26 lines
688 B
Scheme
26 lines
688 B
Scheme
;; Author: David Frese
|
|
|
|
(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")
|
|
|
|
;; ...
|
|
|
|
(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)))
|