130 lines
3.7 KiB
C
130 lines
3.7 KiB
C
#include "xlib.h"
|
|
|
|
Generic_Predicate (Color)
|
|
|
|
static Color_Equal (x, y) s48_value x, y; {
|
|
register XColor *p = &COLOR(x)->c, *q = &COLOR(y)->c;
|
|
return p->red == q->red && p->green == q->green && p->blue == q->blue;
|
|
}
|
|
|
|
Generic_Print (Color, "#[color %lu]", POINTER(x))
|
|
|
|
s48_value Make_Color (r, g, b) unsigned int r, g, b; {
|
|
s48_value c;
|
|
|
|
c = Find_Object (T_Color, (GENERIC)0, Match_X_Obj, r, g, b);
|
|
if (S48_NULL_P (c)) {
|
|
c = Alloc_Object (sizeof (struct S_Color), T_Color, 0);
|
|
COLOR(c)->tag = S48_NULL;
|
|
COLOR(c)->c.red = r;
|
|
COLOR(c)->c.green = g;
|
|
COLOR(c)->c.blue = b;
|
|
Register_Object (c, (GENERIC)0, (PFO)0, 0);
|
|
}
|
|
return c;
|
|
}
|
|
|
|
XColor *Get_Color (c) s48_value c; {
|
|
Check_Type (c, T_Color);
|
|
return &COLOR(c)->c;
|
|
}
|
|
|
|
static unsigned short Get_RGB_Value (x) s48_value x; {
|
|
double d;
|
|
|
|
d = s48_extract_double (x);
|
|
if (d < 0.0 || d > 1.0)
|
|
Primitive_Error ("bad RGB value: ~s", x);
|
|
return (unsigned short)(d * 65535);
|
|
}
|
|
|
|
static s48_value P_Make_Color (r, g, b) s48_value r, g, b; {
|
|
return Make_Color (Get_RGB_Value (r), Get_RGB_Value (g), Get_RGB_Value (b));
|
|
}
|
|
|
|
static s48_value P_Color_Rgb_Values (c) s48_value c; {
|
|
s48_value ret, t, x;
|
|
S48_DECLARE_GC_PROTECT(3);
|
|
|
|
Check_Type (c, T_Color);
|
|
ret = t = S48_NULL;
|
|
S48_GC_PROTECT_3 (c, ret, t);
|
|
t = ret = P_Make_List (s48_enter_integer (3), S48_NULL);
|
|
S48_GC_UNPROTECT;
|
|
x = Make_Reduced_Flonum ((double)COLOR(c)->c.red / 65535.0);
|
|
S48_CAR (t) = x; t = S48_CDR (t);
|
|
x = Make_Reduced_Flonum ((double)COLOR(c)->c.green / 65535.0);
|
|
S48_CAR (t) = x; t = S48_CDR (t);
|
|
x = Make_Reduced_Flonum ((double)COLOR(c)->c.blue / 65535.0);
|
|
S48_CAR (t) = x;
|
|
return ret;
|
|
}
|
|
|
|
static s48_value P_Query_Color (cmap, p) s48_value cmap, p; {
|
|
XColor c;
|
|
Colormap cm = Get_Colormap (cmap);
|
|
|
|
c.pixel = Get_Pixel (p);
|
|
Disable_Interrupts;
|
|
XQueryColor (COLORMAP(cmap)->dpy, cm, &c);
|
|
Enable_Interrupts;
|
|
return Make_Color (c.red, c.green, c.blue);
|
|
}
|
|
|
|
static s48_value P_Query_Colors (cmap, v) s48_value cmap, v; {
|
|
Colormap cm = Get_Colormap (cmap);
|
|
register i, n;
|
|
s48_value ret;
|
|
register XColor *p;
|
|
S48_DECLARE_GC_PROTECT(1);
|
|
Alloca_Begin;
|
|
|
|
Check_Type (v, T_Vector);
|
|
n = S48_VECTOR_LENGTH(v);
|
|
Alloca (p, XColor*, n * sizeof (XColor));
|
|
for (i = 0; i < n; i++)
|
|
p[i].pixel = Get_Pixel (VECTOR(v)->data[i]);
|
|
Disable_Interrupts;
|
|
XQueryColors (COLORMAP(cmap)->dpy, cm, p, n);
|
|
Enable_Interrupts;
|
|
ret = s48_make_vector (n, S48_NULL);
|
|
S48_GC_PROTECT_1 (ret);
|
|
for (i = 0; i < n; i++, p++) {
|
|
s48_value x;
|
|
|
|
x = Make_Color (p->red, p->green, p->blue);
|
|
S48_VECTOR_SET(ret, i, x;)
|
|
}
|
|
S48_GC_UNPROTECT;
|
|
Alloca_End;
|
|
return ret;
|
|
}
|
|
|
|
static s48_value P_Lookup_Color (cmap, name) s48_value cmap, name; {
|
|
XColor visual, exact;
|
|
Colormap cm = Get_Colormap (cmap);
|
|
s48_value ret, x;
|
|
S48_DECLARE_GC_PROTECT(1);
|
|
|
|
if (!XLookupColor (COLORMAP(cmap)->dpy, cm, Get_Strsym (name),
|
|
&visual, &exact))
|
|
Primitive_Error ("no such color: ~s", name);
|
|
ret = s48_cons (S48_NULL, S48_NULL);
|
|
S48_GC_PROTECT_1 (ret);
|
|
x = Make_Color (visual.red, visual.green, visual.blue);
|
|
S48_CAR (ret) = x;
|
|
x = Make_Color (exact.red, exact.green, exact.blue);
|
|
S48_CDR (ret) = x;
|
|
S48_GC_UNPROTECT;
|
|
return ret;
|
|
}
|
|
|
|
elk_init_xlib_color () {
|
|
Generic_Define (Color, "color", "color?");
|
|
Define_Primitive (P_Make_Color, "make-color", 3, 3, EVAL);
|
|
Define_Primitive (P_Color_Rgb_Values, "color-rgb-values", 1, 1, EVAL);
|
|
Define_Primitive (P_Query_Color, "query-color", 2, 2, EVAL);
|
|
Define_Primitive (P_Query_Colors, "query-colors", 2, 2, EVAL);
|
|
Define_Primitive (P_Lookup_Color, "lookup-color", 2, 2, EVAL);
|
|
}
|