Re: of color monitors and triple-clicks

[bill@cambridge.apple.com (Bill St. Clair)]

At  6:03 PM 2/14/94 -0500, Mark A. Tapia wrote:
>On  Mon Feb 14, Chris Crone asks:
>  1)  How can you tell whether the monitor attached to the computer on which
>  MCL is being run is color or not?  I know, for example, that MCL has access
>  to *screen-height* and *screen-width*, but is there a screen-color-p
>  somewhere? *color-available* only tells whether color quickdraw is
>  around, I think, which is not the same.
>
>You can use the utilities in my menu-enhancement package available by ftp
>from cambridge.apple.com in pub/MCL2/contrib/menu-enhancements.sit.hqx.
>Here's a shorter answer:
>
>The short answer is to use the #_getdevicelist and #_getnextdevice traps.

MCL contains some undocumented functions that call these traps. None of
them are exported, so you'll need a "ccl::" package prefix. For those
of you with access to the MCL 2.0 CD, these functions are from the
file "MCL 2.0 CD:Additional MCL Source Code:lib:colors.lisp":

--------------------------------------------------------------------------

(defun screen-attribute (screen attribute)
  (#_TestDeviceAttribute  screen attribute))

(defun screen-active-p (screen)
  (and (screen-attribute screen $screenDevice)
       (screen-attribute screen $screenActive)))

(defun screen-color-p (screen)
  (screen-attribute screen $gdDevType))

(defun screen-bits (screen)
  (rref (rref screen :GDevice.gdPMap) :PixMap.PixelSize))

(defun screen-position (screen)
  (rref screen :GDevice.gdRect.topleft))

(defun screen-size (screen)
  (subtract-points
   (rref screen :GDevice.gdRect.bottomright)
   (screen-position screen)))

(defmacro do-screens ((s &optional (active-only? t)) &body body)
  `(with-macptrs ((,s (require-trap #_GetDeviceList :ptr)))
     (loop
       (if (%null-ptr-p ,s) (return))
       (when ,(if active-only? `(screen-active-p ,s) t)
         ,@body)
       (%setf-macptr ,s (require-trap #_GetNextDevice :ptr ,s :ptr)))))

(unless (assq 'do-screens *fred-special-indent-alist*)
  (push '(do-screens . 1) *fred-special-indent-alist*))

; Return two values, the position and size of the best color screen
; that is near mouse-position.
; If the mouse is on any color screen and most-bits? is nil, return that screen.
; If most-bits? is true, return the color screen with the most bits using
; mouse-position only to break ties.
(defun find-best-color-screen (&key (mouse-position (view-mouse-position nil))
                                    (most-bits? t) screen)
  (if *color-available*
    (rlet ((rect :rect :topleft mouse-position :bottomright (add-points mouse-position #@(1 1))))
      (with-macptrs ((maxScreen (#_GetMaxDevice rect)))
        (let* ((got-max? (not (%null-ptr-p maxScreen)))
               (max-color? (and got-max? (screen-color-p maxScreen)))
               (max-bits (if got-max? (screen-bits maxScreen) 0)))
          (unless (and max-color? (not most-bits?))
            (do-screens (screen)
              (let ((color? (screen-color-p screen))
                    (bits (screen-bits screen)))
                (when (or (%null-ptr-p maxScreen)
                          (and color? (not max-color?))
                          (and (eq color? max-color?)
                               (> bits max-bits)))
                  (setq max-bits bits
                        max-color? color?)
                  (%setf-macptr maxScreen screen))))))
        (if screen
          (%setf-macptr screen maxScreen))
        (values (screen-position maxScreen) (screen-size maxScreen))))
    (progn
      (if screen (%setf-macptr screen (%null-ptr)))
      (values #@(0 0) (make-point *screen-width* *screen-height*)))))

(defun find-screen (point &optional return-screen)
  (when return-screen
    (%setf-macptr return-screen (%null-ptr)))
  (if *color-available*
    (do-screens (screen)
      (let* ((pos (screen-position screen))
             (pos-h (point-h pos))
             (pos-v (point-v pos))
             (size (screen-size screen))
             (h (point-h point))
             (v (point-v point)))
        (declare (fixnum pos-h pos-v h v))
        (when
          (and (<= pos-h h)
               (<= h (the fixnum (+ pos-h (the fixnum (point-h size)))))
               (<= pos-v v)
               (<= v (the fixnum (+ pos-v (the fixnum (point-v size))))))
          (when return-screen (%setf-macptr return-screen screen))
          (return (values pos size)))))
    (let ((size (make-point *screen-width* *screen-height*)))
      (and (point<= #@(0 0) point size)
           (values #@(0 0) size)))))