;;; -*- Mode:COMMON-LISP; Package:X11; Base:10.; Fonts:(medfnb hl12B hl12bi) -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1987, Texas Instruments Incorporated. All rights reserved.

;;; Change history:
;;;
;;;  Date       Author      Description
;;; -------------------------------------------------------------------------------------
;;; 03/10/89	WJB	Patch 1.39; Modify EXPLORER-GET-PIXEL to avoid use of *resources*
;;; 12/22/88    LGO     Fix Alloc-Color-Cells1 and* Alloc-Color-Planes to 
;;;			return an access-error, because we only support static color maps.
;;; 12/22/88    LGO     Add better error checking to Store-Colors.
;;; 12/21/88    LGO     Keep free-colormap out of the error handler.
;;; 12/21/88    LGO     Report bad-idchoice in create-colormap when the visual isn't found.
;;; 11/23/88    LGO     1Optimize FIND-COLOR*
;;; 11/11/88    DAN     Fix LOOKUP-COLOR to generate BAD-COLOR error.
;;; 11/09/88	WJB	Fix error in UNINSTALL-COLORMAP.
;;; 110/19*/88	LGO	1Fix ALLOC-NAMED-COLOR to return correct pixel number*
;;; 110/19*/88	LGO	1Fix ALLOC-NAMED-COLOR to get correct color name byte count*
;;;  9/20/88	LGO	1Re-write find-color*
;;;  9/20/88	LGO	Make 1the reply from *Alloc-Color-Cells1 and *Alloc-Color-Planes1 the correct length*
;;;  9/20/88	LGO	Make query-colors work.
;;;  9/20/88	LGO	Keep CREATE-COLORMAP and Install-Colormap out of the error handler
;;;  9/12/88	LGO	Fix explorer-get-pixel to call alloc-color correctly
;;;  7/21/88	DAN	Added EXPLORER-GET-PIXEL.
;;;  4/04/88	TWE	Corrected COLORMAP-NOTIFY-EVENT.
;;;  3/31/88	KDB	1A*dded COLORMAP-NOTIFY-EVENT (written by DAN).
;;; 12/09/87	KDB	Created

;;; 1This file contains Monochrome color server requests.*


;;;	The default-colormap is the one initially associated with the root
;;;	window.  Clients with minimal color requirements creating windows of
;;;	the same depth as the root may want to allocate from this map by
;;;	default.

;;;	Black-pixel and white-pixel can be used in implementing a "monochrome"
;;;	application.  These pixel values are for permanently allocated entries
;;;	in the default-colormap.  The actual RGB values may be settable on some
;;;	screens, and in any case may not actual be "black" and "white".  The
;;;	names are intended to convey the expected relative intensity of the
;;;	colors.

;;;	Min-installed-maps specifies the number of maps that can be guaranteed
;;;	to be installed simultaneously (with InstallColormap), regardless of
;;;	the number of entries allocated in each map.  Max-installed-maps
;;;	specifies the maximum number of maps that might possibly be installed
;;;	simultaneously, depending on their allocations; multiple static-visual
;;;	colormaps with identical contents but differing in resource id should
;;;	be considered as a single map for the purposes of this number.  For the
;;;	typical case of a single hardware colormap, both values will be one.


#|
Debug code
(setq my-map (make-colormap 1:id 11111*)1 *)1  ;(resource.type my-map) (resource.entries my-map)*
(typep (aref my-map 1))
;;(colormap-type 1my-*map)
;;(colormap-entries my-map)
;1;; *(aref my-map 12*)
1(SETQ WHITE-PIXELS (CAR *SCREEN-WHITE-PIXELS*))    ; INDEX TO GET WHITE RGB VALS IN COLORMAP ENTRY
(SETF * 1BLACK-PIXELS (CAR *SCREEN-BLACK-PIXELS* ))
(SETQ RED 0) ; FIRST SLOT IN COLORMAP ENTRY STRUCTURE
(SETQ GREEN 1) ; SECOND SLOT ...
(SETQ BLUE 2) ; THIRD ELT OF COLORMAP ENTRY STRUCTURE*

;;;1 *(colormap-type my-map)
;;;(setq black-rgbs  (aref (colormap-1entries* my-map) black-pixel1s*))
;;;(1setq* white-rgb1s  *(aref (colormap-1entries* my-map) 1white*-pixel1s*))
;;;(aref black-rgbs r1ed*)1  ; use an index, not the :conc-name*
;;;(aref 1white*-rgbs 1green*)
|#


1;;; A WAY TO GET A COLOR VALUE.. SHOULD MAYBE DEFSUBST IT..*

(defsubst get-rgb-vals (colormap entry)
  "2a way to get at a color value ...
Returns the red, green and blue values for this entry in the colormap.*"
  (let ((rgb-vals (aref (colormap.entries colormap) entry)))
    (values (colormap-entry.red   rgb-vals)
            (colormap-entry.green rgb-vals)
            (colormap-entry.blue  rgb-vals))))

#|
Debug code
;(get-rgb-val my-map 1WHITE-PIXELS * red)
;(get-rgb-val my-map black-pixels 1blue)*
;
|#

