107 lines
3.6 KiB
Scheme
107 lines
3.6 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")
|
|
|
|
;; The create-colormap function creates a colormap of the specified
|
|
;; visual type for the screen on which the specified window resides.
|
|
;; alloc can be 'none or 'all. See XCreateColormap.
|
|
|
|
(define (create-colormap window visual alloc)
|
|
(let ((Xcolormap (%create-colormap (display-Xdisplay (window-display window))
|
|
(window-Xwindow window)
|
|
(visual-Xvisual visual)
|
|
(if (eq? alloc 'none)
|
|
#f
|
|
#t) ; 'all
|
|
)))
|
|
(make-colormap Xcolormap (window-display window) #t)))
|
|
|
|
(import-lambda-definition %create-colormap (Xdisplay Xwindow Xvisual alloc)
|
|
"scx_Create_Colormap")
|
|
|
|
;; The alloc-color-cells function allocates read/write color cells.
|
|
;; The number of colors must be positive and the number of planes
|
|
;; nonnegative, or a BadValue error results. See XAllocColorCells.
|
|
;; The return value is a pair who's car is the list of the planes
|
|
;; (integers), and who's cdr is a list of the pixels.
|
|
|
|
(define (alloc-color-cells colormap contigous nplanes npixels)
|
|
(let ((res (%alloc-color-cells (display-Xdisplay (colormap-display colormap))
|
|
(colormap-Xcolormap colormap)
|
|
contigous
|
|
nplanes npixels)))
|
|
(if res
|
|
(cons (vector->list (car res))
|
|
(map make-pixel
|
|
(vector->list (cdr res))))
|
|
res)))
|
|
|
|
(import-lambda-definition %alloc-color-cells (Xdisplay Xcolormap contig
|
|
nplanes npixels)
|
|
"scx_Alloc_Color_Cells")
|
|
|
|
;; The set-color-cell function uses XStoreColor(s) to set the content
|
|
;; of the color cell specified by pixel (a pixel is an index to a
|
|
;; colormap) to color. An optional parameter is a list of the symbols
|
|
;; 'do-red 'do-gree and 'do-blue, that specify which components of the
|
|
;; color should be used. It defaults to '(do-red do-green
|
|
;; do-blue). See XStoreColors.
|
|
|
|
(define (set-color-cell colormap pixel color . flags)
|
|
(%set-color-cell (display-Xdisplay (colormap-display colormap))
|
|
(colormap-Xcolormap colormap)
|
|
(pixel-Xpixel pixel) (color-Xcolor color)
|
|
(if (null? flags)
|
|
'(do-red do-green do-blue)
|
|
(car flags))))
|
|
|
|
(import-lambda-definition %set-color-cells (Xdisplay Xcolormap Xpixel Xcolor
|
|
flags)
|
|
"scx_Set_Color_Cell")
|