USER_PICK_COLOR

["Roland Zito-wolf" <rjz@chaos.cs.brandeis.edu>]

I had a related problem with this function, in that my color monitor
(a) wasn't the main one, and (b) was rearranged in logical scrren space
by other users. Below is a version of USER_PICK_COLOR that locates a 
color screen if present and positions the color menu there.
It also includes some RECORD defs that are missing from the 
released Library; i only guarantee the correctness of the fields I used.

(defun find-color-window (&optional avoidlist)
   (loop with color? and active? and screen?
            for i from 1
            for devhandle first (_GetMainDevice :ptr) then (_GetNextDevice :ptr devhandle :ptr)
            while devhandle
            do (setq  color? (logbitp 8 (_TestDeviceAttribute :ptr devhandle :word 0 :word))
                           active? (logbitp 8 (_TestDeviceAttribute :ptr devhandle :word 15 :word))
                           screen? (logbitp 8 (_TestDeviceAttribute :ptr devhandle :word 13 :word)))
            if (and screen? active? color? (not (member i avoidlist))) do (return devhandle)
            ))

(in-package :ccl)
(defrecord (GDevice :handle)
   (gdRefNum integer)
   (gdID integer)
   (gdType integer)
   (gdITable handle)
   (gdResPref integer)
   (gdSearchProc handle)
   (gdCompProc handle)
   (gdFlags integer)
   (gdPMap handle)
   (gdRefCon longint)
   (gdNextGD handle)
   (gdRect Rect)
   (gdMode longint)
   (gdCCBytes integer)
   (gdCCDepth integer)
   (gdCCXData handle)
   (gdCCXMask handle)
   (gdReserved longint)
   )


(defun find-colored-area (&optional avoidlist)
   (let ((dh (find-color-window avoidlist)))
      (if dh (rref dh :GDevice.gdRect.topleft) #@(10 10))))

(defun describe-all-screens ()
   (loop with color? and active? and screen?
            for i from 1
            for devhandle first (_GetMainDevice :ptr) then (_GetNextDevice :ptr devhandle :ptr)
;            do (format t "~% handle=~A" devhandle)
            while devhandle
            do (setq  color? (logbitp 8 (_TestDeviceAttribute :ptr devhandle :word 0 :word))
                           active? (logbitp 8 (_TestDeviceAttribute :ptr devhandle :word 15 :word))
                           screen? (logbitp 8 (_TestDeviceAttribute :ptr devhandle :word 13 :word)))
            do (format t "~% color? = ~A active=~A screen=~A for handle ~A=~A" 
                              color? active? screen?  i devhandle)
              do  (format t "~%    GDType=~A TOP=~A LEFT=~A BOTTOM=~A RIGHT=~A"
                                 (rref devhandle :GDevice.gdType)
                                 (rref devhandle :GDevice.gdRect.top)
                                 (rref devhandle :GDevice.gdRect.left)
                                 (rref devhandle :GDevice.gdRect.bottom)
                                 (rref devhandle :GDevice.gdRect.right))
            ))

(defun pick-color (&optional (color *black-color*) (prompt "Pick a color"))
   (let ((pos (find-colored-area '(1))))
      (if pos
         (with-pstrs ((prmt prompt))
                (with-rgb (in color)
                       (with-rgb (out *black-color*)
                             (_GetColor :long (add-points pos #@(50 50)) :ptr prmt  :ptr in :ptr out :word)
                              (rgb-to-color out)
                     )))
         (user-pick-color color prompt))))