scsh-conservatory
/
scx
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

- removed direct calls to scx_Create_Color 

- renamed save-color-cell to store-color
- added store-colors, copy-colormap-and-free,
respect. scx_Store_Colors, scx_Copy_Colormap
- renamed alloc-named-color to query/alloc-named-color
- added new alloc-named-color that can be used like alloc-color!
- changed my-floor definition (color.scm)
- added parse-color
- updated calls to make-pixel
This commit is contained in:
frese 2001-10-09 15:31:33 +00:00
parent ac8219c0a8
commit 648252ba0d
3 changed files with 121 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
c/xlib/colormap.c
View File

@ -50,8 +50,16 @@ s48_value scx_Parse_Color (s48_value Xdpy, s48_value cmap, s48_value spec) {
if (XParseColor (SCX_EXTRACT_DISPLAY(Xdpy),
SCX_EXTRACT_COLORMAP(cmap),
s48_extract_string(spec),
&ret))
return scx_Create_Color (ret.red, ret.green, ret.blue);
&ret)) {
s48_value res = s48_make_vector(3, S48_FALSE);
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(res);
S48_VECTOR_SET(res, 0, s48_enter_integer(ret.red));
S48_VECTOR_SET(res, 1, s48_enter_integer(ret.green));
S48_VECTOR_SET(res, 2, s48_enter_integer(ret.blue));
S48_GC_UNPROTECT();
return res;
}
return S48_FALSE;
}
@ -93,9 +101,9 @@ s48_value scx_Alloc_Color_Cells (s48_value Xdisplay, s48_value Xcolormap,
return S48_FALSE;
}
s48_value scx_Set_Color_Cell(s48_value Xdisplay, s48_value Xcolormap,
s48_value Xpixel, s48_value Xcolor,
s48_value flags) {
s48_value scx_Store_Color(s48_value Xdisplay, s48_value Xcolormap,
s48_value Xpixel, s48_value Xcolor,
s48_value flags) {
XColor t;
XColor* c;
@ -112,6 +120,35 @@ s48_value scx_Set_Color_Cell(s48_value Xdisplay, s48_value Xcolormap,
return S48_UNSPECIFIC;
}
s48_value scx_Store_Colors(s48_value Xdisplay, s48_value Xcolormap,
s48_value cells) {
int n = S48_VECTOR_LENGTH(cells);
XColor colors[n];
XColor* c;
int i;
for (i = 0; i < n; i++) {
s48_value def = S48_VECTOR_REF(cells, i);
colors[i].pixel = SCX_EXTRACT_PIXEL(S48_VECTOR_REF(def, 0));
c = SCX_EXTRACT_COLOR(S48_VECTOR_REF(def, 1));
colors[i].red = c->red;
colors[i].green = c->green;
colors[i].blue = c->blue;
colors[i].flags = Symbols_To_Bits(S48_VECTOR_REF(def, 2), Color_Flags_Syms);
}
XStoreColors(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_COLORMAP(Xcolormap),
colors, n);
return S48_UNSPECIFIC;
}
s48_value scx_Copy_Colormap_And_Free(s48_value Xdisplay, s48_value Xcolormap) {
Colormap cm = XCopyColormapAndFree(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_COLORMAP(Xcolormap));
return SCX_ENTER_COLORMAP(cm);
}
void scx_init_colormap(void) {
S48_EXPORT_FUNCTION(scx_Free_Colormap);
S48_EXPORT_FUNCTION(scx_Alloc_Color);
@ -119,5 +156,7 @@ void scx_init_colormap(void) {
S48_EXPORT_FUNCTION(scx_Parse_Color);
S48_EXPORT_FUNCTION(scx_Create_Colormap);
S48_EXPORT_FUNCTION(scx_Alloc_Color_Cells);
S48_EXPORT_FUNCTION(scx_Set_Color_Cell);
S48_EXPORT_FUNCTION(scx_Store_Color);
S48_EXPORT_FUNCTION(scx_Store_Colors);
S48_EXPORT_FUNCTION(scx_Copy_Colormap_And_Free);
}

2
scheme/xlib/color.scm
View File

@ -6,7 +6,7 @@
(define (my-floor v)
(if (exact? v)
(floor v)
(my-floor (inexact->exact v))))
(floor (inexact->exact v))))
(define (make-color r g b)
(create-color (my-floor (* r 65535))

92
scheme/xlib/colormap.scm
View File

@ -8,18 +8,19 @@
(color-Xcolor color)
(display-Xdisplay (colormap-display colormap)))))
(if Xpixel
(make-pixel Xpixel)
(make-pixel Xpixel colormap #t)
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.
;; 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 (alloc-named-color colormap color-name)
(define (query/alloc-named-color colormap color-name)
(let ((Xres (%alloc-named-color (colormap-Xcolormap colormap)
(if (symbol? color-name)
(symbol->string color-name)
@ -27,7 +28,7 @@
(display-Xdisplay
(colormap-display colormap)))))
(if Xres
(list (make-pixel (car Xres))
(list (make-pixel (car Xres) colormap #t)
(apply create-color (cadr Xres))
(apply create-color (caddr Xres)))
Xres)))
@ -35,15 +36,30 @@
(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.
; added by N. Freudemann
; swaped from utility.scm to this file.
(define (alloc-named-color colormap color-name)
(let ((c (parse-color colormap color-name)))
(if c
(alloc-color! colormap c)
#f)))
(define (parse-color colormap string)
(%parse-color (display-Xdisplay (colormap-display colormap))
(colormap-Xcolormap colormap)
string))
;; 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")
@ -78,7 +94,8 @@
nplanes npixels)))
(if res
(cons (vector->list (car res))
(map make-pixel
(map (lambda (Xpixel)
(make-pixel Xpixel colormap #t))
(vector->list (cdr res))))
res)))
@ -86,14 +103,14 @@
nplanes npixels)
"scx_Alloc_Color_Cells")
;; The set-color-cell function uses XStoreColor(s) to set the content
;; 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 (set-color-cell colormap pixel color . flags)
(define (store-color colormap pixel color . flags)
(%set-color-cell (display-Xdisplay (colormap-display colormap))
(colormap-Xcolormap colormap)
(pixel-Xpixel pixel) (color-Xcolor color)
@ -103,4 +120,45 @@
(import-lambda-definition %set-color-cells (Xdisplay Xcolormap Xpixel Xcolor
flags)
"scx_Set_Color_Cell")
"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")