(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)))
(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)
(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)))
(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))
(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)
(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))
(provide XQueryTree)
(define XQueryTree
(let* ((func 'XQueryTree)
(style-1 (get-ffi-obj func libx11
(_fun _XDisplay-pointer Window
(f1 : (_ptr o Window)) (f2 : (_ptr o Window)) (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)))))
(defx11* XQueryTree :
_XDisplay-pointer Window
(f1 : (_ptr o Window)) (f2 : (_ptr o Window)) (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))