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

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

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

(define (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))
	      (apply create-color (cadr Xres))
	      (apply create-color (caddr Xres)))
	Xres)))

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


; added by N. Freudemann
; swaped from utility.scm to this file.

(define (parse-color colormap string)
  (%parse-color (display-Xdisplay (colormap-display colormap))
		(colormap-Xcolormap colormap)
		string))


(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 make-pixel
		   (vector->list (cdr res))))
	res)))

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

;; The set-color-cell 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 (set-color-cell colormap pixel color . flags)
  (%set-color-cell (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 %set-color-cells (Xdisplay Xcolormap Xpixel Xcolor 
						     flags)
  "scx_Set_Color_Cell")