1 ! Copyright (C) 2005, 2009 Eduardo Cavazos and Slava Pestov
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.c-types ascii assocs classes.struct combinators
4 combinators.short-circuit command-line environment io.encodings.ascii
5 io.encodings.string io.encodings.utf8 kernel literals locals math
6 namespaces sequences specialized-arrays.instances.alien.c-types.uchar
7 strings ui ui.backend ui.clipboards ui.event-loop ui.gadgets
8 ui.gadgets.private ui.gadgets.worlds ui.gestures ui.pixel-formats
9 ui.pixel-formats.private ui.private x11 x11.clipboard x11.constants
10 x11.events x11.glx x11.io x11.windows x11.xim x11.xlib ;
13 SINGLETON: x11-ui-backend
15 : XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
17 TUPLE: x11-handle-base glx ;
18 TUPLE: x11-handle < x11-handle-base window xic ;
19 TUPLE: x11-pixmap-handle < x11-handle-base pixmap glx-pixmap ;
21 C: <x11-handle> x11-handle
22 C: <x11-pixmap-handle> x11-pixmap-handle
24 M: world expose-event nip relayout ;
26 M: world configure-event
27 swap [ event-loc >>window-loc ] [ event-dim >>dim ] bi
28 ! In case dimensions didn't change
31 PIXEL-FORMAT-ATTRIBUTE-TABLE: glx-visual { $ GLX_USE_GL $ GLX_RGBA } H{
32 { double-buffered { $ GLX_DOUBLEBUFFER } }
33 { stereo { $ GLX_STEREO } }
34 { color-bits { $ GLX_BUFFER_SIZE } }
35 { red-bits { $ GLX_RED_SIZE } }
36 { green-bits { $ GLX_GREEN_SIZE } }
37 { blue-bits { $ GLX_BLUE_SIZE } }
38 { alpha-bits { $ GLX_ALPHA_SIZE } }
39 { accum-red-bits { $ GLX_ACCUM_RED_SIZE } }
40 { accum-green-bits { $ GLX_ACCUM_GREEN_SIZE } }
41 { accum-blue-bits { $ GLX_ACCUM_BLUE_SIZE } }
42 { accum-alpha-bits { $ GLX_ACCUM_ALPHA_SIZE } }
43 { depth-bits { $ GLX_DEPTH_SIZE } }
44 { stencil-bits { $ GLX_STENCIL_SIZE } }
45 { aux-buffers { $ GLX_AUX_BUFFERS } }
46 { sample-buffers { $ GLX_SAMPLE_BUFFERS } }
47 { samples { $ GLX_SAMPLES } }
50 M: x11-ui-backend (make-pixel-format)
51 [ drop dpy get scr get ] dip
52 >glx-visual-int-array glXChooseVisual ;
54 M: x11-ui-backend (free-pixel-format)
57 M: x11-ui-backend (pixel-format-attribute)
59 [ handle>> ] [ >glx-visual ] bi*
62 0 <int> [ glXGetConfig drop ] keep *int
74 { HEX: FF08 "BACKSPACE" }
79 { HEX: FFFF "DELETE" }
85 { HEX: FF55 "PAGE_UP" }
86 { HEX: FF56 "PAGE_DOWN" }
100 : key-code ( keysym -- keycode action? )
101 dup key-codes at [ t ] [ 1string f ] ?if ;
103 : event-modifiers ( event -- seq )
104 state>> modifiers modifier ;
106 : valid-input? ( string gesture -- ? )
107 over empty? [ 2drop f ] [
108 mods>> { f { S+ } } member? [
109 [ { [ 127 = not ] [ CHAR: \s >= ] } 1&& ] all?
111 [ { [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] } 1&& ] all?
115 : key-down-event>gesture ( event world -- string gesture )
117 handle>> xic>> lookup-string
118 [ swap event-modifiers ] dip key-code <key-down> ;
120 M: world key-down-event
121 [ key-down-event>gesture ] keep
122 [ propagate-key-gesture drop ]
123 [ 2over valid-input? [ nip user-input ] [ 3drop ] if ]
126 : key-up-event>gesture ( event -- gesture )
127 [ event-modifiers ] [ 0 XLookupKeysym key-code ] bi <key-up> ;
129 M: world key-up-event
130 [ key-up-event>gesture ] dip propagate-key-gesture ;
132 : mouse-event>gesture ( event -- modifiers button loc )
133 [ event-modifiers ] [ button>> ] [ event-loc ] tri ;
135 M: world button-down-event
136 [ mouse-event>gesture [ <button-down> ] dip ] dip
139 M: world button-up-event
140 [ mouse-event>gesture [ <button-up> ] dip ] dip
143 : mouse-event>scroll-direction ( event -- pair )
152 [ [ mouse-event>scroll-direction ] [ event-loc ] bi ] dip
155 M: world enter-event motion-event ;
157 M: world leave-event 2drop forget-rollover ;
159 M: world motion-event
160 [ event-loc ] dip move-hand fire-motion ;
162 M: world focus-in-event
163 nip [ handle>> xic>> XSetICFocus ] [ focus-world ] bi ;
165 M: world focus-out-event
166 nip [ handle>> xic>> XUnsetICFocus ] [ unfocus-world ] bi ;
168 M: world selection-notify-event
169 [ handle>> window>> selection-from-event ] keep
172 : supported-type? ( atom -- ? )
173 { "UTF8_STRING" "STRING" "TEXT" }
174 [ x-atom = ] with any? ;
176 : clipboard-for-atom ( atom -- clipboard )
178 { XA_PRIMARY [ selection get ] }
179 { XA_CLIPBOARD [ clipboard get ] }
183 : encode-clipboard ( string type -- bytes )
184 target>> XA_UTF8_STRING = utf8 ascii ? encode ;
186 : set-selection-prop ( evt -- )
190 [ target>> 8 PropModeReplace ] keep
191 [ selection>> clipboard-for-atom contents>> ] keep
192 encode-clipboard dup length XChangeProperty drop ;
194 M: world selection-request-event
196 { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
197 { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
198 { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
199 [ drop send-notify-failure ]
202 M: x11-ui-backend (close-window) ( handle -- )
204 [ glx>> destroy-glx ]
205 [ window>> [ unregister-window ] [ destroy-window ] bi ]
208 M: world client-event
209 swap close-box? [ ungraft ] [ drop ] if ;
211 : gadget-window ( world -- )
213 [ [ [ window-loc>> ] [ dim>> ] bi ] dip handle>> glx-window ]
214 with-world-pixel-format swap
215 dup "Factor" create-xic
217 [ window>> register-window ] [ >>handle drop ] 2bi ;
219 : wait-event ( -- event )
220 QueuedAfterFlush events-queued 0 > [
222 None XFilterEvent 0 = [ drop wait-event ] unless
223 ] [ wait-for-display wait-event ] if ;
225 M: x11-ui-backend do-events
226 wait-event dup XAnyEvent>> window>> window dup
227 [ handle-event ] [ 2drop ] if ;
229 : x-clipboard@ ( gadget clipboard -- prop win )
231 find-world handle>> window>> ;
233 M: x-clipboard copy-clipboard
234 [ x-clipboard@ own-selection ] keep
237 M: x-clipboard paste-clipboard
238 [ find-world handle>> window>> ] dip atom>> convert-selection ;
240 : init-clipboard ( -- )
241 XA_PRIMARY <x-clipboard> selection set-global
242 XA_CLIPBOARD <x-clipboard> clipboard set-global ;
244 : set-title-old ( dpy window string -- )
245 dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ;
247 : set-title-new ( dpy window string -- )
248 [ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
249 utf8 encode dup length XChangeProperty drop ;
251 : set-class ( dpy window -- )
252 XA_WM_CLASS XA_UTF8_STRING 8 PropModeReplace "Factor"
253 utf8 encode dup length XChangeProperty drop ;
255 M: x11-ui-backend set-title ( string world -- )
256 handle>> window>> swap
257 [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
259 : make-fullscreen-msg ( world ? -- msg )
260 XClientMessageEvent <struct>
263 "_NET_WM_STATE" x-atom >>message_type
264 swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0
265 swap handle>> window>> >>window
267 "_NET_WM_STATE_FULLSCREEN" x-atom >>data1 ;
269 M: x11-ui-backend (set-fullscreen) ( world ? -- )
270 [ dpy get root get 0 SubstructureNotifyMask ] 2dip
271 make-fullscreen-msg XSendEvent drop ;
273 M: x11-ui-backend (open-window) ( world -- )
276 [ set-closable ] [ dpy get swap set-class ] [ map-window ] tri ;
278 M: x11-ui-backend raise-window* ( world -- )
280 dpy get swap window>>
281 [ RevertToPointerRoot CurrentTime XSetInputFocus drop ]
282 [ XRaiseWindow drop ]
286 M: x11-handle select-gl-context ( handle -- )
288 [ window>> ] [ glx>> ] bi glXMakeCurrent
289 [ "Failed to set current GLX context" throw ] unless ;
291 M: x11-handle flush-gl-context ( handle -- )
292 dpy get swap window>> glXSwapBuffers ;
294 M: x11-pixmap-handle select-gl-context ( handle -- )
296 [ glx-pixmap>> ] [ glx>> ] bi glXMakeCurrent
297 [ "Failed to set current GLX context" throw ] unless ;
299 M: x11-pixmap-handle flush-gl-context ( handle -- )
302 M: x11-ui-backend (open-offscreen-buffer) ( world -- )
303 dup [ [ dim>> ] [ handle>> ] bi* glx-pixmap ] with-world-pixel-format
304 <x11-pixmap-handle> >>handle drop ;
306 M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
308 [ glx-pixmap>> glXDestroyGLXPixmap ]
309 [ pixmap>> XFreePixmap drop ]
310 [ glx>> glXDestroyContext ] 2tri ;
312 M: x11-ui-backend offscreen-pixels ( world -- alien w h )
313 [ [ dim>> ] [ handle>> pixmap>> ] bi pixmap-bits ] [ dim>> first2 ] bi ;
315 M: x11-ui-backend (with-ui) ( quot -- )
326 M: x11-ui-backend beep ( -- )
327 dpy get 100 XBell drop ;
329 : black ( -- xcolor ) 0 0 0 0 0 0 XColor <struct-boa> ; inline
331 M:: x11-ui-backend (grab-input) ( handle -- )
332 handle window>> :> wnd
334 dpy wnd uchar-array{ 0 0 0 0 0 0 0 0 } 8 8 XCreateBitmapFromData :> pixmap
335 dpy pixmap dup black dup 0 0 XCreatePixmapCursor :> cursor
337 dpy wnd 1 NoEventMask GrabModeAsync dup wnd cursor CurrentTime XGrabPointer drop
339 dpy cursor XFreeCursor drop
340 dpy pixmap XFreePixmap drop ;
342 M: x11-ui-backend (ungrab-input)
343 drop dpy get CurrentTime XUngrabPointer drop ;
345 x11-ui-backend ui-backend set-global
347 [ "DISPLAY" os-env "ui.tools" "listener" ? ]
348 main-vocab-hook set-global