Re: other screens

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

At  3:01 PM 3/22/94 -0400, bright@ENH.NIST.GOV wrote:
>Greetings.
>Anyone have some functions that give the posisitions (rects) for screens
>other than the main one?
>I believe *screen-size* and *screen-position* are confined to the screen
>with the menubar.
>Thanks
>:8o)
>Dave

There are a bunch of unexported functions that MCL uses to figure
out where to pop up the color picker. They are in the file
"MCL 2.0 CD:Additional MCL Source Code:lib:color.lisp" and
are included here in case you don't have a CD player. Most of
them are not exported, so you'll need a "ccl::" package prefix.
The source is the only documentation I have, but if you fail
to understand it, I can probably help out.

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

(defun user-pick-color (&key (color *black-color*)
                             (prompt "Pick a color")
                             (position (default-pick-color-position)))
  "lets the user choose a color with the standard mac window"
  (with-cursor *arrow-cursor*
    (if *color-available*
        (with-rgb (rgb color)
          (with-pstrs ((pp prompt))
            (if (#_GetColor position pp rgb rgb)
                (rgb-to-color rgb)
                (throw-cancel))))
        (if (y-or-n-dialog prompt
                           :yes-text "Black"
                           :no-text "White")
            *black-color*
            *white-color*))))

;; Find the deepest screen.
;; If there is a choice, use the one that the nearby-window is on.
(defun default-pick-color-position (&optional (mouse-position (view-mouse-position nil)))
  (multiple-value-bind (position size)
                       (find-best-color-screen :mouse-position mouse-position)
    (let ((width (point-h size))
          (height (point-v size))
          (dialog-width 440)
          (dialog-height 280))          ; determined emperically
    (add-points position
                (make-point (floor (- width dialog-width) 2)
                            (floor (- height dialog-height) 3))))))

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