scx/scheme/xlib/colormap.scm

;; Author: David Frese

;; alloc-color returns the pixel closest to the specified color supported by the
;; hardware. See XAllocColor. The color parameter is mutated!

(define (alloc-color! colormap color)
  (let ((Xpixel (%alloc-color (colormap-Xcolormap colormap)
			      (color-Xcolor color)
			      (display-Xdisplay (colormap-display colormap)))))
    (if Xpixel
	(make-pixel Xpixel colormap #t)
	Xpixel)))

(import-lambda-definition %alloc-color (Xcolormap Xcolor Xdisplay)
  "scx_Alloc_Color")

;; query/alloc-named-color looks up the named color with respect to
;; the screen that is associated with the specified colormap. It
;; returns the allocated pixel and both the exact database definition
;; and the closest color supported by the screen (as a list).  See
;; XAllocNamedColor.

(define (query/alloc-named-color colormap color-name)
  (let ((Xres (%alloc-named-color (colormap-Xcolormap colormap)
				  (if (symbol? color-name)
				      (symbol->string color-name)
				      color-name)
				  (display-Xdisplay 
				   (colormap-display colormap)))))
    (if Xres
	(list (make-pixel (car Xres) colormap #t)
	      (apply create-color (cadr Xres))
	      (apply create-color (caddr Xres)))
	Xres)))

(import-lambda-definition %alloc-named-color (Xcolormap name Xdisplay)
  "scx_Alloc_Named_Color")

;; alloc-named-color only allocates a named color and returns the
;; allocated pixel (as one might suppose). If the color does not
;; exists it returns #f.

(define (alloc-named-color colormap color-name)
  (let ((c (parse-color colormap color-name)))
    (if c
	(alloc-color! colormap c)
	#f)))

;; parse-color looks up the string name of a color and returns the
;; exact color value. See XParseColor. See lookup-color.

(define (parse-color colormap color-name)
  (let ((res (%parse-color (display-Xdisplay (colormap-display colormap))
			   (colormap-Xcolormap colormap)
			   (if (symbol? color-name)
			       (symbol->string color-name)
			       color-name))))
    (if res
	(create-color (vector-ref res 0)
		      (vector-ref res 1)
		      (vector-ref res 2))
	#f)))

(import-lambda-definition %parse-color (Xdisplay Xcolormap string)
  "scx_Parse_Color")

;; The create-colormap function creates a colormap of the specified
;; visual type for the screen on which the specified window resides.
;; alloc can be 'none or 'all. See XCreateColormap.

(define (create-colormap window visual alloc)
  (let ((Xcolormap (%create-colormap (display-Xdisplay (window-display window))
				     (window-Xwindow window)
				     (visual-Xvisual visual)
				     (if (eq? alloc 'none)
					 #f
					 #t) ; 'all
				     )))
    (make-colormap Xcolormap (window-display window) #t)))

(import-lambda-definition %create-colormap (Xdisplay Xwindow Xvisual alloc)
  "scx_Create_Colormap")

;; The alloc-color-cells function allocates read/write color cells.
;; The number of colors must be positive and the number of planes
;; nonnegative, or a BadValue error results. See XAllocColorCells.
;; The return value is a pair who's car is the list of the planes
;; (integers), and who's cdr is a list of the pixels.

(define (alloc-color-cells colormap contigous nplanes npixels)
  (let ((res (%alloc-color-cells (display-Xdisplay (colormap-display colormap))
				 (colormap-Xcolormap colormap)
				 contigous
				 nplanes npixels)))
    (if res
	(cons (vector->list (car res))
	      (map (lambda (Xpixel)
		     (make-pixel Xpixel colormap #t))
		   (vector->list (cdr res))))
	res)))

(import-lambda-definition %alloc-color-cells (Xdisplay Xcolormap contig
						       nplanes npixels)
  "scx_Alloc_Color_Cells")

;; The store-color function uses XStoreColor(s) to set the content
;; of the color cell specified by pixel (a pixel is an index to a
;; colormap) to color. An optional parameter is a list of the symbols
;; 'do-red 'do-gree and 'do-blue, that specify which components of the
;; color should be used. It defaults to '(do-red do-green
;; do-blue). See XStoreColors.

(define (store-color colormap pixel color . flags)
  (%store-color (display-Xdisplay (colormap-display colormap))
		(colormap-Xcolormap colormap)
		(pixel-Xpixel pixel) (color-Xcolor color)
		(if (null? flags)
		    '(do-red do-green do-blue)
		    (car flags))))

(import-lambda-definition %store-color (Xdisplay Xcolormap Xpixel Xcolor 
						 flags)
  "scx_Store_Color")

;; store-colors does the same as store-color, but for multiple
;; colorcells. The paramter cells must be a list of lists consisting
;; of 2 or 3 elements: a pixel, a color and an optional flags list
;; (see above).

(define (store-colors colormap cells)
  (let ((cells (list->vector
		(map (lambda (p-c-f)
		       (list->vector
			(list (pixel-Xpixel (car p-c-f))
			      (color-Xcolor (cadr p-c-f))
			      (if (null? (cddr p-c-f))
				  '(do-red do-green do-blue)
				  (caddr p-c-f)))))
		     cells))))
    (%store-colors (display-Xdisplay (colormap-display colormap))
		   (colormap-Xcolormap colormap)
		   cells)))

(import-lambda-definition %store-colors (Xdisplay Xcolormap cells)
  "scx_Store_Colors")

;; copy-colormap-and-free function creates a colormap of the same
;; visual type and for the same screen as the specified colormap and
;; returns the new colormap. It also moves all of the client's
;; existing allocation from the specified colormap to the new colormap
;; with their color values intact and their read-only or writable
;; characteristics intact and frees those entries in the specified
;; colormap. See XCopyColormapAndFree

(define (copy-colormap-and-free colormap)
  (make-colormap (%copy-colormap-and-free 
		  (display-Xdisplay (colormap-display colormap))
		  (colormap-Xcolormap colormap))
		 (colormap-display colormap)
		 #t))

(import-lambda-definition %copy-colormap-and-free (Xdisplay Xcolormap)
  "scx_Copy_Colormap_And_Free")