2006-03-20 00:05:04 -05:00
|
|
|
IN: x11
|
2006-03-21 15:17:49 -05:00
|
|
|
USING: arrays errors freetype gadgets gadgets-launchpad
|
2006-03-20 00:05:04 -05:00
|
|
|
gadgets-layouts gadgets-listener hashtables kernel
|
|
|
|
|
kernel-internals math namespaces opengl sequences x11 ;
|
|
|
|
|
|
2006-03-21 18:19:06 -05:00
|
|
|
M: world expose-event ( event world -- ) nip draw-world ;
|
2006-03-20 00:05:04 -05:00
|
|
|
|
2006-03-21 18:19:06 -05:00
|
|
|
M: world resize-event ( event world -- )
|
2006-03-20 00:05:04 -05:00
|
|
|
>r
|
|
|
|
|
dup XConfigureEvent-width swap XConfigureEvent-height 0
|
|
|
|
|
3array
|
|
|
|
|
r> set-gadget-dim ;
|
|
|
|
|
|
2006-03-21 18:19:06 -05:00
|
|
|
M: world button-down-event ( event world -- )
|
|
|
|
|
drop XButtonEvent-button send-button-down ;
|
|
|
|
|
|
|
|
|
|
M: world button-up-event ( event world -- )
|
|
|
|
|
drop XButtonEvent-button send-button-up ;
|
|
|
|
|
|
|
|
|
|
M: world motion-event ( event world -- )
|
|
|
|
|
>r dup XMotionEvent-x swap XMotionEvent-y 0 3array r>
|
|
|
|
|
move-hand ;
|
|
|
|
|
|
|
|
|
|
M: world key-event ( event world -- ) 2drop ;
|
|
|
|
|
|
2006-03-20 00:05:04 -05:00
|
|
|
: gadget-window ( world -- window )
|
|
|
|
|
dup rect-dim first2 choose-visual [
|
|
|
|
|
create-window 2dup windows get set-hash dup map-window
|
|
|
|
|
] keep create-context 2array swap set-world-handle ;
|
|
|
|
|
|
|
|
|
|
IN: gadgets
|
|
|
|
|
|
2006-03-21 17:15:53 -05:00
|
|
|
: draw-handle ( handle -- ) first windows get hash draw-world ;
|
2006-03-20 00:05:04 -05:00
|
|
|
|
|
|
|
|
: in-window ( gadget status dim title -- )
|
|
|
|
|
>r <world> r> drop gadget-window ;
|
|
|
|
|
|
2006-03-21 15:17:49 -05:00
|
|
|
: select-gl-context ( handle -- )
|
2006-03-21 17:15:53 -05:00
|
|
|
dpy get swap first2 glXMakeCurrent
|
2006-03-21 15:17:49 -05:00
|
|
|
[ "Failed to set current GLX context" throw ] unless ;
|
|
|
|
|
|
|
|
|
|
: flush-gl-context ( handle -- )
|
|
|
|
|
dpy get swap first glXSwapBuffers ;
|
|
|
|
|
|
2006-03-20 00:05:04 -05:00
|
|
|
IN: shells
|
|
|
|
|
|
|
|
|
|
: ui ( -- )
|
|
|
|
|
[
|
|
|
|
|
f [
|
|
|
|
|
launchpad-window
|
|
|
|
|
listener-window
|
|
|
|
|
event-loop
|
|
|
|
|
] with-x
|
|
|
|
|
] with-freetype ;
|
|
|
|
|
|
|
|
|
|
IN: kernel
|
|
|
|
|
|
2006-03-21 18:19:06 -05:00
|
|
|
! : default-shell "DISPLAY" os-env empty? "tty" "ui" ? ;
|