;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Author      : Dan Bothell
;;; Copyright   : (c)2002 CMU/Dan Bothell, All Rights Reserved
;;; Availability: public domain
;;; Address     : Carnegie Mellon University
;;;             : Psychology Department
;;;             : Pittsburgh,PA 15213-3890
;;;             : db30+@andrew.cmu.edu
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : act-gui-interface.lisp
;;; Version     : 2.1b7
;;; 
;;; Description : Contains the functions that implement the abstract GUI
;;;             : interface used by the tutorial units and the misc functions
;;;             : that go with them (permute-list, correlation and 
;;;             : mean-deviation).  I'm calling it the ACT-R GUI interface
;;;             : (AGI) as suggested by Mike.
;;;             : It relies on the UWI (at least for now).
;;; Bugs        : 
;;; --- History ---
;;; 2002.06.30 Dan
;;;             : Added this header.
;;;             : Renamed this file from uniform-interface-exp to 
;;;             : act-gui-interface.
;;;             : Added comments.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; *LIBRARY-EXPERIMENT-WINDOW*  [Global Variable]
;;; Description : This variable is used to hold the window that's opened with
;;;             : the AGI function open-exp-window.

(defvar *library-experiment-window* nil "Global AGI window")

;;; OPEN-EXP-WINDOW  [Function]
;;; Description : This function opens a window, either real, virtual, or
;;;             : visible-virtual as requested.  If there's already a window
;;;             : with those specs open it's cleared and used.

(defun open-exp-window (title &key (width 300) (height 300) (visible t) 
                                  (x 300) (y 300))
  "Open an experiment window"
  (if (open-rpm-window? *library-experiment-window*)
      (if (and (string-equal title (rpm-window-title 
                                    *library-experiment-window*))
               (eql visible (rpm-window-visible-status 
                             *library-experiment-window*))) 
          (progn
            (remove-all-items-from-rpm-window *library-experiment-window*)
            *library-experiment-window*)
        (progn
          (close-exp-window)
          
          (setf *library-experiment-window* (make-rpm-window 
                                             :visible visible 
                                             :title title
                                             :width width 
                                             :height height
                                             :x x
                                             :y y))))
    (setf *library-experiment-window* (make-rpm-window 
                                       :visible visible 
                                       :title title
                                       :width width 
                                       :height height
                                       :x x
                                       :y y)))
  (select-rpm-window *library-experiment-window*)
  *library-experiment-window*)

;;; SELECT-EXP-WINDOW  [Function]
;;; Description : Brings the *library-experiment-window* to the front.

(defun select-exp-window ()
  "select the experiment window"
  (select-rpm-window *library-experiment-window*))

;;; CLOSE-EXP-WINDOW  [Function]
;;; Description : Closes the *library-experiment-window*.

(defun close-exp-window ()
  "Close the experiment window"
  (close-rpm-window *library-experiment-window*)
  (setf *library-experiment-window* nil))

;;; CLEAR-EXP-WINDOW  [Function]
;;; Description : Removes all items from *library-experiment-window*.

(defun clear-exp-window ()
  "Erases everything in the experiment window"
  (remove-all-items-from-rpm-window *library-experiment-window*))

;;; REMOVE-ITEMS-FROM-EXP-WINDOW  [Function]
;;; Description : Removes the requested items from *library-experiment-window*.

(defun remove-items-from-exp-window (&rest items)
  "Remove the specified items from the experiment window"
  (apply #'remove-visual-items-from-rpm-window 
         (cons *library-experiment-window* items)))

;;; ADD-TEXT-TO-EXP-WINDOW  [Function]
;;; Description : Build a text item based on the parameters supplied and
;;;             : add it to *library-experiment-window*.

(defun add-text-to-exp-window (&key (x 0) (y 0) (text "") (height 20) 
                                    (width 75))
  "Create and display a text item in the experiment window"
 (let ((item (make-static-text-for-rpm-window 
                                   *library-experiment-window* 
                                   :text text 
                                   :x x
                                   :y y
                                   :width width
              :height height)))
   (add-visual-items-to-rpm-window *library-experiment-window* item)
   item))

;;; ADD-BUTTON-TO-EXP-WINDOW  [Function]
;;; Description : Build a button item based on the parameters supplied and
;;;             : add it to *library-experiment-window*.

(defun add-button-to-exp-window (&key (x 0) (y 0) (text "Ok") 
                                          (action nil) (height 18) 
                                          (width 60))
  "Create and display a button item in the experiment window"
  (let ((item (make-button-for-rpm-window *library-experiment-window*
                                                              :x x
                                                              :y y
                                                              :text text
                                                              :action action
                                                              :height height
                                          :width width)))
    (add-visual-items-to-rpm-window *library-experiment-window* item)
    item))

;;; ADD-LINE-TO-EXP-WINDOW  [Function]
;;; Description : Build a line item based on the parameters supplied and
;;;             : add it to *library-experiment-window*.

