165 lines
5.7 KiB
Scheme
165 lines
5.7 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 colormap #t)
|
|
Xpixel)))
|
|
|
|
(import-lambda-definition %alloc-color (Xcolormap Xcolor Xdisplay)
|
|
"scx_Alloc_Color")
|
|
|
|
;; query/alloc-named-color looks up the named color with respect to
|
|
;; the screen that is associated with the specified colormap. It
|
|
;; returns the allocated pixel and both the exact database definition
|
|
;; and the closest color supported by the screen (as a list). See
|
|
;; XAllocNamedColor.
|
|
|
|
(define (query/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) colormap #t)
|
|
(apply create-color (cadr Xres))
|
|
(apply create-color (caddr Xres)))
|
|
Xres)))
|
|
|
|
(import-lambda-definition %alloc-named-color (Xcolormap name Xdisplay)
|
|
"scx_Alloc_Named_Color")
|
|
|
|
;; alloc-named-color only allocates a named color and returns the
|
|
;; allocated pixel (as one might suppose). If the color does not
|
|
;; exists it returns #f.
|
|
|
|
(define (alloc-named-color colormap color-name)
|
|
(let ((c (parse-color colormap color-name)))
|
|
(if c
|
|
(alloc-color! colormap c)
|
|
#f)))
|
|
|
|
;; parse-color looks up the string name of a color and returns the
|
|
;; exact color value. See XParseColor. See lookup-color.
|
|
|
|
(define (parse-color colormap color-name)
|
|
(let ((res (%parse-color (display-Xdisplay (colormap-display colormap))
|
|
(colormap-Xcolormap colormap)
|
|
(if (symbol? color-name)
|
|
(symbol->string color-name)
|
|
color-name))))
|
|
(if res
|
|
(create-color (vector-ref res 0)
|
|
(vector-ref res 1)
|
|
(vector-ref res 2))
|
|
#f)))
|
|
|
|
(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 (lambda (Xpixel)
|
|
(make-pixel Xpixel colormap #t))
|
|
(vector->list (cdr res))))
|
|
res)))
|
|
|
|
(import-lambda-definition %alloc-color-cells (Xdisplay Xcolormap contig
|
|
nplanes npixels)
|
|
"scx_Alloc_Color_Cells")
|
|
|
|
;; The store-color 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 (store-color colormap pixel color . flags)
|
|
(%store-color (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 %store-color (Xdisplay Xcolormap Xpixel Xcolor
|
|
flags)
|
|
"scx_Store_Color")
|
|
|
|
;; store-colors does the same as store-color, but for multiple
|
|
;; colorcells. The paramter cells must be a list of lists consisting
|
|
;; of 2 or 3 elements: a pixel, a color and an optional flags list
|
|
;; (see above).
|
|
|
|
(define (store-colors colormap cells)
|
|
(let ((cells (list->vector
|
|
(map (lambda (p-c-f)
|
|
(list->vector
|
|
(list (pixel-Xpixel (car p-c-f))
|
|
(color-Xcolor (cadr p-c-f))
|
|
(if (null? (cddr p-c-f))
|
|
'(do-red do-green do-blue)
|
|
(caddr p-c-f)))))
|
|
cells))))
|
|
(%store-colors (display-Xdisplay (colormap-display colormap))
|
|
(colormap-Xcolormap colormap)
|
|
cells)))
|
|
|
|
(import-lambda-definition %store-colors (Xdisplay Xcolormap cells)
|
|
"scx_Store_Colors")
|
|
|
|
;; copy-colormap-and-free function creates a colormap of the same
|
|
;; visual type and for the same screen as the specified colormap and
|
|
;; returns the new colormap. It also moves all of the client's
|
|
;; existing allocation from the specified colormap to the new colormap
|
|
;; with their color values intact and their read-only or writable
|
|
;; characteristics intact and frees those entries in the specified
|
|
;; colormap. See XCopyColormapAndFree
|
|
|
|
(define (copy-colormap-and-free colormap)
|
|
(make-colormap (%copy-colormap-and-free
|
|
(display-Xdisplay (colormap-display colormap))
|
|
(colormap-Xcolormap colormap))
|
|
(colormap-display colormap)
|
|
#t))
|
|
|
|
(import-lambda-definition %copy-colormap-and-free (Xdisplay Xcolormap)
|
|
"scx_Copy_Colormap_And_Free")
|
|
|