53 lines
1.3 KiB
Scheme
53 lines
1.3 KiB
Scheme
;; Author: David Frese
|
|
|
|
;; r,g,b should be values between 0.0 to 1.0 inclusive.
|
|
|
|
(define (make-color r g b)
|
|
(create-color (floor (* r 65535))
|
|
(floor (* g 65535))
|
|
(floor (* b 65535))))
|
|
|
|
(define (color-rgb-values color)
|
|
(map (lambda (x)
|
|
(/ x 65535)) ;; exact<->inexact?
|
|
(extract-rgb-values color)))
|
|
|
|
;; ...
|
|
|
|
(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")
|
|
|
|
;; ...
|
|
|
|
(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")
|
|
|
|
;; ...
|
|
|
|
(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)
|
|
"Lookup_Color")
|