diff --git a/c/xlib/colormap.c b/c/xlib/colormap.c index c0d1d6a..b40216c 100644 --- a/c/xlib/colormap.c +++ b/c/xlib/colormap.c @@ -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); } diff --git a/scheme/xlib/color.scm b/scheme/xlib/color.scm index ca0cef6..502e30d 100644 --- a/scheme/xlib/color.scm +++ b/scheme/xlib/color.scm @@ -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)) diff --git a/scheme/xlib/colormap.scm b/scheme/xlib/colormap.scm index b50dad6..c646da5 100644 --- a/scheme/xlib/colormap.scm +++ b/scheme/xlib/colormap.scm @@ -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") +