#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);
}