Hacking on X11
slava
parent
c98d9b7517
commit
57c8781e10
2
Makefile
2
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 \
|
||||
|
|
|
|||
|
|
@ -1,17 +1,16 @@
|
|||
USING: kernel math namespaces opengl ;
|
||||
USE: x11
|
||||
USING: alien kernel math namespaces opengl threads x11 ;
|
||||
|
||||
":0.0" initialize-x
|
||||
f initialize-x
|
||||
|
||||
{ 500 500 0 } create-window
|
||||
dup map-window
|
||||
SYMBOL: window
|
||||
|
||||
dup StructureNotifyMask select-input
|
||||
choose-visual
|
||||
|
||||
dup choose-visual create-context make-current
|
||||
500 500 pick create-window window set
|
||||
|
||||
: init ( -- )
|
||||
0.0 0.0 0.0 0.0 glClearColor GL_FLAT glShadeModel ;
|
||||
window get map-window
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
>r dpy get root get 0 0 r> first2
|
||||
0 black-pixel get white-pixel get
|
||||
XCreateSimpleWindow ;
|
||||
: create-colormap ( visinfo -- colormap )
|
||||
dpy get root get rot XVisualInfo-visual AllocNone
|
||||
XCreateColormap ;
|
||||
|
||||
: 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 ;
|
||||
|
|
@ -58,22 +62,55 @@ SYMBOL: white-pixel
|
|||
|
||||
: 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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue