1 ! Copyright (C) 2005, 2010 Eduardo Cavazos, Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays alien.c-types alien.data alien.syntax ascii
4 assocs classes.struct combinators combinators.short-circuit
5 command-line environment io.encodings.ascii io.encodings.string
6 io.encodings.utf8 kernel literals locals math namespaces
7 sequences specialized-arrays strings ui ui.backend ui.clipboards
8 ui.event-loop ui.gadgets ui.gadgets.private ui.gadgets.worlds
9 ui.gestures ui.pixel-formats ui.pixel-formats.private ui.private
10 x11 x11.clipboard x11.constants x11.events x11.glx x11.io
11 x11.windows x11.xim x11.xlib ;
12 FROM: libc => system ;
13 SPECIALIZED-ARRAYS: uchar ulong ;
16 SINGLETON: x11-ui-backend
18 : XA_NET_SUPPORTED ( -- atom ) "_NET_SUPPORTED" x-atom ;
19 : XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
20 : XA_NET_WM_STATE ( -- atom ) "_NET_WM_STATE" x-atom ;
21 : XA_NET_WM_STATE_FULLSCREEN ( -- atom ) "_NET_WM_STATE_FULLSCREEN" x-atom ;
22 : XA_NET_ACTIVE_WINDOW ( -- atom ) "_NET_ACTIVE_WINDOW" x-atom ;
24 : supported-net-wm-hints ( -- seq )
25 { Atom int ulong ulong pointer: Atom }
26 [| type format n-atoms bytes-after atoms |
31 ulong c-type-interval nip
43 [| type format n-atoms bytes-after atoms |
44 atoms n-atoms <direct-ulong-array> >array
48 : net-wm-hint-supported? ( atom -- ? )
49 supported-net-wm-hints member? ;
51 TUPLE: x11-handle-base glx ;
52 TUPLE: x11-handle < x11-handle-base window xic ;
53 TUPLE: x11-pixmap-handle < x11-handle-base pixmap glx-pixmap ;
55 C: <x11-handle> x11-handle
56 C: <x11-pixmap-handle> x11-pixmap-handle
58 M: world expose-event nip relayout ;
60 M: world configure-event
61 swap [ event-loc >>window-loc ] [ event-dim >>dim ] bi
62 ! In case dimensions didn't change
65 PIXEL-FORMAT-ATTRIBUTE-TABLE: glx-visual { $ GLX_RGBA } H{
66 { double-buffered { $ GLX_DOUBLEBUFFER } }
67 { stereo { $ GLX_STEREO } }
68 { color-bits { $ GLX_BUFFER_SIZE } }
69 { red-bits { $ GLX_RED_SIZE } }
70 { green-bits { $ GLX_GREEN_SIZE } }
71 { blue-bits { $ GLX_BLUE_SIZE } }
72 { alpha-bits { $ GLX_ALPHA_SIZE } }
73 { accum-red-bits { $ GLX_ACCUM_RED_SIZE } }
74 { accum-green-bits { $ GLX_ACCUM_GREEN_SIZE } }
75 { accum-blue-bits { $ GLX_ACCUM_BLUE_SIZE } }
76 { accum-alpha-bits { $ GLX_ACCUM_ALPHA_SIZE } }
77 { depth-bits { $ GLX_DEPTH_SIZE } }
78 { stencil-bits { $ GLX_STENCIL_SIZE } }
79 { aux-buffers { $ GLX_AUX_BUFFERS } }
80 { sample-buffers { $ GLX_SAMPLE_BUFFERS } }
81 { samples { $ GLX_SAMPLES } }
84 M: x11-ui-backend (make-pixel-format)
85 [ drop dpy get scr get ] dip
86 >glx-visual-int-array glXChooseVisual ;
88 M: x11-ui-backend (free-pixel-format)
91 M: x11-ui-backend (pixel-format-attribute)
93 [ handle>> ] [ >glx-visual ] bi*
96 { int } [ glXGetConfig drop ] with-out-parameters
108 { HEX: FF08 "BACKSPACE" }
111 { HEX: FF8D "ENTER" }
113 { HEX: FFFF "DELETE" }
117 { HEX: FF53 "RIGHT" }
119 { HEX: FF55 "PAGE_UP" }
120 { HEX: FF56 "PAGE_DOWN" }
122 { HEX: FF58 "BEGIN" }
134 : key-code ( keysym -- keycode action? )
135 dup key-codes at [ t ] [ 1string f ] ?if ;
137 : event-modifiers ( event -- seq )
138 state>> modifiers modifier ;
140 : valid-input? ( string gesture -- ? )
141 over empty? [ 2drop f ] [
142 mods>> { f { S+ } } member? [
143 [ { [ 127 = not ] [ CHAR: \s >= ] } 1&& ] all?
145 [ { [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] } 1&& ] all?
149 : key-down-event>gesture ( event world -- string gesture )
151 handle>> xic>> lookup-string
152 [ swap event-modifiers ] dip key-code <key-down> ;
154 M: world key-down-event
155 [ key-down-event>gesture ] keep
156 [ propagate-key-gesture drop ]
157 [ 2over valid-input? [ nip user-input ] [ 3drop ] if ]
160 : key-up-event>gesture ( event -- gesture )
161 [ event-modifiers ] [ 0 XLookupKeysym key-code ] bi <key-up> ;
163 M: world key-up-event
164 [ key-up-event>gesture ] dip propagate-key-gesture ;
166 : mouse-event>gesture ( event -- modifiers button loc )
167 [ event-modifiers ] [ button>> ] [ event-loc ] tri ;
169 M: world button-down-event
170 [ mouse-event>gesture [ <button-down> ] dip ] dip
173 M: world button-up-event
174 [ mouse-event>gesture [ <button-up> ] dip ] dip
177 : mouse-event>scroll-direction ( event -- pair )
185 M: world scroll-event
186 [ [ mouse-event>scroll-direction ] [ event-loc ] bi ] dip
189 M: world enter-event motion-event ;
191 M: world leave-event 2drop forget-rollover ;
193 M: world motion-event
194 [ event-loc ] dip move-hand fire-motion ;
196 M: world focus-in-event
197 nip [ handle>> xic>> XSetICFocus ] [ focus-world ] bi ;
199 M: world focus-out-event
200 nip [ handle>> xic>> XUnsetICFocus ] [ unfocus-world ] bi ;
202 M: world selection-notify-event
203 [ handle>> window>> selection-from-event ] keep
206 : supported-type? ( atom -- ? )
207 XA_UTF8_STRING XA_STRING XA_TEXT 3array member? ;
209 : clipboard-for-atom ( atom -- clipboard )
211 { XA_PRIMARY [ selection get ] }
212 { XA_CLIPBOARD [ clipboard get ] }
216 : encode-clipboard ( string type -- bytes )
217 target>> XA_UTF8_STRING = utf8 ascii ? encode ;
219 : set-selection-prop ( evt -- )
223 [ target>> 8 PropModeReplace ] keep
224 [ selection>> clipboard-for-atom contents>> ] keep
225 encode-clipboard dup length XChangeProperty drop ;
227 M: world selection-request-event
229 { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
230 { [ dup XA_TARGETS = ] [ drop dup set-targets-prop send-notify-success ] }
231 { [ dup XA_TIMESTAMP = ] [ drop dup set-timestamp-prop send-notify-success ] }
232 [ drop send-notify-failure ]
235 M: x11-ui-backend (close-window) ( handle -- )
237 [ glx>> destroy-glx ]
238 [ window>> [ unregister-window ] [ destroy-window ] bi ]
241 M: world client-event
242 swap close-box? [ ungraft ] [ drop ] if ;
244 : gadget-window ( world -- )
246 [ [ [ window-loc>> ] [ dim>> ] bi ] dip handle>> glx-window ]
247 with-world-pixel-format swap
248 dup "Factor" create-xic
250 [ window>> register-window ] [ >>handle drop ] 2bi ;
252 : wait-event ( -- event )
253 QueuedAfterFlush events-queued 0 > [
255 None XFilterEvent 0 = [ drop wait-event ] unless
256 ] [ wait-for-display wait-event ] if ;
258 M: x11-ui-backend do-events
259 wait-event dup XAnyEvent>> window>> window dup
260 [ handle-event ] [ 2drop ] if ;
262 : x-clipboard@ ( gadget clipboard -- prop win )
264 find-world handle>> window>> ;
266 M: x-clipboard copy-clipboard
267 [ x-clipboard@ own-selection ] keep
270 M: x-clipboard paste-clipboard
271 [ find-world handle>> window>> ] dip atom>> convert-selection ;
273 : init-clipboard ( -- )
274 XA_PRIMARY <x-clipboard> selection set-global
275 XA_CLIPBOARD <x-clipboard> clipboard set-global ;
277 : set-title-old ( dpy window string -- )
278 dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ;
280 : set-title-new ( dpy window string -- )
281 [ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
282 utf8 encode dup length XChangeProperty drop ;
284 : set-class ( dpy window -- )
285 XA_WM_CLASS XA_UTF8_STRING 8 PropModeReplace "Factor"
286 utf8 encode dup length XChangeProperty drop ;
288 M: x11-ui-backend set-title ( string world -- )
289 handle>> window>> swap
290 [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
292 : make-fullscreen-msg ( window ? -- msg )
293 XClientMessageEvent <struct>
296 XA_NET_WM_STATE >>message_type
297 swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0
300 XA_NET_WM_STATE_FULLSCREEN >>data1 ;
302 : send-event ( event -- )
307 SubstructureNotifyMask SubstructureRedirectMask bitor
308 ] dip XSendEvent drop ;
310 M: x11-ui-backend (set-fullscreen) ( world ? -- )
311 [ handle>> window>> ] dip make-fullscreen-msg send-event ;
313 M: x11-ui-backend (open-window) ( world -- )
314 dup gadget-window handle>> window>>
316 [ [ dpy get ] dip set-class ]
320 : make-raise-window-msg ( window -- msg )
321 XClientMessageEvent <struct>
326 XA_NET_ACTIVE_WINDOW >>message_type
329 : raise-window-new ( window -- )
330 make-raise-window-msg send-event ;
332 : raise-window-old ( window -- )
334 [ RevertToPointerRoot CurrentTime XSetInputFocus drop ]
335 [ XRaiseWindow drop ]
338 M: x11-ui-backend raise-window* ( world -- )
341 XA_NET_ACTIVE_WINDOW net-wm-hint-supported?
342 [ raise-window-new ] [ raise-window-old ] if
345 M: x11-handle select-gl-context ( handle -- )
347 [ window>> ] [ glx>> ] bi glXMakeCurrent
348 [ "Failed to set current GLX context" throw ] unless ;
350 M: x11-handle flush-gl-context ( handle -- )
351 dpy get swap window>> glXSwapBuffers ;
353 M: x11-pixmap-handle select-gl-context ( handle -- )
355 [ glx-pixmap>> ] [ glx>> ] bi glXMakeCurrent
356 [ "Failed to set current GLX context" throw ] unless ;
358 M: x11-pixmap-handle flush-gl-context ( handle -- )
361 M: x11-ui-backend (open-offscreen-buffer) ( world -- )
362 dup [ [ dim>> ] [ handle>> ] bi* glx-pixmap ] with-world-pixel-format
363 <x11-pixmap-handle> >>handle drop ;
365 M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
367 [ glx-pixmap>> glXDestroyGLXPixmap ]
368 [ pixmap>> XFreePixmap drop ]
369 [ glx>> glXDestroyContext ] 2tri ;
371 M: x11-ui-backend offscreen-pixels ( world -- alien w h )
372 [ [ dim>> ] [ handle>> pixmap>> ] bi pixmap-bits ] [ dim>> first2 ] bi ;
374 M: x11-ui-backend (with-ui) ( quot -- )
385 M: x11-ui-backend beep ( -- )
386 dpy get 100 XBell drop ;
389 : escape-' ( string -- string' )
390 [ dup CHAR: ' = [ drop "'\\''" ] [ 1string ] if ] { } map-as concat ;
392 : xmessage ( string -- )
393 escape-' "/usr/bin/env xmessage '" "'" surround system drop ;
396 M: x11-ui-backend system-alert
397 "\n\n" glue xmessage ;
399 : black ( -- xcolor ) 0 0 0 0 0 0 XColor <struct-boa> ; inline
401 M:: x11-ui-backend (grab-input) ( handle -- )
402 handle window>> :> wnd
404 dpy wnd uchar-array{ 0 0 0 0 0 0 0 0 } 8 8 XCreateBitmapFromData :> pixmap
405 dpy pixmap dup black dup 0 0 XCreatePixmapCursor :> cursor
407 dpy wnd 1 NoEventMask GrabModeAsync dup wnd cursor CurrentTime XGrabPointer drop
409 dpy cursor XFreeCursor drop
410 dpy pixmap XFreePixmap drop ;
412 M: x11-ui-backend (ungrab-input)
413 drop dpy get CurrentTime XUngrabPointer drop ;
415 x11-ui-backend ui-backend set-global
417 [ "DISPLAY" os-env "ui.tools" "listener" ? ]
418 main-vocab-hook set-global