;; Author: David Frese

;; make-color creates a color with the given r,g,b values, which should be 
;; values between 0.0 to 1.0 inclusive.

(define (my-floor v)
  (if (exact? v)
      (floor v)
      (my-floor (inexact->exact v))))

(define (make-color r g b)
  (create-color (my-floor (* r 65535))
		(my-floor (* g 65535))
		(my-floor (* b 65535))))

;; color-rgb-values returns a list of the rgb-values (see make-color).

(define (color-rgb-values color)
  (map (lambda (x)
	 (/ x 65535)) ;; exact<->inexact?
       (extract-rgb-values color)))

;; query-color returns the color of the given pixel in the given colormap. 
;; See XQueryColor.

(define (query-color colormap pixel)
  (apply create-color
	 (%query-color (colormap-Xcolormap colormap)
		       (pixel-Xpixel pixel)
		       (display-Xdisplay (colormap-display colormap)))))

(import-lambda-definition %query-color (Xcolormap Xpixel Xdisplay)
  "Query_Color")

;; query-colors does the same as query-color but on vectors of pixels and 
;; colors. See XQueryColors.

(define (query-colors colormap pixels)
  (let ((res (%query-colors (colormap-Xcolormap colormap)
			    (vector-map! pixel-Xpixel pixels)
			    (display-Xdisplay (colormap-display colormap)))))
    (vector-map! (lambda (r-g-b)
		   (apply create-color r-g-b))
		 res)))

(import-lambda-definition %query-colors (Xcolormap Xpixels Xdisplay)
  "Query_Colors")

;; lookup-color takes the name of a color (a string or symbol) looks it up in
;; the colormap and returns a pair of colors: the exact color and the closest
;; color provided by the screen associated to the colormap. If the color-name
;; can't be found an error is raised. See XLookupColor.

(define (lookup-color colormap color-name)
  (let ((r (%lookup-color (colormap-Xcolormap colormap)
			  (display-Xdisplay (colormap-display colormap))
			  (if (symbol? color-name)
			      (symbol->string color-name)
			      color-name))))
    (if r
	(cons (apply create-color (car r))
	      (apply create-color (cdr r)))
	(error "no such color:" color-name))))

(import-lambda-definition %lookup-color (Xcolormap Xdisplay name)
  "Lookup_Color")