(DEFUN  CREATE-COLORMAP (ALLOC CMAP WINDOW VISUAL-ID)
 1"*	1Creates a colormap of the specified visual typ*e1 for the screen on which*
	1the window resides, and associates the identifier mid with it. *

	1Errors: IDChoice, Window, Value, Match, Alloc*

	Creates a colormap of the specified visual type for the screen on which
	the window resides, and associates the identifier mid with it.  The
	visual type must be one supported by the screen (else a Match error).
	The initial values of the colormap entries are undefined for classes
	GrayScale, PseudoColor, and DirectColor; for STATICGRAY, StaticColor,
	and TrueColor, the entries will have defined values, but those values
	aRE SPECIFIC TO THE VISUAL and are not defined by the core protocol.
	For STATICGRAY, StaticColor, and TrueColor, alloc must be specified as
	None (else a Match error).  For the other classes, if alloc is None,
	the colormap initially has no allocated entries, and clients can
	allocate entries.

	If alloc is All, then the entire colormap is 1allocated* writable.  The
	initial values of all allocated entries are undefined.  For GrayScale
	and PseudoColor, the effect is as if an AllocColor request returned all
	pixel values from zero to N-1, where N is the colormap-entries value in
	the specified visual.  For DirectColor, the effect is as if an
	AllocColorPlanes request returned a pixel value of zero and red-mask,
	green-mask, and blue-mask values containing the same bits as the
	corresponding masks in the specified visual.  However, in all cases,
	none of these entries can be freed with FreeColors.1"*
  (DECLARE (TYPE INTEGER ALLOC CMAP VISUAL-ID)
           (TYPE WINDOW WINDOW))
  (LET ((VISUAL (gethash VISUAL-ID *resources*)))
    ;; We can't allocate any color cells since we are monochrome and can't allocate pixel values.
    (COND ((not (visual-p visual))
	   (bad-value visual-id))
	  ((= ALLOC MAP-ALLOC-ALL)
           (BAD-MATCH))
          ((NOT (= (VISUAL.CLASS VISUAL) STATIC-GRAY))
           ;; The monochrome server doesn't support much.
           (BAD-MATCH))
          (T
           (STORE-RESOURCE CMAP (SIMPLY-CREATE-COLORMAP CMAP WINDOW VISUAL))))))

(DEFUN SIMPLY-CREATE-COLORMAP (CMAP-ID WINDOW VISUAL)
  (MAKE-COLORMAP :ID CMAP-ID
                 :WINDOW WINDOW
                 :CLASS (VISUAL.CLASS VISUAL)
                 :SCREEN (SCREEN-FOR-WINDOW WINDOW)))

(Defreq Create-Colormap ((alloc (CARD8 Map-Alloc-None Map-Alloc-All))
			 (cmap NEWID)
			 (window WINDOW)
			 (visual CARD32))
  (Create-Colormap alloc cmap window visual))





(DEFUN Colormap-Notify-Event (window colormap new-p state)
  (DECLARE (type window colormap window)
           (type boolean new-p)
           (type colormap-type state))           ;???
  (LET ((event (make-event-colormap :type Colormap-Notify-Event
                                    :window window
                                    :colormap colormap
                                    :new new-p
                                    :state state)))
        (deliver-events window event 1 nil)))

;;; note1 THE WINDOW TREE TRAVERSAL IS ALSO NOT HERE YET... *

(DEFUN FREE-COLORMAP (CMAP STATE)
  "	Deletes the association between the resource id and the colormap.  If
	the colormap is an installed map for a screen, it is uninstalled (see
	UninstallColormap).  If the colormap is defined as the colormap for a
	window (via CreateWindow or ChangeWindowAttributes), the colormap for
	the window is changed to None, and a ColormapNotify event is generated.
	The colors displayed for a window with a colormap of None are not
	defined by the protocol.

	Has no effect on a default colormap for a screen.

 2   *	Errors: Colormap"
  
  (LET ((CID (COLORMAP.ID CMAP))
        (WINDOW (COLORMAP.WINDOW CMAP)))
    (unless (= CID (SCREEN.DEF-COLORMAP (COLORMAP.SCREEN CMAP)))
      (REMOVE-RESOURCE CID))
    (COLORMAP-NOTIFY WINDOW CMAP NIL STATE)))
		
(defreq Free-Colormap ((:solo)
		       (cmap COLORMAP))
  (Free-Colormap cmap state))


