49 lines
1.2 KiB
Scheme
49 lines
1.2 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-definiton %query-color (Xcolormap Xpixel Xdisplay)
|
|
"Query_Color")
|
|
|
|
;; ...
|
|
|
|
(define (query-colors colormap pixels)
|
|
(list->vector
|
|
(map (lambda (pixel)
|
|
(query-color colormap pixel))
|
|
(vector->list pixels))))
|
|
|
|
;; ...
|
|
|
|
(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-definiton %lookup-color (Xcolormap Xdisplay)
|
|
"Lookup_Color")
|