/* $Id: kred-x.c,v 1.4 1993/06/14 06:59:56 czyborra Exp $ */
#include "/usr/elk/include/scheme.h"
#include <X11/X.h>
#include <X11/Xlib.h>
#include <X11/Xutil.h>

#define WIDTH  800
#define HEIGHT 600

static Display	*dsply;
static Window	visible;
static Atom	protocol;
static Pixmap	invisible;
static GC	gc[3];

static Object P_Kred_Init (void) 
{
    unsigned long screen, depth, black, white, red, green, values;
    Colormap colors;
    XGCValues options;
    XColor color;
    
    dsply = XOpenDisplay (NULL); 
    if (! dsply) return False;

    screen = DefaultScreen (dsply);
    depth  = DefaultDepth (dsply, screen);
    black  = BlackPixel (dsply, screen);
    white  = WhitePixel (dsply, screen);
    colors = DefaultColormap (dsply, screen);

    visible = XCreateSimpleWindow (dsply, DefaultRootWindow (dsply),
				   0, 0, WIDTH, HEIGHT, 1, black, white);
    XSelectInput (dsply, visible, ExposureMask | KeyPressMask 
		  | ButtonPressMask | ButtonReleaseMask);
    protocol = XInternAtom (dsply, "WM_DELETE_WINDOW", False);
    XSetWMProtocols (dsply, visible, &protocol, 1);
    XStoreName (dsply, visible, "kred");
    XMapWindow (dsply, visible);

    invisible = XCreatePixmap (dsply, visible, WIDTH, HEIGHT, depth); 
    options.function   = GXclear;
    options.background = white;
    gc[0] = XCreateGC (dsply, visible, GCBackground | GCFunction,  &options);
    XFillRectangle (dsply, invisible, gc[0], 0, 0, WIDTH, HEIGHT);

    options.line_width = 5;
    values = GCForeground | GCLineWidth;
    options.foreground = 
	(depth > 1 && XParseColor (dsply, colors, "red", &color) && 
	 XAllocColor (dsply, colors, &color)) ? (red = color.pixel) : black;
    gc[1] = XCreateGC (dsply, visible, values, &options);
    if (depth > 1 && XParseColor (dsply, colors, "forest green", &color) && 
	XAllocColor (dsply, colors, &color) && (green = color.pixel) != red
	&& green != white) options.foreground = green;
    /* auf Bit-Screens male dünn für grün, gestrichelt sieht zwar hübscher aus,
       ist aber extrem rechenaufwendig für den Display Server */
    else options.line_width = 3;
    gc[2] = XCreateGC (dsply, visible, values, &options);

    return True;
}

static Object P_Kred_Draw_Circle (Object X, Object Y, Object R, Object C) 
{
    int x, y, r, c;

    r = Get_Integer (R);
    x = Get_Integer (X) - r;
    y = Get_Integer (Y) - r;
    r *= 2;
    c = Get_Integer (C);
    XDrawArc (dsply, invisible, gc[c], x, y, r, r, 0, 360 * 64);
}

static Object P_Kred_Show_Drawing (void)
{
    XCopyArea (dsply, invisible, visible, gc[1], 0, 0, WIDTH, HEIGHT, 0, 0);
    XFillRectangle (dsply, invisible, gc[0], 0, 0, WIDTH, HEIGHT);
}

static Object P_Kred_Get_Next_Event (void)
{
    XEvent event;
    Object result, symbol;
    char *typestr = 0;
    
    do {
	XNextEvent (dsply, &event);
	
	switch (event.type)
	{
	case Expose: 
	    
	    typestr = "expose"; 
	    result = Null;
	    break;
	    
	case ClientMessage:
	{
	  XClientMessageEvent * message = (XClientMessageEvent*) &event;

	  if (message->data.l[0] == protocol) {
              typestr = "vanish";
              result = Null;
          }
          break;
      }                   
	case KeyPress: 
	{
	    char   keyname [10];
	    int    length;
	    KeySym ignore;
	    
	    typestr = "key-press"; length = XLookupString 
		( (XKeyEvent *) & event, keyname, 10, &ignore, 0);
	    result = Make_String (keyname, length);
	    result = Cons (result, Null);
	    /*  Cons kann zwar eine Speicherbereinigung auslösen, sollte aber
		selbst dafür sorgen, daß es nicht die ihm übergebenen Objekte
		verliert, daher ist GC_Link (result) unnötig.  */
	    break;
	}
	case ButtonPress:
	    typestr = "button-press";
	case ButtonRelease:
	{
	    XButtonEvent * button = (XButtonEvent*) &event;

	    if (! typestr) typestr = "button-release";
	    
	    result = Cons (Make_Integer (button->y), Null);
	    result = Cons (Make_Integer (button->x), result);
	    result = Cons (Make_Integer (button->button), result);
	}
	}
    } while (! typestr);
    
    symbol = Intern (typestr);
    result = Cons (symbol, result);
    
    return result;
}

void init_kred_x (void) 
{
    Object program;

    Define_Primitive (P_Kred_Init,           "kred-init",           0,0, EVAL);
    Define_Primitive (P_Kred_Draw_Circle,    "kred-draw-circle",    4,4, EVAL);
    Define_Primitive (P_Kred_Show_Drawing,   "kred-show-drawing",   0,0, EVAL);
    Define_Primitive (P_Kred_Get_Next_Event, "kred-get-next-event", 0,0, EVAL);

    program = Intern ("kred.scm"); P_Load (1, &program);
}