32 lines
1.0 KiB
Scheme
32 lines
1.0 KiB
Scheme
;; Author: David Frese
|
|
|
|
;; alloc-color returns the pixel closest to the specified color supported by the
|
|
;; hardware. See XAllocColor.
|
|
|
|
(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)
|
|
"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))))
|
|
(if Xres
|
|
(list (make-pixel (car Xres))
|
|
(apply make-color (cadr Xres))
|
|
(apply make-color (caddr Xres)))
|
|
Xres)))
|