Hacking on X11

Makefile

@@ -20,7 +20,7 @@ DEFAULT_LIBS = -lm
 ifdef NO_UI
 	UNIX_UI_LIBS =
 else
-	UNIX_UI_LIBS = -lfreetype -lGL -lX11
+	UNIX_UI_LIBS = -lfreetype -lGL -lGLU -lX11
 endif
 
 WIN32_OBJS = native/win32/ffi.o \

library/x11/ui.factor

@@ -1,17 +1,16 @@
-USING: kernel math namespaces opengl ;
+USING: alien kernel math namespaces opengl threads x11 ;
-USE: x11
 
-":0.0" initialize-x
+f initialize-x
 
-{ 500 500 0 } create-window
+SYMBOL: window
-dup map-window
 
-dup StructureNotifyMask select-input
+choose-visual
 
-dup choose-visual create-context make-current
+500 500 pick create-window window set
 
-: init ( -- )
+window get map-window
-    0.0 0.0 0.0 0.0 glClearColor GL_FLAT glShadeModel ;
+
+create-context window get swap make-current
 
 SYMBOL: pval
 
@@ -44,6 +43,7 @@ SYMBOL: pval
     glEnd ;
 
 : display ( -- )
+    0.0 0.0 0.0 0.0 glClearColor GL_FLAT glShadeModel
     GL_COLOR_BUFFER_BIT glClear
     1.0 1.0 1.0 glColor3f
     glLoadIdentity
@@ -52,8 +52,8 @@ SYMBOL: pval
     1.0 wire-cube
     glFlush ;
 
-init display
+display
 
-dup swap-buffers
+window get swap-buffers
 
 flush-dpy

library/x11/utilities.factor

@@ -1,30 +1,34 @@
 ! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 IN: x11
-USING: alien arrays errors kernel namespaces sequences ;
+USING: alien arrays errors io kernel math namespaces prettyprint
+sequences threads ;
 
 SYMBOL: dpy
 SYMBOL: scr
 SYMBOL: root
-SYMBOL: black-pixel
-SYMBOL: white-pixel
-
-! Initialization
-
-: initialize-x ( display-string -- )
-    XOpenDisplay [ "Cannot connect to X server" throw ] unless*
-    dpy set
-    dpy get XDefaultScreen scr set
-    dpy get scr get XRootWindow root set
-    dpy get scr get XBlackPixel black-pixel set
-    dpy get scr get XWhitePixel white-pixel set ;
 
 ! Window management
+: create-window-mask ( -- n )
+    CWBackPixel CWBorderPixel bitor
+    CWColormap bitor CWEventMask bitor ;
 
-: create-window ( dim -- win )
+: create-colormap ( visinfo -- colormap )
-    >r dpy get root get 0 0 r> first2
+    dpy get root get rot XVisualInfo-visual AllocNone
-    0 black-pixel get white-pixel get
+    XCreateColormap ;
-    XCreateSimpleWindow ;
+
+: window-attributes ( visinfo -- attributes )
+    "XSetWindowAttributes" <c-object>
+    0 over set-XSetWindowAttributes-background_pixel
+    0 over set-XSetWindowAttributes-border_pixel
+    [ >r create-colormap r> set-XSetWindowAttributes-colormap ] keep
+    StructureNotifyMask ExposureMask bitor over set-XSetWindowAttributes-event_mask ;
+
+: create-window ( w h visinfo -- window )
+    >r >r >r dpy get root get 0 0 r> r> 0 r>
+    [ XVisualInfo-depth InputOutput ] keep
+    [ XVisualInfo-visual create-window-mask ] keep
+    window-attributes XCreateWindow ;
 
 : destroy-window ( win -- )
     dpy get swap XDestroyWindow drop ;
@@ -54,26 +58,59 @@ SYMBOL: white-pixel
     dpy get "XEvent" <c-object> dup >r XNextEvent drop r> ;
 
 : mask-event ( mask -- event )
-  >r dpy get r> "XEvent" <c-object> dup >r XMaskEvent drop r> ;
+    >r dpy get r> "XEvent" <c-object> dup >r XMaskEvent drop r> ;
 
 : events-queued ( mode -- n ) >r dpy get r> XEventsQueued ;
 
+: next-event ( -- event )
+    dpy get "XEvent" <c-object> dup >r XNextEvent drop r> ;
+
+: wait-event ( -- event )
+      QueuedAfterFlush events-queued 0 >
+      [ next-event ] [ 10 sleep wait-event ] if ;
+
+: handle-event ( event -- )
+    XAnyEvent-type . flush ;
+
+: event-loop ( -- )
+    wait-event handle-event event-loop ;
+
 ! GLX
 
 : >int-array ( seq -- <int-array> )
-    [ length "int" <c-array> ] keep dup length
+    dup length dup "int" <c-array> -rot
     [ pick set-int-nth ] 2each ;
 
 : choose-visual ( -- XVisualInfo* )
     dpy get scr get
     GLX_RGBA GLX_DOUBLEBUFFER 0 3array >int-array
-    glXChooseVisual ;
+    glXChooseVisual
+    [ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ;
 
 : create-context ( XVisualInfo* -- GLXContext )
-    >r dpy get r> f 1 glXCreateContext ;
+    >r dpy get r> f 1 glXCreateContext
+    [ "Failed to create GLX context" throw ] unless* ;
 
 : make-current ( win GLXContext -- )
-    >r dpy get swap r> glXMakeCurrent drop ;
+    >r dpy get swap r> glXMakeCurrent
+    [ "Failed to set current GLX context" throw ] unless ;
 
 : swap-buffers ( win -- )
     dpy get swap glXSwapBuffers ;
+
+! Initialization
+
+: check-display
+    [ "Cannot connect to X server - check $DISPLAY" throw ] unless* ;
+
+: (initialize-x) ( display-string -- )
+    XOpenDisplay check-display dpy set
+    dpy get XDefaultScreen scr set
+    dpy get scr get XRootWindow root set ;
+
+: initialize-x ( display-string -- )
+    dpy get [
+        drop
+    ] [
+        (initialize-x) [ event-loop ] in-thread
+    ] if ;