(DEFUN COPY-COLORMAP-AND-FREE (NEW-CMAP SRC-CMAP)
"	CREATES A COLORMAP OF THE SAME VISUAL TYPE AND FOR THE SAME SCREEN AS  
	SRC-CMAP, AND ASSOCIATES IDENTIFIER MID WITH IT. 
	  
	ERRORS: IDCHOICE, COLORMAP, ALLOC"
  (WHEN (NOT (TYPEP SRC-CMAP 'COLORMAP))
    (BAD-COLORMAP SRC-CMAP))
  (LET* ((WINDOW (COLORMAP.WINDOW SRC-CMAP)) 
	 (VISUAL-TYPE   MONOCHROME)   ;1 B&W, THE TYPE IS ALWAYS 0. .*
         (GNU-CMAP (CREATE-COLORMAP MAP-ALLOC-NONE NEW-CMAP WINDOW VISUAL-TYPE)))
   GNU-CMAP))                                                                                                       

;;(SCREEN.ROOT-VISUAL XLIB:EXPLORER-SERVER )
;;(DEFVAR WW NIL)

(defreq Copy-Colormap-And-Free ((new-cmap NEWID)
				(src-cmap COLORMAP))
  (Copy-Colormap-And-Free new-cmap src-cmap))


;;; 1DOCUMENTATION ALERT:*
;;; A monochrome frame buffer is a static gray colormap with two entries.
;;; We have a "required list" of length 1.  Because we can only support 1
;;; colormap, we never have to change it, but we may have to change the 
;;; name we call it.  If someone installs a new colormap, we know it must
;;; look just like the old one (because we've checked in dispatch that it was
;;; a valid colormap identifier, and all the colormap IDs for this device
;;; look the same).  Nevertheless, we still have to uninstall the old colormap
;;; and install the new one.  Similarly, if someone uninstalls a colormap,
;;; we have to install the default map, even though we know those two looked
;;; alike.  
;;; The required list concept is pretty much irrelevant when you can only
 ;;; have one map installed at a time.  


;1;; FOR NOW, WE ARE GOING TO FAKE THE COLORMAP NOTIFY...*
;;1; THE WINDOW TREE TRAVERSAL IS ALSO NOT HERE YET... *

#|
Debug code
;;(SETF (SCREEN.ROOT-VISUAL) (WINDOW.PARENT 

|#

(DEFUN COLORMAP-NOTIFY (WINDOW COLORMAP NEW STATE)
  "	window: WINDOW
	colormap: COLORMAP or None
	new: BOOL
	state: {Installed, Uninstalled}

	Reported to clients selecting ColormapChange on the window.  Generated
	with value True for new when the colormap attribute of the window is
	changed.  Generated with value False for new when the colormap of a
	window is installed or uninstalled.  In either case, state indicates
	whether the colormap is currently installed."

  (IGNORE WINDOW COLORMAP NEW STATE))

(DEFUN INSTALL-COLORMAP  (STATE CMAP)
  1"*	Makes this colormap an installed map for its screen.  All windows
	associated with this colormap immediately display with true colors.
 
1   *	1Errors: Colormap"*
  ;; 	the default colormap for a screen should be  installed (but is not in
  ;;	the required list. if not, then install cmap. 
  ;;    DON'T INSTALL CMAP IT IT IS THE DEFAULT COLORMAP... IT IS ALREADY INSTALLED... 
  ;;    WE STILL NEED TO ADD A MECHANISM TO WALK THE1 WINDOW LIST.* SEE THE C CODE AND SPEC.
  
  
  (LET ((DEF-CMAP (GETHASH (SCREEN.DEF-COLORMAP (COLORMAP.SCREEN CMAP))
			   *RESOURCES*))
        (NEW-CMAP NIL))
    
    (WHEN (NOT (EQL (COLORMAP.ID CMAP)  (COLORMAP.ID DEF-CMAP)))
      (SETQ NEW-CMAP T)
      (SETQ *INSTALLED-COLORMAPS* (LIST CMAP))
      (SETF DEF-CMAP CMAP))            ;1 IF NOT DEFAULT COLORMAP, INSTALL IT*
    
;;;	If cmap is not already an installed map, a ColormapNotify event is
;;;	generated on every window having cmap as an attribute.  In addition,
;;;	for every other colormap that is installed or uninstalled as a result
;;;	of the request, a ColormapNotify event is generated on every window
;;;	having that colormap as an attribute.
    
    (COLORMAP-NOTIFY (COLORMAP.WINDOW CMAP) CMAP NEW-CMAP STATE)))


(DEFREQ INSTALL-COLORMAP ((CMAP COLORMAP))
  (INSTALL-COLORMAP STATE CMAP))

 
(DEFUN UNINSTALL-COLORMAP (STATE CMAP)
  1"*	1If cmap is on the *''1required list*''2 1for its screen (see InstallColormap),**
	1it is removed from the list.  As a side-effect, cmap might be*
	1uninstalled, and additional colormaps might be implicitly installed or*
	1uninstalled.  

          Errors: Colormap"*
  
  1;;  Uninstalling the default colormap is a no-op*
  (LET ((DEF-CMAP (GETHASH (SCREEN.DEF-COLORMAP (COLORMAP.SCREEN CMAP))
			   *RESOURCES*))
	(NEW-CMAP NIL)
        WINDOW)
    (UNLESS (EQL (COLORMAP.ID CMAP) (COLORMAP.ID DEF-CMAP))
      (SETQ NEW-CMAP T)
      (SETF DEF-CMAP CMAP)
;;;	If cmap becomes uninstalled, a ColormapNotify event is generated on
;;;	every window having cmap as an attribute.  In addition, for every other
;;;	colormap that is installed or uninstalled as a result of the request, a
;;;	ColormapNotify event is generated on every window having that colormap
;;;	as an attribute.
      ;1;*
      ;1; IMPLEMENTATION NOTE: STILL NEED TO DO THE ACTUAL WINDOW TREE TRAVERSAL,*
      ;;1                        TO NOTIFY WINDOWS OF GAINING OR LOSING A MAP. SEE C.*
      (COLORMAP-NOTIFY WINDOW  CMAP NEW-CMAP STATE))))

(Defreq Uninstall-Colormap ((cmap COLORMAP))
  (Uninstall-Colormap STATE cmap)) 
1       *
(defun List-Installed-Colormaps (STATE window )
  1"*	1Returns a list of the currently installed colormaps for the screen of*
	1the specified window.  The order of colormaps is not significant, and*
	1there is no explicit indication of the 2''*required list2''* (see*
	1InstallColormap).

  *	1Errors: Windows*  "
  1;; always will just have one2 *for the monochrome case.*
  (IGNORE WINDOW)
  (LET ((LIST-OF-CMAPS (LOOP FOR MAP IN *INSTALLED-COLORMAPS*	
                             COLLECTING (COLORMAP.ID MAP)))
        LONG-COUNT				
        OUTPUT-BUFFER-LENGTH)
    (SETQ LONG-COUNT (LENGTH *INSTALLED-COLORMAPS*))
    
    (FORMAT-REPLY (STATE LONG-COUNT)
                  :WORD LONG-COUNT)     
    (SERVER-PUSH STATE)			
    (setq output-buffer-length (loop with output-index = 0
                                     for CMAP in LIST-OF-CMAPS
                                     do (progn  (setq output-index (simple-reply
                                                                     (state output-index)
                                                                     :long  CMAP)))
                                     finally (return output-index)))
    (server-string-out state (response.bytes (state.response state)) output-buffer-length)
    (server-push state)))

(defreq List-Installed-Colormaps ((window window))
  (List-Installed-Colormaps STATE window ))

;1; THE FOLLOWING DIFFERENCE CALCULATION *MAY 1APPLY WHEN WE HAVE AN ACTUAL COLOR SYSTEM*
;1; IT *IS 1NOT THE WAY TO DO IT WITH B& W.*
;;; AllocColor will return the first color
;;;in the colormap which has the smallest numerical differences from the given
;;;pixel.  The calculation to compute the differences is:

;;;	diff = dr * dr + dg * dg + db * db 
       
;;;where dr, dg and db are the differences between the given red, green and blue
;;;values and a candidate pixel's reg, gree and blue values, respectively.
;;;Nothing fancy is done if there are multiple pixels with the same minimal
;;;difference -- the first one is chosen.

(defun Alloc-Color (cmap red green blue state &optional (send-reply t))
  1"*	1Allocates a read-only colormap entry corresponding to the closest RGB*
	1values provided by the hardware.  Returns the pixel and the RGB values*
	1actually used.*

	1Errors: Colormap, Alloc

2 *        Returns:*	1pixel: CARD32
                  *	1red, green, blue: CARD16"*
  (DECLARE (VALUES PIXEL))
  (unless (typep cmap 'colormap)
    (bad-colormap cmap))
  
  (let ((pixel 0)
	(rval 0)   
	(gval 0)   
	(bval 0))
    1;; following code is from the sunbw2 c code.*
    1;;     * Gets intensity from RGB.  If intensity is >= half, pick white, else*
    1;;     * pick black.  This may well be more trouble than it's worth.*
    1;;    *pred = *pgreen = *pblue = *
    1;;      * 1 (((3*01L * *pred +*
    1;;           5*91L * *pgreen +*
    1;;           11L * *pblue) >> 8) >= (((1<<8)-1)*50)) ? ~0 : 0;*
    ;; See page 613 of Foley and Van Dam (1982 edition (first))
    (when (< 32767  (+ (* red .30) (* green .59) (* blue .11)))1        *; 1set to white*
      (setq rval 1 gval 1 bval 1 pixel 1))
    (WHEN send-reply
      (FORMAT-REPLY (STATE)
                    :WORD rval
                    :word gval
                    :word bval
                    ;; 2 unused
                    :long pixel)
      (SERVER-PUSH STATE))
    PIXEL))

(defreq Alloc-Color ((cmap COLORMAP)
		     (red CARD16)
		     (green CARD16)
		     (blue CARD16))
  (Alloc-Color cmap red green blue state))
  
(defun  Alloc-Named-Color (state cmap num-bytes name byte-offset)
1"*	1Looks up the named color with respect to the screen associated with the*
	1colormap, then does an AllocColor on cmap.  The name should use the ISO*
	1Latin-1 encoding, and upper/lower case does not matter.  The exact RGB*
	1values specify the "true" values for the color, and the visual values*
	1specify the values actually used in the colormap.*

	1Errors: Colormap, Name, Alloc
    =>*
	1pixel: CARD32*
	1exact-red, exact-green, exact-blue: CARD16*
	1visual-red, visual-green, visual-blue: CARD16*	1"*

	(unless (typep cmap 'colormap)
	  (bad-colormap cmap))
	(let ((pixel 0)
	      (exact-red 0)
	      (exact-green 0)  ;1 this is bogus. Need to get from colormap.........*
	      (exact-blue 0)
	      (visual-red 0)
	      (visual-green 0)
	      (visual-blue 0)
              (COLOR-NAME-STRING (BYTES-TO-STRING NAME NUM-BYTES BYTE-OFFSET)))
          (setf (values exact-red exact-green exact-blue visual-red visual-green visual-blue)
                (find-color cmap color-name-string))
          (IF (null exact-red)
             ;; Couldn't find the color name
             (bad-name)
             ;;ELSE
             (WHEN (> (+ exact-red exact-green exact-blue) (FLOOR (* (EXPT 2 16) 3) 2))
               (SETQ pixel 1))
             (format-reply (state)
                           :long pixel
                           :word exact-red
                           :word exact-green
                           :word exact-blue
                           :word visual-red
                           :word visual-green
                           :word visual-blue))))

(defreq Alloc-Named-Color ((cmap COLORMAP)
			   (nbytes CARD16)
			   (:byte nbytes))
  (Alloc-Named-Color state cmap nbytes bytes byte-offset))

;;;(MAKE-COLOR
(defun Alloc-Color-Cells (contiguous-p cmap colors planes state)
  1"*	1The number of colors must be positive, the number of planes*
	1non-negative (else a Value error).  If C colors and P planes are*
	1requested, then C pixels and P masks are returned.  *

	1Errors: Colormap, Value, Alloc
    =>*
	1pixels, masks: LISTofCARD32"*
  (declare (ignore state))
  
  ;; We will want to use this flag when we have a real colormap.
  (declare (ignore contiguous-p))
  (unless (typep cmap 'colormap)
    (bad-colormap cmap))
  (unless (plusp colors)
    (bad-value colors ))
  (when  (minusp planes)
    (bad-value planes))
  ;; Output header information and then the pixels and masks.
  (bad-alloc)
  #+comment
 (simple-reply (state)
   :BYTE REPLY-RESPONSE
   :BYTE 0			       ; Unused
   :WORD (STATE.SEQUENCE-ID STATE)
   :LONG (+ COLORS PLANES)
   :WORD COLORS
   :WORD PLANES)
 #+comment
  (let ((output-index 32))
    (LOOP FOR COLOR-COUNT FROM 0 BELOW COLORS
	  DO (PROGN
	       1;;*If contiguous is True,
	       ;1;* then if all masks are ORed together, a single contiguous
	       ;1;* set of bits will be formed for GrayScale or PseudoColor,
	       ;1;* and three contiguous sets of bits (one within each pixel
	       ;1;* subfield) for DirectColor.
	       (SETQ OUTPUT-INDEX (simple-reply (state output-index)
				    :LONG 0)))
	  finally (return output-index))
    (LOOP FOR COLOR-COUNT FROM 0 BELOW PLANES
	  DO (PROGN
	       ;1;*If contiguous is True,
	       ;1;* then if all masks are ORed together, a single
	       ;1;* contiguous set of bits will be formed for GrayScale or
	       ;1;* PseudoColor, and three contiguous sets of bits (one
	       ;1;* within each pixel subfield) for DirectColor.
	       (SETQ OUTPUT-INDEX (simple-reply (state output-index)
				    :LONG 0)))
	  finally (return output-index))
    (server-string-out state (response.bytes (state.response state)) output-index)
    (SERVER-PUSH STATE)))

(defreq Alloc-Color-Cells ((contiguous-p BOOL)
			   (cmap COLORMAP)
			   (colors CARD16)
			   (planes CARD16))
  (Alloc-Color-Cells contiguous-p cmap colors planes state))

(defun Alloc-Color-Planes (contiguous-p cmap colors red-mask green-mask blue-mask STATE)
1"       The number of colors must be positive, the reds, greens, and blues*
	1non-negative (else a Value error).  If C colors, R reds, G greens, and*
	1B blues are requested, then C pixels are returned, and the masks have*
	1R, G, and B bits set respectively.  If contiguous is True, then each*
	1mask will have a contiguous set of bits.  *

	1Errors; Colormap, Value, Alloc
    =>*
	1pixels: LISTofCARD32*
	1red-mask, green-mask, blue-mask: CARD32"*
  (declare (ignore state))

  ;; We will want to use this flag when we have a real colormap.
  (declare (ignore contiguous-p RED-MASK GREEN-MASK BLUE-MASK))
  (unless (typep cmap 'colormap)
    (bad-colormap cmap))
  (unless (plusp colors)
    (bad-value colors ))
  (bad-alloc)
  #+comment
  (simple-reply (state)
    :BYTE REPLY-RESPONSE
    :BYTE 0			       ; Unused
    :WORD (STATE.SEQUENCE-ID STATE)
    :LONG COLORS
    :WORD COLORS
    :WORD 0			       ; unused
    :LONG 0			       ; Red mask
    :LONG 0			       ; Green mask
    :LONG 0			       ; Blue mask
    :LONG 0			       ; Unused
    :LONG 0)			       ; Unused
  #+comment
  (let ((output-index 32))
    (LOOP FOR COLOR-INDEX FROM 0 BELOW COLORS
	  DO (PROGN
	       (SETQ OUTPUT-INDEX (SIMPLE-REPLY (STATE OUTPUT-INDEX)
				    :LONG 0)))
	  FINALLY (RETURN OUTPUT-INDEX))
    (server-string-out state (response.bytes (state.response state)) output-index)
    (SERVER-PUSH STATE)))
    
(Defreq Alloc-Color-Planes ((contiguous BOOL)
			    (cmap COLORMAP)
			    (colors CARD16)
			    (reds CARD16)
			    (greens CARD16)
			    (blues CARD16))
   (Alloc-Color-Planes contiguous cmap colors reds greens blues STATE))

(defun Free-Colors (cmap plane-mask pixels offset)
1"*	
	The plane-mask should not have any bits in common with any of the
	pixels.  The set of all pixels is produced by ORing together subsets of
	plane-mask with the pixels.  The request frees all of these pixels that
	were allocated by the client (using AllocColor, AllocNamedColor,
	AllocColorCells, and AllocColorPlanes).  Note that freeing an
	individual pixel obtained from AllocColorPlanes may not actually allow
	it to be reused until all of its 'related' pixels are also freed.

	All specified pixels that are allocated by the client in cmap are
	freed, even if one or more pixels produce an error.  A Value error is
	generated if a specified pixel is not a valid index into cmap, and an
	Access error is generated if a specified pixel is not allocated by the
	client (i.e., is unallocated or is only allocated by another client).
	If more than one pixel is in error, which one is reported is arbitrary."
	(IGNORE CMAP PLANE-MASK PIXELS OFFSET)
	
	;; this is really a big no-op. Can't free colors that are not allocated.
	)

(defreq Free-Colors ((cmap COLORMAP)
		     (plane-mask CARD32)
		     (:long))
  (Free-Colors cmap plane-mask longs long-offset))

  
(defun Store-Colors (cmap length bytes byte-offset words word-offset longs long-offset)
1"*	1Changes the colormap entries of the specified pixels.  The do-red,*
	1do-green, and do-blue fields indicate which components should actually*
	1be changed.  If the colormap is an installed map for its screen, the*
	1changes are visible immediately.*

	1where*
		1COLORITEM: [pixel: CARD32*
			1    do-red, do-green, do-blue: BOOL*
			1    red, green, blue: CARD16]*

	1Errors: Colormap, Access, Value"*
  (declare (ignore byte-offset word-offset bytes words))
  (unless (typep cmap 'colormap)
    (bad-colormap cmap))
  ;1; Check for errors*
  (loop with max = (length (colormap.entries cmap))
	for loffset from long-offset below (+ long-offset (floor length 4))
	for pixel = (aref longs loffset)
	(when (> pixel max)
	  (bad-value pixel)))
  ;; For the monochrome case we can't store any colors.  Let the client know.
  (bad-access)
  #+comment
  ;1; Store colors*
  (loop for boffset from byte-offset below (+ byte-offset length) by 12
	for woffset upfrom word-offset by 6
	for loffset upfrom long-offset by 3
	for pixel = (aref longs loffset)
	for entry = (aref (colormap.entries cmap) pixel)
	for todo = (aref bytes (+ boffset 10))
	do
	(when (logtest #b001 todo) (setf (colormap-entry.red entry) (aref words (+ woffset 2))))
	(when (logtest #b010 todo) (setf (colormap-entry.green entry) (aref words (+ woffset 3))))
	(when (logtest #b100 todo) (setf (colormap-entry.blue entry) (aref words (+ woffset 4))))
	))

(defreq Store-Colors ((cmap COLORMAP)
		      (:word (:long :word :word :word :byte :byte)))
  ;; Adjust the long and byte offsets to point to the first byte of the first color item.
  (incf long-offset 2)
  (incf byte-offset 8)
  ;; 1Hack alert*!! There is an error in the defreq macro in the handling of the color items.
  ;; What it should do is to set up the bytes array since we will need it to access parts
  ;; of a color item.  Since we don't need to look at the color items in the monochrome
  ;; case we will ignore this error for now.
  (Store-Colors cmap length 'bytes byte-offset words word-offset longs long-offset))
   
(Defun Store-Named-Color (flags cmap pixel name-length name)
"	Looks up the named color with respect to the screen associated with
	cmap, then does a StoreColors in cmap.  

	Errors: Colormap, Name, Access, Value"
  (ignore flags cmap pixel name-length name) ;; another big no-op
  ;; Need to build up a color items so we can call store-color when we have a real color system.
  (bad-access))

(defreq Store-Named-Color ((flags (MASKBITS All-RGB-Update-Masks CARD8))
			   (cmap COLORMAP)
			   (pixel CARD32)
			   (nbytes CARD16)
			   (:byte nbytes))
  (Store-Named-Color flags cmap pixel length bytes))

(defun query-colors (state cmap num-pixels pixels long-offset)
  "Returns the color values stored in cmap for the specified pixels.  The
2 *values returned for an UNALLOCATED Entry are undefined.  A Value error
2 *is generated if a pixel  is not a valid index into cmap.  If more than
2 *one pixel is in error, which one is reported is arbitrary.
2 =>
   *colors: LISTofRGB
2   *where
2     *RGB: [red, green, blue: CARD16]

2  *Errors: Colormap, Value"
  
  ;1; First check for errors*
  (loop FOR OFFSET FROM LONG-OFFSET
	FOR INDEX FROM 0 BELOW NUM-PIXELS
	FOR PIXEL = (AREF PIXELS OFFSET)
	do (when (> pixel  1)
	     ;;1 can't be more than two entries in our monochrome colormap...*
	     (bad-value pixel)
	     (return-from query-colors nil)))
  ;1; Send the reply*
  (let ((OUTPUT-BUFFER-LENGTH
	  (LOOP WITH OUTPUT-INDEX =
		(simple-reply (state)
		  :BYTE REPLY-RESPONSE
		  :BYTE 0	       ; Unused
		  :WORD (STATE.SEQUENCE-ID STATE)
		  :LONG (* 2 num-pixels)
		  :WORD num-pixels
		  :WORD 0	       ; Unused
		  :LONG 0	       ; Unused
		  :LONG 0	       ; Unused
		  :LONG 0	       ; Unused
		  :LONG 0	       ; Unused
		  :LONG 0)	       ; Unused
		FOR OFFSET FROM LONG-OFFSET
		FOR INDEX FROM 0 BELOW NUM-PIXELS
		FOR PIXEL = (AREF PIXELS OFFSET)
		do (let (rval gval bval)
		     (multiple-value-setq (rval gval bval)
		       (get-rgb-vals cmap pixel))
		     (server-trace-variable rval gval bval)
		     (setq output-index (SIMPLE-reply (state output-index)
					  :word rval
					  :word gval
					  :word bval
					  :word 0)))
		finally (return output-index))))
    (server-string-out state (response.bytes (state.response state)) output-buffer-length)
    (server-push state)))

(defreq Query-Colors ((cmap COLORMAP)
		      (:long))
  (query-colors STATE cmap length longs long-offset))

;1; NOTE: *color-table* contains 8-bit values, were the X11 protocol spec uses 16-bit values.*
(defsubst compress-color (red green blue)
  (dpb red (byte 8 16) (dpb green (byte 8 8) blue)))

(defsubst expand-color (color)
 (values (ldb (byte 8 16) color)
	 (ldb (byte 8 8) color)
	 (ldb (byte 8 0) color)))

;1; Utility function*
(defun read-rgb (pathname)
  "1Read in a standard X11 format RGB file and return a color alist*"
  (with-open-file (stream pathname)
    (loop for red = (read stream nil)
	  for green = (read stream nil)
	  for blue = (read stream nil)
	  for name = (string-trim '(#\space #\tab) (read-line stream nil))
	  while (and red green blue name)
	  collect name
	  collect (compress-color red green blue))))

;1;*(defparameter *color-table* (read-rgb "stroke:/u1/XV11R3/util/rgb/rgb.txt"))

;1; The following was generated using zmacs m-x grind expression on *(read-rgb "stroke:/u1/XV11R3/util/rgb/rgb.txt")
(defparameter *color-table* 
 '("aquamarine" 7396243 "medium aquamarine" 3329177 "MediumAquamarine" 3329177 "black" 0
 "blue" 255 "cadet blue" 6266783 "CadetBlue" 6266783 "cornflower blue" 4342383
 "CornflowerBlue" 4342383 "dark slate blue" 7021454 "DarkSlateBlue" 7021454 "light blue"
 12572888 "LightBlue" 12572888 "light steel blue" 9408444 "LightSteelBlue" 9408444
 "medium blue" 3289804 "MediumBlue" 3289804 "medium slate blue" 8323327 "MediumSlateBlue"
 8323327 "midnight blue" 3092303 "MidnightBlue" 3092303 "navy blue" 2302862 "NavyBlue"
 2302862 "navy" 2302862 "sky blue" 3316172 "SkyBlue" 3316172 "slate blue" 32767 "SlateBlue"
 32767 "steel blue" 2321294 "SteelBlue" 2321294 "coral" 16744192 "cyan" 65535 "firebrick"
 9315107 "brown" 10824234 "Sandy Brown" 16032864 "sandybrown" 16032864 "gold" 13401906
 "goldenrod" 14408560 "medium goldenrod" 15395501 "MediumGoldenrod" 15395501 "green" 65280
 "dark green" 3100463 "DarkGreen" 3100463 "dark olive green" 5197615 "DarkOliveGreen"
 5197615 "forest green" 2330147 "ForestGreen" 2330147 "lime green" 3329074 "LimeGreen"
 3329074 "medium forest green" 7048739 "MediumForestGreen" 7048739 "medium sea green"
 4353858 "MediumSeaGreen" 4353858 "medium spring green" 8388352 "MediumSpringGreen" 8388352
 "pale green" 9419919 "PaleGreen" 9419919 "sea green" 2330219 "SeaGreen" 2330219
 "spring green" 65407 "SpringGreen" 65407 "yellow green" 10079282 "YellowGreen" 10079282
 "dark slate grey" 3100495 "DarkSlateGrey" 3100495 "dark slate gray" 3100495
 "DarkSlateGray" 3100495 "dim grey" 5526612 "DimGrey" 5526612 "dim gray" 5526612 "DimGray"
 5526612 "light grey" 11053224 "LightGrey" 11053224 "light gray" 11053224 "LightGray"
 11053224 "gray" 12632256 "grey" 12632256 "khaki" 10461023 "magenta" 16711935 "maroon"
 9315179 "orange" 13382194 "orchid" 14381275 "dark orchid" 10040012 "DarkOrchid" 10040012
 "medium orchid" 9662683 "MediumOrchid" 9662683 "pink" 12357519 "plum" 15379946 "red"
 16711680 "indian red" 5189423 "IndianRed" 5189423 "medium violet red" 14381203
 "MediumVioletRed" 14381203 "orange red" 16711807 "OrangeRed" 16711807 "violet red"
 13382297 "VioletRed" 13382297 "salmon" 7291458 "sienna" 9333539 "tan" 14390128 "thistle"
 14204888 "turquoise" 11397866 "dark turquoise" 7377883 "DarkTurquoise" 7377883
 "medium turquoise" 7396315 "MediumTurquoise" 7396315 "violet" 5189455 "blue violet"
 10444703 "BlueViolet" 10444703 "wheat" 14211263 "white" 16777215 "yellow" 16776960
 "green yellow" 9689968 "GreenYellow" 9689968 "gray0" 0 "gray1" 197379 "gray2" 328965
 "gray3" 526344 "gray4" 657930 "gray5" 855309 "gray6" 986895 "gray7" 1184274 "gray8"
 1315860 "gray9" 1513239 "gray10" 1710618 "gray11" 1842204 "gray12" 2039583 "gray13"
 2171169 "gray14" 2368548 "gray15" 2500134 "gray16" 2697513 "gray17" 2829099 "gray18"
 3026478 "gray19" 3158064 "gray20" 3355443 "gray21" 3552822 "gray22" 3684408 "gray23"
 3881787 "gray24" 4013373 "gray25" 4210752 "gray26" 4342338 "gray27" 4539717 "gray28"
 4671303 "gray29" 4868682 "gray30" 5066061 "gray31" 5197647 "gray32" 5395026 "gray33"
 5526612 "gray34" 5723991 "gray35" 5855577 "gray36" 6052956 "gray37" 6184542 "gray38"
 6381921 "gray39" 6513507 "gray40" 6710886 "gray41" 6908265 "gray42" 7039851 "gray43"
 7237230 "gray44" 7368816 "gray45" 7566195 "gray46" 7697781 "gray47" 7895160 "gray48"
 8026746 "gray49" 8224125 "gray50" 8355711 "gray51" 8553090 "gray52" 8750469 "gray53"
 8882055 "gray54" 9079434 "gray55" 9211020 "gray56" 9408399 "gray57" 9539985 "gray58"
 9737364 "gray59" 9868950 "gray60" 10066329 "gray61" 10263708 "gray62" 10395294 "gray63"
 10592673 "gray64" 10724259 "gray65" 10921638 "gray66" 11053224 "gray67" 11250603 "gray68"
 11382189 "gray69" 11579568 "gray70" 11776947 "gray71" 11908533 "gray72" 12105912 "gray73"
 12237498 "gray74" 12434877 "gray75" 12566463 "gray76" 12763842 "gray77" 12895428 "gray78"
 13092807 "gray79" 13224393 "gray80" 13421772 "gray81" 13619151 "gray82" 13750737 "gray83"
 13948116 "gray84" 14079702 "gray85" 14277081 "gray86" 14408667 "gray87" 14606046 "gray88"
 14737632 "gray89" 14935011 "gray90" 15066597 "gray91" 15263976 "gray92" 15461355 "gray93"
 15592941 "gray94" 15790320 "gray95" 15921906 "gray96" 16119285 "gray97" 16250871 "gray98"
 16448250 "gray99" 16579836 "gray100" 16777215))

(defun find-Color (Cmap cname)
 "2GENERAL FUNCTION USED BY LOOKUP-COLOR TO FIND
  the string name of a color with repsect to the 
   screen associated with the color-map. Return both the
   exact color values and the closest values provided by the
   hardware with repect to the visual type* 2of the colormap*
	1cmap: COLORMAP*
	1cname: STRING8
    =>*
	1exact-red, exact-green, exact-blue: CARD16*
	1visual-red, visual-green, visual-blue: CARD16"*
  (declare (IGNORE CMAP))
  (loop for color on *color-table* by #'cddr
	for name = (car color)
	for pixnum upfrom 0
	with cname-len = (length cname)
	when (and (= (length name) cname-len) ;1; do initial check in-line*
		  (string-equal cname name))
	do (multiple-value-bind (red green blue)
	       (expand-color (second color))
	     ;1; Convert from card8 values to card16*
	     (setq red   (dpb red   (byte 8 8) (if (zerop red) 0 #xff))
		   green (dpb green (byte 8 8) (if (zerop green) 0 #xff))
		   blue  (dpb blue  (byte 8 8) (if (zerop blue) 0 #xff)))
	     (return (values pixnum red green blue red green blue)))))

(defun  lookup-Color 1(*state cmap nbytes bytes byte-offset)
 "2Looks up the string name of a color with repsect to the 
   screen associated with the color-map. Return both the
   exact color values and the closest values provided by the
   hardware with repect to the visual type* 2of the colormap
1         state: state of the server connection**
	1cmap: COLORMAP
         nbytes: length of name*
	1bytes: STRING8 of characters of the name*
        1byte-offset: offset within bytes of where the name starts
    =>*
	1exact-red, exact-green, exact-blue: CARD16*
	1visual-red, visual-green, visual-blue: CARD16"*
  (let (PIXEL  x-red  x-green   x-blue   v-red   v-green   v-blue )
    ;; To avoid going insane, be sure to close you eyes before reading the next form.
    ;; You may want to do a macro expand (control-shift-m on the initial parenthesis)
    ;; to see what this means.
    (multiple-value-setq (PIXEL x-red x-green  x-blue  v-red  v-green  v-blue)
      (find-color cmap (BYTES-TO-STRING bytes nbytes byte-offset)))
    (IF (null x-red)
        ;; Couldn't find the color name
        (bad-name)
        ;;ELSE
        (format-reply (state)
          :word  x-red
          :word  x-green
          :word  x-blue
          :word  v-red
          :word  v-green
          :word  v-blue)
        (SERVER-PUSH STATE))))

(defreq Lookup-Color ((cmap COLORMAP)
		      (nbytes CARD16)
		      (:byte nbytes))
  (lookup-color state cmap nbytes bytes byte-offset))


(defun EXPLORER-GET-PIXEL (red green blue)
  ;; copied from alloc-color
  (if (< 32767  (+ (* red .30) (* green .59) (* blue .11)))1        *
      1
    0))


#|
Debug code:
;;; 1MAGIC ALERT!!!  THIS IS A WAY TO GET INTO THE *RESOURCES* ENVIRONMENT.....
(eh (car si:all-processes))
(setq resources (x11:global-state.resources (eh-arg 1)))
resume
(gethash (colormap.id the-map ) user:resources)*

(MULTIPLE-VALUE-SETQ (PIXEL  x-red  x-green   x-blue   v-red   v-green   v-blue )
  (find-COLOR 'AMAP "forest green"))
|#