49 lines
1.5 KiB
Scheme
49 lines
1.5 KiB
Scheme
;; Author: David Frese
|
|
|
|
;; alloc-color returns the pixel closest to the specified color supported by the
|
|
;; hardware. See XAllocColor. The color parameter is mutated!
|
|
|
|
(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)
|
|
"scx_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)
|
|
(display-Xdisplay
|
|
(colormap-display colormap)))))
|
|
(if Xres
|
|
(list (make-pixel (car Xres))
|
|
(apply create-color (cadr Xres))
|
|
(apply create-color (caddr Xres)))
|
|
Xres)))
|
|
|
|
(import-lambda-definition %alloc-named-color (Xcolormap name Xdisplay)
|
|
"scx_Alloc_Named_Color")
|
|
|
|
|
|
; added by N. Freudemann
|
|
; swaped from utility.scm to this file.
|
|
|
|
(define (parse-color colormap string)
|
|
(%parse-color (display-Xdisplay (colormap-display colormap))
|
|
(colormap-Xcolormap colormap)
|
|
string))
|
|
|
|
|
|
(import-lambda-definition %parse-color (Xdisplay Xcolormap string)
|
|
"scx_Parse_Color") |