(module x11 mzscheme

  (require (lib "foreign.ss")) (unsafe!)

  (define libx11 (ffi-lib "libX11"))

  (define-syntax defx11
    (syntax-rules (:)
      ((_ id : x ...)
         (define id
	   #; (get-ffi-obj (symbol->string 'id) liballegro (_fun x ...))

	   (get-ffi-obj (regexp-replaces 'id '((#rx"-" "_"))) libx11 (_fun x ...))
	   ))))


  (define-syntax defx11*
    (syntax-rules (:)
      ((_ id : x ...)
       (begin
	 (defx11 id : x ...)
	 (provide id)))
      ((_ (id x ...) expr ...)
       (begin
	 (provide id)
	 (define id (lambda (x ...)
		      expr ...))))))

  (define Status _int)
  (define Pixel _ulong)
  (define XID _ulong)
  (define Atom _ulong)
  (define Window XID)
  (define Drawable XID)
  (define Pixmap XID)
  (define Font XID)
  (define ColorMap XID)
  (define GContext XID)
  (define KeySym XID)
  (provide XID Window Pixmap ColorMap GContext KeySym)

  (define RectangleRegion
    (_enum '(RectangleOut = 0
             RectangleIn = 1
             RectanglePart = 2)))

  (define AtomProperty
    (_enum '(XA_PRIMARY = 1
             XA_SECONDARY = 2
             XA_ARC = 3
             XA_ATOM = 4
             XA_BITMAP = 5
             XA_CARDINAL = 6
             XA_COLORMAP = 7
             XA_CURSOR = 8
             XA_CUT_BUFFER0 = 9
             XA_CUT_BUFFER1 = 10
             XA_CUT_BUFFER2 = 11
             XA_CUT_BUFFER3 = 12
             XA_CUT_BUFFER4 = 13
             XA_CUT_BUFFER5 = 14
             XA_CUT_BUFFER6 = 15
             XA_CUT_BUFFER7 = 16
             XA_DRAWABLE = 17
             XA_FONT = 18
             XA_INTEGER = 19
             XA_PIXMAP = 20
             XA_POINT = 21
             XA_RECTANGLE = 22
             XA_RESOURCE_MANAGER = 23
             XA_RGB_COLOR_MAP = 24
             XA_RGB_BEST_MAP = 25
             XA_RGB_BLUE_MAP = 26
             XA_RGB_DEFAULT_MAP = 27
             XA_RGB_GRAY_MAP = 28
             XA_RGB_GREEN_MAP = 29
             XA_RGB_RED_MAP = 30
             XA_STRING = 31
             XA_VISUALID = 32
             XA_WINDOW = 33
             XA_WM_COMMAND = 34
             XA_WM_HINTS = 35
             XA_WM_CLIENT_MACHINE = 36
             XA_WM_ICON_NAME = 37
             XA_WM_ICON_SIZE = 38
             XA_WM_NAME = 39
             XA_WM_NORMAL_HINTS = 40
             XA_WM_SIZE_HINTS = 41
             XA_WM_ZOOM_HINTS = 42
             XA_MIN_SPACE = 43
             XA_NORM_SPACE = 44
             XA_MAX_SPACE = 45
             XA_END_SPACE = 46
             XA_SUPERSCRIPT_X = 47
             XA_SUPERSCRIPT_Y = 48
             XA_SUBSCRIPT_X = 49
             XA_SUBSCRIPT_Y = 50
             XA_UNDERLINE_POSITION = 51
             XA_UNDERLINE_THICKNESS = 52
             XA_STRIKEOUT_ASCENT = 53
             XA_STRIKEOUT_DESCENT = 54
             XA_ITALIC_ANGLE = 55
             XA_X_HEIGHT = 56
             XA_QUAD_WIDTH = 57
             XA_WEIGHT = 58
             XA_POINT_SIZE = 59
             XA_RESOLUTION = 60
             XA_COPYRIGHT = 61
             XA_NOTICE = 62
             XA_FONT_NAME = 63
             XA_FAMILY_NAME = 64
             XA_FULL_NAME = 65
             XA_CAP_HEIGHT = 66
             XA_WM_CLASS = 67
             XA_WM_TRANSIENT_FOR = 68
             XA_LAST_PREDEFINED = 68)))

  (define FillStyle
    (_enum '(FillSolid = 0
	     FillTiled = 1
	     FillStippled = 2
	     FillOpaqueStippled = 3)))

  (define WindowViewable
    (_enum '(IsUnmapped = 0
             IsUnviewable = 1
             IsViewable = 2)))

  (define EventQueue
    (_enum '(QueuedAlready = 0
             QueuedAfterReading = 1
             QueuedAfterFlush 2)))

  (define EventType
    (_enum '(KeyPress = 2
             KeyRelease = 3
             ButtonPress = 4
             ButtonRelease = 5
             MotionNotify = 6
             EnterNotify = 7
             LeaveNotify = 8
             FocusIn = 9
             FocusOut = 10
             KeymapNotify = 11
             Expose = 12
             GraphicsExpose = 13
             NoExpose = 14
             VisibilityNotify = 15
             CreateNotify = 16
             DestroyNotify = 17
             UnmapNotify = 18
             MapNotify = 19
             MapRequest = 20
             ReparentNotify = 21
             ConfigureNotify = 22
             ConfigureRequest = 23
             GravityNotify = 24
             ResizeRequest = 25
             CirculateNotify = 26
             CirculateRequest = 27
             PropertyNotify = 28
             SelectionClear = 29
             SelectionRequest = 30
             SelectionNotify = 31
             ColormapNotify = 32
             ClientMessage = 33
             MappingNotify = 34
             LASTEvent = 35)))

  (define InputMask
    (_bitmask '(NoEventMask =              #x00000000
                KeyPressMask =             #x00000001
                KeyReleaseMask =           #x00000002
                ButtonPressMask =          #x00000004
                ButtonReleaseMask =        #x00000008
                EnterWindowMask =          #x00000010
                LeaveWindowMask =          #x00000020
                PointerMotionMask =        #x00000040
                PointerMotionHintMask =    #x00000080
                Button1MotionMask =        #x00000100
                Button2MotionMask =        #x00000200
                Button3MotionMask =        #x00000400
                Button4MotionMask =        #x00000800
                Button5MotionMask =        #x00001000
                ButtonMotionMask =         #x00002000
                KeymapStateMask =          #x00004000
                ExposureMask =             #x00008000
                VisibilityChangeMask =     #x00010000
                StructureNotifyMask =      #x00020000
                ResizeRedirectMask =       #x00040000
                SubstructureNotifyMask =   #x00080000
                SubstructureRedirectMask = #x00100000
                FocusChangeMask =          #x00200000
                PropertyChangeMask =       #x00400000
                ColormapChangeMask =       #x00800000
                OwnerGrabButtonMask =      #x01000000)))


  #|
  typedef struct {
	XExtData *ext_data;	/* hook for extension to hang data */
	struct _XDisplay *display;/* back pointer to display structure */
	Window root;		/* Root window id. */
	int width, height;	/* width and height of screen */
	int mwidth, mheight;	/* width and height of  in millimeters */
	int ndepths;		/* number of depths possible */
	Depth *depths;		/* list of allowable depths on the screen */
	int root_depth;		/* bits per pixel */
	Visual *root_visual;	/* root visual */
	GC default_gc;		/* GC for the root root visual */
	Colormap cmap;		/* default color map */
	unsigned long white_pixel;
	unsigned long black_pixel;	/* White and Black pixel values */
	int max_maps, min_maps;	/* max and min color maps */
	int backing_store;	/* Never, WhenMapped, Always */
	Bool save_unders;
	long root_input_mask;	/* initial root input mask */
} Screen;

  |#

  
  (define-cstruct _XGC
    ((ext-data _pointer)
     (gid GContext)))

  (define-cstruct _XDisplay
    ((ext-data _pointer)
     (private1 _pointer)
     (fd _int)
     (private2 _int)
     (proto_major_version _int)
     (proto_minor_version _int)
     (vendor _string)
     (private3 XID)
     (private4 XID)
     (private5 XID)
     (private6 XID)
     (resource_alloc _pointer)
     (byte-order _int)
     (bitmap-unit _int)
     (bitmap-pad _int)
     (bitmap-bit-order _int)
     (nformats _int)
     (pixmap-format _pointer)
     (private8 _int)
     (releaes _int)
     (private9 _pointer)
     (private10 _pointer)
     (qlen _int)
     (last-request-read _ulong)
     (request _ulong)
     (private11 _pointer)
     (private12 _pointer)
     (private13 _pointer)
     (private14 _pointer)
     (max-request-size _uint)
     (db _pointer)
     (private15 _pointer)
     (display-name _string)
     (default-screen _int)
     (nscreens _int)
     (screens _pointer)
     (motion-buffer _ulong)
     (private16 _ulong)
     (min-keycode _int)
     (max-keycode _int)
     (private17 _pointer)
     (private18 _pointer)
     (private19 _int)
     (xdefaults _string)))
  (provide _XDisplay-pointer)

  #|

  typedef struct
#ifdef XLIB_ILLEGAL_ACCESS
_XDisplay
#endif
{
	XExtData *ext_data;	/* hook for extension to hang data */
	struct _XPrivate *private1;
	int fd;			/* Network socket. */
	int private2;
	int proto_major_version;/* major version of server's X protocol */
	int proto_minor_version;/* minor version of servers X protocol */
	char *vendor;		/* vendor of the server hardware */
        XID private3;
	XID private4;
	XID private5;
	int private6;
	XID (*resource_alloc)(	/* allocator function */
		struct _XDisplay*
	);
	int byte_order;		/* screen byte order, LSBFirst, MSBFirst */
	int bitmap_unit;	/* padding and data requirements */
	int bitmap_pad;		/* padding requirements on bitmaps */
	int bitmap_bit_order;	/* LeastSignificant or MostSignificant */
	int nformats;		/* number of pixmap formats in list */
	ScreenFormat *pixmap_format;	/* pixmap format list */
	int private8;
	int release;		/* release of the server */
	struct _XPrivate *private9, *private10;
	int qlen;		/* Length of input event queue */
	unsigned long last_request_read; /* seq number of last event read */
	unsigned long request;	/* sequence number of last request. */
	XPointer private11;
	XPointer private12;
	XPointer private13;
	XPointer private14;
	unsigned max_request_size; /* maximum number 32 bit words in request*/
	struct _XrmHashBucketRec *db;
	int (*private15)(
		struct _XDisplay*
		);
	char *display_name;	/* "host:display" string used on this connect*/
	int default_screen;	/* default screen for operations */
	int nscreens;		/* number of screens on this server*/
	Screen *screens;	/* pointer to list of screens */
	unsigned long motion_buffer;	/* size of motion buffer */
	unsigned long private16;
	int min_keycode;	/* minimum defined keycode */
	int max_keycode;	/* maximum defined keycode */
	XPointer private17;
	XPointer private18;
	int private19;
	char *xdefaults;	/* contents of defaults from server */
	/* there is more to this structure, but it is private to Xlib */
}
#ifdef XLIB_ILLEGAL_ACCESS
Display,
#endif
*_XPrivDisplay;

  |#

  ;; Im to lazy to really figure out what this should be
  ;; so ill just overcompensate
  (define-cstruct _XEvent
    ((type EventType)
     (pad1 _int)
     (pad2 _int)
     (padx1 _long)
     (padx2 _long)
     (padx3 _long)
     (padx4 _long)
     (padx5 _long)
     (padx6 _long)
     (padx7 _long)
     (padx8 _long)
     (padx9 _long)
     (padx10 _long)))

  ;; more laziness
  (define (make-dummy-XEvent)
    (let ((s (malloc _XEvent 1)))
      (cpointer-push-tag! s XEvent-tag)
      s))
  (provide XEvent-type make-XEvent make-dummy-XEvent)

  (define-cstruct _XExposeEvent
    ((type _int)
     (serial _ulong)
     (send-event _bool)
     (display _XDisplay-pointer)
     (window Window)
     (x _int)
     (y _int)
     (width _int)
     (height _int)
     (count _int)))
  (provide XExposeEvent-tag XExposeEvent-x XExposeEvent-y 
	   XExposeEvent-width XExposeEvent-height)

  (define-cstruct _XGCValues
    ((function _int)
     (plane-mask _ulong)
     (foreground _ulong)
     (background _ulong)
     (line-width _int)
     (line-style _int)
     (cap-style _int)
     (join-style _int)
     (fill-style _int)
     (fill-rule _int)
     (arc-mode _int)
     (tile Pixmap)
     (stipple Pixmap)
     (ts-x-origin _int)
     (ts-y-origin _int)
     (font Font)
     (subwindow-mode _int)
     (graphics-exposures _bool)
     (clip-x-origin _int)
     (clip-y-origin _int)
     (clip-mask Pixmap)
     (dash-offset _int)
     (dashes _byte)))
  (define (make-dummy-XGCValues)
    (make-XGCValues 0 0 0 0
		    0 0 0 0
		    0 0 0 0
		    0 0 0 0
		    0 #f 0 0
		    0 0 0))

  (provide _XGCValues XGCValues-tag make-dummy-XGCValues)

  (define-cstruct _XColor
    ((pixel _ulong)
     (red _ushort)
     (green _ushort)
     (blue _ushort)
     (flags _byte)
     (pad _byte)))

  (define-cstruct _Box
    ((x1 _short)
     (x2 _short)
     (y1 _short)
     (y2 _short)))

  (define-cstruct _XRectangle
    ((x _short)
     (y _short)
     (width _short)
     (height _short)))
  (provide make-XRectangle XRectangle-width XRectangle-height XRectangle-x XRectangle-y
	   set-XRectangle-height! set-XRectangle-width! set-XRectangle-x! set-XRectangle-y!)
  #;
  (provide _XRectangle XRectangle-tag set-XRectangle-x! set-XRectangle-y!
	   set-XRectangle-width! set-XRectangle-height!)

  (define-cstruct _XRegion
    ((size _long)
     (numRects _long)
     (rects _Box-pointer)
     (extends _Box)))
  
  (define-cstruct _Screen
    ((ext-data _pointer)
     (display _XDisplay-pointer)
     (root Window)
     (width _int)
     (height _int)
     (mwidth _int)
     (mheight _int)
     (ndepths _int)
     (depths _pointer)
     (root-depth _int)
     (root-visual _pointer)
     (default-gc _pointer)
     (cmap ColorMap)
     (white-pixel _ulong)
     (black-pixel _ulong)
     (max-maps _int)
     (min-maps _int)
     (backing-store _int)
     (save-unders _bool)
     (root-input-mask _ulong)))

  (define-cstruct _XWindowAttributes
    ((x _int)
     (y _int)
     (width _int)
     (height _int)
     (border-width _int)
     (depth _int)
     (visual _pointer)
     (root Window)
     (class _int)
     (bit-gravity _int)
     (win-gravity _int)
     (backing-store _int)
     (backing-planes _ulong)
     (backing-pixel _ulong)
     (save-under _bool)
     (colormap ColorMap)
     (map-installed _bool)
     (map-state WindowViewable)
     (all-event-maskes _long)
     (your-event-mask _long)
     (do-not-propagate-mask _long)
     (override-redirect _bool)
     (screen _Screen-pointer/null)))
  (define (make-dummy-attributes)
    (make-XWindowAttributes 0 0 0 0
			    0 0 #f 0
			    0 0 0 0
			    0 0 #f 0 #f
			    'IsUnmapped 
			    0 0 0 #f #f))
  (provide XWindowAttributes-save-under XWindowAttributes-map-state 
	   (rename make-dummy-attributes make-XWindowAttributes))

  ;; this makes things work in KDE
  (define (virtual-root-window screen)
    (let* ((display (Screen-display screen))
	   (root (Screen-root screen))
	   (swm-vroot (XInternAtom display "__SWM_VROOT" #f)))
      (for-each (lambda (window)
		  (let ((new-window (XGetWindowProperty display window
							swm-vroot 0 1 #f 'XA_WINDOW)))
		    (when new-window
		      (set! root (ptr-ref new-window Window 0)))))
		(XQueryTree display root))
      root))

  (defx11* XInternAtom : _XDisplay-pointer _string _bool -> Atom)

  ;; Return &(display->screens[screen])
  (define (screen-of-display display screen)
    (ptr-ref (XDisplay-screens display) _Screen screen))

  (defx11* (DisplayWidth display screen)
	     (Screen-width (screen-of-display display screen)))

  (defx11* (DisplayHeight display screen)
	     (Screen-height (screen-of-display display screen)))

  (defx11* (BlackPixel display screen)
	     (Screen-black-pixel (screen-of-display display screen)))

  (defx11* (WhitePixel display screen)
	     (Screen-white-pixel (screen-of-display display screen)))

  (defx11* (DefaultScreen display)
	     (XDisplay-default-screen display))

  (defx11* (RootWindow display screen)
	     (virtual-root-window (screen-of-display display screen)))

  (defx11* (DefaultColorMap display screen)
	     (Screen-cmap (screen-of-display display screen)))

  (defx11* (AllocNamedColor display screen name default)
	     (let-values (((ret screen-color exact-color)
			       (XAllocNamedColor display 
						 (DefaultColorMap display screen) 
						 name)))
               (if (not (= 0 ret))
		 (XColor-pixel screen-color)
		 default)))

  (defx11* XGrabServer : _XDisplay-pointer -> _int)
  (defx11* XUngrabServer : _XDisplay-pointer -> _int)

  (defx11 XAllocNamedColor : _XDisplay-pointer ColorMap _string
	                     (screen-color : (_ptr o _XColor))
			     (exact-color : (_ptr o _XColor))
			     -> (out : _int)
			     -> (values out screen-color exact-color))

  (defx11* XFree : _pointer -> _int)

  (defx11* XPending : _XDisplay-pointer -> _bool)

  (defx11* XNextEvent : _XDisplay-pointer _XEvent-pointer -> _int)
  (defx11* (NextEvent display)
	     (let ((e (make-XEvent 'LASTEvent 0 0)))
	       (XNextEvent display e)
	       e))

  (defx11* XGetGeometry :
	   _XDisplay-pointer Drawable (dummy1 : (_ptr o Window))
	   (x : (_ptr o _int)) (y : (_ptr o _int))
	   (width : (_ptr o _uint)) (height : (_ptr o _uint))
	   (border-width : (_ptr o _uint)) (depth : (_ptr o _uint))
	   -> Status
	   -> (values x y width height border-width depth))

  ;; this could theoretically be extended to not ignore f1 and f2
  ;; f1 - root return
  ;; f2 - parent return
  (provide XQueryTree)
  (define XQueryTree
    (let* ((func 'XQueryTree)
	   (style-1 (get-ffi-obj func libx11 
		     (_fun _XDisplay-pointer Window 
		       (f1 : (_ptr o Window)) ;; dont care
		       (f2 : (_ptr o Window)) ;; dont care
		       (children : (_ptr o _pointer))
		       (nchildren : (_ptr o _int))
		       -> (status : _bool)
		       -> (if (not status)
			    '()
			    (begin
			      (register-finalizer children 
						  (lambda (c) (XFree c)))
			      (cblock->list children Window nchildren)))))))
      (case-lambda
	((display window)
	 (style-1 display window)))))

  ;; Return a list of int's( Window ids )
  #;
  (defx11* XQueryTree :
	   _XDisplay-pointer Window 
	   (f1 : (_ptr o Window)) ;; dont care
	   (f2 : (_ptr o Window)) ;; dont care
	   (children : (_ptr o _pointer))
	   (nchildren : (_ptr o _int))
	   -> (status : _bool)
	   -> (if (not status)
		'()
		(begin
		  (register-finalizer children (lambda (c) (XFree c)))
		  (cblock->list children Window nchildren))))

  (defx11* XSetErrorHandler : (_fun _XDisplay-pointer _XEvent-pointer -> _int) -> _void)

  (defx11* XCreateGC :
	   _XDisplay-pointer Drawable _ulong _XGCValues-pointer/null -> _XGC-pointer)

  (defx11* XGetGCValues :
	   _XDisplay-pointer _XGC-pointer _ulong _XGCValues-pointer -> Status)

  (defx11* XCreateBitmapFromData :
	   _XDisplay-pointer Drawable _pointer _uint _uint -> Pixmap)

  (defx11* XSetForeground :
	   _XDisplay-pointer _XGC-pointer _ulong -> _int)

  (defx11* XPointInRegion : _XRegion-pointer _int _int -> _bool)
  
  (defx11* XUnionRectWithRegion :
	   _XRectangle-pointer _XRegion-pointer _XRegion-pointer
	   -> _int)

  (defx11* XSubtractRegion :
	   _XRegion-pointer _XRegion-pointer _XRegion-pointer
	   -> _int)

  (defx11* XCreateRegion :
	   -> _XRegion-pointer)

  (defx11* XDestroyRegion : _XRegion-pointer -> _int)

  (defx11* XSetStipple :
	   _XDisplay-pointer _XGC-pointer Pixmap -> _int)

  (defx11* XSetFillStyle :
	   _XDisplay-pointer _XGC-pointer FillStyle -> _int)

  (defx11* XSetTSOrigin :
	   _XDisplay-pointer _XGC-pointer _int _int -> _int)

  (defx11* XFillRectangle :
	   _XDisplay-pointer Drawable _XGC-pointer _int _int _uint _uint -> _int)

  (defx11* XRectInRegion : 
	   _XRegion-pointer _int _int _uint _uint -> RectangleRegion)

  (defx11* XCopyGC :
	   _XDisplay-pointer _XGC-pointer _ulong _XGC-pointer -> _int)

  (defx11* XClearArea :
	   _XDisplay-pointer Window _int _int _uint _uint _bool -> _int)

  (defx11* XSelectInput :
	   _XDisplay-pointer Window InputMask -> _int)

  (defx11* XEventsQueued :
	   _XDisplay-pointer EventQueue -> _int)

  (defx11* XGetWindowProperty :
	   _XDisplay-pointer Window
	   Atom _long _long _bool AtomProperty
	   (_ptr o Atom)
	   (_ptr o _int)
	   (_ptr o _ulong)
	   (_ptr o _ulong)
	   (ret : (_ptr o _pointer))
	   -> _bool
	   -> ret)

  (defx11* XGetWindowAttributes :
	   _XDisplay-pointer Window _XWindowAttributes-pointer
	   -> Status)

  (defx11* XOpenDisplay : _string -> _XDisplay-pointer))