;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Author      : Mike Byrne
;;; Copyright   : (c)1999-2001 CMU/Rice U./Mike Byrne, All Rights Reserved
;;; Availability: public domain
;;; Address     : Rice University
;;;             : Psychology Department
;;;             : Houston,TX 77251-1892
;;;             : byrne@acm.org
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : mcl-screen.lisp
;;; Version     : 1.0b7
;;; 
;;; Description : Using multiple windows in MCL requires a new virtual device.
;;;             : Here's one to handle multiple windows.  See the usage notes
;;;             : at the end of the file.
;;; 
;;; Bugs        : 
;;; 
;;; Todo        : 
;;; 
;;; ----- History -----
;;; 99.05.04 Mike Byrne
;;;             :  Incept date.  Minimal testing.
;;; 01.07.03 mdb
;;;             : Made some fixes for the vector conversion.  Minimal testing.
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass mcl-screen ()
  ((the-windows :accessor the-windows :initform nil :initarg :windows)))


;;;; ---------------------------------------------------------------------- ;;;;
;;;; RPM device methods
;;;; ---------------------------------------------------------------------- ;;;;


;;; DEVICE-HANDLE-KEYPRESS      [Method]
;;; Description : The frontmost window that is part of the device gets to 
;;;             : handle the keypress.

(defmethod device-handle-keypress ((device mcl-screen) key)
  "Handle a keypress for MCL screen device object."
  (view-key-event-handler (front-device-window device) key)
  (event-dispatch))


;;; DEVICE-HANDLE-CLICK      [Method]
;;; Description : Handling a click means we have to determine which click
;;;             : the window is in.  Since windows can overlap, this could be
;;;             : multiple different windows.  Compute which windows contain
;;;             : the clickpoint, and only click in the front one.

(defmethod device-handle-click ((device mcl-screen))
  "Handle a click in an MCL screen device."
  (let ((possible-wins nil)
        (clickpoint (get-mouse-coordinates device)))
    (dolist (tw (the-windows device))
      (when (xy-in-window-p tw clickpoint)
        (push tw possible-wins)))
    (if possible-wins
      (let ((clickwin (front-device-window device possible-wins)))
        (window-select clickwin)
        (view-click-event-handler clickwin (view-mouse-position clickwin))
        (event-dispatch))
      (beep))))


;;; BUILD-FEATURES-FOR      [Method]
;;; Description : Just build the features for all the windows, but in global
;;;             : coordinates, and return that list.

(defmethod build-features-for ((device mcl-screen) 
                                  (vis-mod vision-module))
  (let ((accum nil))
    (dolist (tw (the-windows device) accum)
      (setf accum
            (append accum (mklist (globalized-feats tw vis-mod)))))))



;;; GLOBALIZED-FEATS      [Method]
;;; Description : The coordinate system used for the screen is the global
;;;             : system, so to build the features for a window, build them
;;;             : as normal but do a global-to-local on all the coordinates.

(defmethod globalized-feats ((wind window) (vis-mod vision-module))
  "Builds a list of features for an MCL window that have been 'globalized'."
  (let ((feat-ls (build-features-for wind vis-mod))
        (global-loc nil))
    (dolist (feat feat-ls feat-ls)
      (setf global-loc (local-to-global wind (vpt2p (xy-loc feat))))
      (setf (screen-x feat) (point-h global-loc))
      (setf (screen-y feat) (point-v global-loc)))))


;;; DEVICE-MOVE-CURSOR-TO      [Method]
;;; Description : Same as for a regular MCL window, but this time assume
;;;             : all coordinates are global.

(defmethod device-move-cursor-to ((device mcl-screen) (xyloc vector))
  "Move the cursor to absolute screen location <xyloc>."
  (let ((absloc (vpt2p xyloc)))
    (without-interrupts
     (ccl::%put-point (%int-to-ptr #$MTemp) absloc)
     (ccl::%put-point (%int-to-ptr #$RawMouse) absloc)
     (%put-word (%int-to-ptr #$CrsrNew) -1))
    (when (with-cursor-p (device-interface *mp*))
      (while (eql (%get-signed-word (%int-to-ptr #$CrsrNew)) -1))
      (update-cursor))))


;;; GET-MOUSE-COORDINATES      [Method]
;;; Description : Return the current mouse loc in (x y) format.

(defmethod get-mouse-coordinates ((device mcl-screen))
  "Return global mouse coordinates."
  (p2vpt (view-mouse-position nil)))


;;; DEVICE-SPEAK-STRING      [Method]
;;; Description : If the Mac Speech Manager is installed, actually speak the
;;;             : string.

(defmethod device-speak-string ((device mcl-screen) string)
  (when (speech-available-p)
    (speak-string string)))


(defmethod cursor-to-feature ((device mcl-screen))
  (let ((pos (view-mouse-position nil))
        (shape (window-cursor (front-device-window device))))
    (make-instance 'cursor-feature
      :x (point-h pos) :y (point-v pos)
      :value (case shape
               (*i-beam-cursor* 'I-BEAM)
               (*crosshair-cursor* 'CROSSHAIR)
               (*watch-cursor* 'WATCH)
               (otherwise 'POINTER)))))


;;;; ---------------------------------------------------------------------- ;;;;
;;;; Utility methods for MCL screen objects
;;;; ---------------------------------------------------------------------- ;;;;

(defmethod add-window ((self mcl-screen) the-window)
  "Add a window to an MCL screen device object."
  (push the-window (the-windows self)))


(defmethod remove-window ((self mcl-screen) the-window)
  "Remove a window from an MCL screen device object."
  (setf (the-windows self) (delete the-window (the-windows self))))


(defmethod front-device-window ((device mcl-screen) &optional window-ls)
  "Return the frontmost window of the device."
  (unless window-ls
    (setf window-ls (the-windows device)))
  (first
   (sort window-ls #'< :key #'window-layer)))


(defmethod xy-in-window-p ((wind window) xyloc)
  "Is the specified <xyloc> (global coords) in window <tw>?"
  (rlet ((the-rect rect))
    (points-to-rect (view-position wind)
                    (add-points (view-position wind) (view-size wind))
                    the-rect)
    (point-in-rect-p the-rect (vpt2p xyloc))))



;;;; ---------------------------------------------------------------------- ;;;;
#|
So here's how you'd use it.  Let's say you have two windows that you want
RPM to interact with, *window1* and *window2*.  You'd do something like this:

(defvar *screen*)

(setf *screen* (make-instance 'mcl-screen))

(add-window *screen* *window1*)
(add-window *screen* *window2*)

(pm-install-device *screen*)

And you should be ready to roll.

|#