66 lines
2.0 KiB
Scheme
66 lines
2.0 KiB
Scheme
;; 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))))
|
|
(vector-map! (lambda (r-g-b)
|
|
(apply make-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")
|