(defun add-line-to-exp-window (start-pt end-pt &optional (color 'black))
  "Create and display a line item in the experiment window"
  (let ((item (make-line-for-rpm-window *library-experiment-window*
                                        start-pt end-pt color)))
    (add-visual-items-to-rpm-window *library-experiment-window* item)
    item))

;;;; ---------------------------------------------------------------------- ;;;;
;;;; The miscelaneous functions used in the tutorial.
;;;; ---------------------------------------------------------------------- ;;;;

;;; PERMUTE-LIST  [Function]
;;; Description : This function returns a randomly ordered copy of the passed
;;;             : in list.

(defun permute-list (lis)
  "Return a random permutation of the list"
  (do* ((item (nth (random (length lis)) lis) (nth (random (length temp)) temp))
        (temp (remove item lis :count 1) (remove item temp :count 1))
        (result (list item) (cons item result)))
       ((null temp) result)))

;;; This is the correlation and deviation functions from the scripting
;;; extensions file and the necessary support.  I figured since they are
;;; still used they should be put here because the scripting extensions 
;;; aren't part of ACT-R 5, but making people load the scripting file
;;; separately is a pain...  I also changed mean-deviation so that it
;;; actually returned the deviation.

(defstruct data labels array)

(defmacro /-safe (number &rest dividers)
  `(/ ,number ,@(let ((max nil))
                  (dolist (divider dividers max)
                    (push-last `(if (zerop ,divider) 1 ,divider) max)))))

(defun numbers-list (structure)
  (let ((list nil))
    (when (data-p structure) (setf structure (data-array structure)))
    (cond ((arrayp structure)
           (dotimes (i (array-total-size structure))
             (let ((data (row-major-aref structure i)))
               (when (numberp data) (push data list)))))
          ((listp structure)
           (dolist (data structure)
             (cond ((listp data)
                    (setf list (append (nreverse (numbers-list data)) list)))
                   ((numberp data)
                    (push data list)))))
          ((numberp structure)
           (push structure list))
          (t (format t "~&UNKNOWN DATA FORMAT ~S NOT COMPATIBLE WITH NUMBERS LIST.~%"
                     structure)))
    (nreverse list)))

(defun square-data (x)
  (* x x))

(defun sum-list (list)
  (let ((sum 0.0))
    (dolist (data list sum)
      (incf sum data))))

(defun square-list (list)
  (let ((sum 0.0))
    (dolist (data list sum)
      (incf sum (square-data data)))))

(defun product-list (list1 list2)
  (let ((sum 0.0))
    (loop
      (when (or (null list1) (null list2)) (return sum))
      (incf sum (* (pop list1) (pop list2))))))

(defun mean-deviation (results data &key (output t))
  (let* ((results-list (numbers-list results))
         (data-list (numbers-list data))
         (n (min (length results-list) (length data-list))))
    (unless (eq output t)
      (cond ((or (stringp output) (pathnamep output) (streamp output))
             (setf output (open output :direction :output :if-exists :append
                                :if-does-not-exist :create)))
            (t
             (format t "~&OUTPUT ARGUMENT ~S TO MEAN-DEVIATION IS NOT A VALID STRING, PATHNAME OR STREAM.~%"
                     output)
             (setf output t))))
    (unless (= (length results-list) (length data-list))
      (format t "~&ERROR: ~S AND ~S DO NOT HAVE THE SAME NUMBER OF NUMBERS.~%"
              results data))
    (let ((result (sqrt (/ (+ (square-list results-list) (square-list data-list)
                              (* -2.0 (product-list results-list data-list)))
                           n))))
      (format output "~&MEAN DEVIATION: ~6,3F~%" result)
      (unless (eq output t) (close output))
      
      result)))

(defun correlation (results data &key (output t))
  (let* ((results-list (numbers-list results))
         (data-list (numbers-list data))
         (n (min (length results-list) (length data-list)))
         (average-results (/-safe (sum-list results-list) n))
         (average-data (/-safe (sum-list data-list) n)))
    (unless (eq output t)
      (cond ((or (stringp output) (pathnamep output) (streamp output))
             (setf output (open output :direction :output :if-exists :append
                                :if-does-not-exist :create)))
            (t
             (format t "~&OUTPUT ARGUMENT ~S TO CORRELATION IS NOT A VALID STRING, PATHNAME OR STREAM.~%"
                     output)
             (setf output t))))
    (unless (= (length results-list) (length data-list))
      (format t "~&ERROR: ~S AND ~S DO NOT HAVE THE SAME NUMBER OF NUMBERS.~%"
              results data))
    (let ((result (/-safe (- (/-safe (product-list results-list data-list) n)
                       (* average-results average-data))
                    (* (sqrt (- (/-safe (square-list results-list) n)
                                (square-data average-results)))
                       (sqrt (- (/-safe (square-list data-list) n)
                                (square-data average-data)))))))
      (format output "~&CORRELATION: ~6,3F~%"
            result)
    (unless (eq output t) (close output))
    result)))