1 ! Copyright (C) 2010, 2011 Anton Gorenko, Philipp Bruschweiler.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.accessors alien.c-types alien.data
4 alien.strings arrays assocs classes.struct command-line
5 continuations destructors environment gdk.ffi gdk.gl.ffi
6 glib.ffi gobject-introspection.standard-types gobject.ffi
7 gtk.ffi gtk.gl.ffi io.encodings.utf8 kernel libc literals locals
8 math math.bitwise math.order math.vectors namespaces sequences
9 strings system threads ui ui.backend ui.backend.gtk.input-methods
10 ui.backend.gtk.io ui.clipboards ui.event-loop ui.gadgets
11 ui.gadgets.private ui.gadgets.worlds ui.gestures
12 ui.pixel-formats ui.pixel-formats.private ui.private
13 vocabs.loader combinators prettyprint io ;
16 SINGLETON: gtk-ui-backend
19 TUPLE: window-handle < handle window fullscreen? im-context ;
21 : <window-handle> ( window im-context -- window-handle )
26 : connect-signal-with-data ( object signal-name callback data -- )
27 [ utf8 string>alien ] 2dip g_signal_connect drop ;
29 : connect-signal ( object signal-name callback -- )
30 f connect-signal-with-data ;
34 TUPLE: gtk-clipboard handle ;
36 C: <gtk-clipboard> gtk-clipboard
38 M: gtk-clipboard clipboard-contents
40 handle>> gtk_clipboard_wait_for_text
41 [ &g_free utf8 alien>string ] [ f ] if*
44 M: gtk-clipboard set-clipboard-contents
45 swap [ handle>> ] [ utf8 string>alien ] bi*
46 -1 gtk_clipboard_set_text ;
48 : init-clipboard ( -- )
52 utf8 string>alien gdk_atom_intern_static_string
53 gtk_clipboard_get <gtk-clipboard> swap set-global
58 SYMBOL: next-fire-time
60 : set-timeout*-value ( alien value -- )
61 swap 0 set-alien-signed-4 ; inline
63 : timer-prepare ( source timeout* -- ? )
64 nip next-fire-time get-global nano-count [-]
65 [ 1,000,000 /i set-timeout*-value ] keep 0 = ;
67 : timer-check ( source -- ? )
68 drop next-fire-time get-global nano-count [-] 0 = ;
70 : timer-dispatch ( source callback user_data -- ? )
71 3drop sleep-time [ 1,000,000,000 ] unless* nano-count +
72 next-fire-time set-global
75 : <timer-funcs> ( -- timer-funcs )
76 GSourceFuncs malloc-struct
77 [ timer-prepare ] GSourceFuncsPrepareFunc >>prepare
78 [ timer-check ] GSourceFuncsCheckFunc >>check
79 [ timer-dispatch ] GSourceFuncsDispatchFunc >>dispatch ;
81 :: with-timer ( quot -- )
82 nano-count next-fire-time set-global
84 GSource heap-size g_source_new &g_source_unref :> source
85 source f g_source_attach drop
87 [ source g_source_destroy ] [ ] cleanup ;
93 GDK_POINTER_MOTION_MASK
94 GDK_POINTER_MOTION_HINT_MASK
98 GDK_BUTTON_RELEASE_MASK
101 GDK_FOCUS_CHANGE_MASK
106 { S+ $ GDK_SHIFT_MASK }
107 { C+ $ GDK_CONTROL_MASK }
108 { A+ $ GDK_MOD1_MASK }
111 CONSTANT: action-key-codes
113 { $ GDK_KEY_BackSpace "BACKSPACE" }
114 { $ GDK_KEY_Tab "TAB" }
115 { $ GDK_KEY_Return "RET" }
116 { $ GDK_KEY_KP_Enter "ENTER" }
117 { $ GDK_KEY_Escape "ESC" }
118 { $ GDK_KEY_Delete "DELETE" }
119 { $ GDK_KEY_Home "HOME" }
120 { $ GDK_KEY_Left "LEFT" }
121 { $ GDK_KEY_Up "UP" }
122 { $ GDK_KEY_Right "RIGHT" }
123 { $ GDK_KEY_Down "DOWN" }
124 { $ GDK_KEY_Page_Up "PAGE_UP" }
125 { $ GDK_KEY_Page_Down "PAGE_DOWN" }
126 { $ GDK_KEY_End "END" }
127 { $ GDK_KEY_Begin "BEGIN" }
128 { $ GDK_KEY_F1 "F1" }
129 { $ GDK_KEY_F2 "F2" }
130 { $ GDK_KEY_F3 "F3" }
131 { $ GDK_KEY_F4 "F4" }
132 { $ GDK_KEY_F5 "F5" }
133 { $ GDK_KEY_F6 "F6" }
134 { $ GDK_KEY_F7 "F7" }
135 { $ GDK_KEY_F8 "F8" }
136 { $ GDK_KEY_F9 "F9" }
137 { $ GDK_KEY_F10 "F10" }
138 { $ GDK_KEY_F11 "F11" }
139 { $ GDK_KEY_F12 "F12" }
142 : event-modifiers ( event -- seq )
143 state>> modifiers modifier ;
145 : event-loc ( event -- loc )
146 [ x>> ] [ y>> ] bi [ >fixnum ] bi@ 2array ;
148 : event-dim ( event -- dim )
149 [ width>> ] [ height>> ] bi 2array ;
151 : scroll-direction ( event -- pair )
153 { $ GDK_SCROLL_UP { 0 -1 } }
154 { $ GDK_SCROLL_DOWN { 0 1 } }
155 { $ GDK_SCROLL_LEFT { -1 0 } }
156 { $ GDK_SCROLL_RIGHT { 1 0 } }
159 : mouse-event>gesture ( event -- modifiers button loc )
160 [ event-modifiers ] [ button>> ] [ event-loc ] tri ;
162 : on-motion ( win event user-data -- ? )
164 [ event-loc ] dip window
165 move-hand fire-motion t ;
167 : on-leave ( win event user-data -- ? )
168 3drop forget-rollover t ;
170 :: on-button-press ( win event user-data -- ? )
172 event mouse-event>gesture :> ( modifiers button loc )
176 [ modifiers swap <button-down> loc world
180 :: on-button-release ( win event user-data -- ? )
182 event mouse-event>gesture :> ( modifiers button loc )
184 { 8 [ world left-action send-action ] }
185 { 9 [ world right-action send-action ] }
186 [ modifiers swap <button-up> loc world
190 : on-scroll ( win event user-data -- ? )
192 [ scroll-direction ] [ event-loc ] bi
193 ] dip window send-scroll t ;
195 : key-sym ( event -- sym/f action? )
196 keyval>> dup action-key-codes at [ t ]
197 [ gdk_keyval_to_unicode [ f ] [ 1string ] if-zero f ] ?if ;
199 : key-event>gesture ( event -- mods sym/f action? )
200 [ event-modifiers ] [ key-sym ] bi ;
202 : on-key-press ( win event user-data -- ? )
203 drop swap [ key-event>gesture <key-down> ] [ window ] bi*
204 propagate-key-gesture t ;
206 : on-key-release ( win event user-data -- ? )
207 drop swap [ key-event>gesture <key-up> ] [ window ] bi*
208 propagate-key-gesture t ;
210 : on-focus-in ( win event user-data -- ? )
211 2drop window focus-world t ;
213 : on-focus-out ( win event user-data -- ? )
214 2drop window unfocus-world t ;
216 :: connect-user-input-signals ( win -- )
217 win events-mask gtk_widget_add_events
218 win "motion-notify-event" [ on-motion yield ]
219 GtkWidget:motion-notify-event connect-signal
220 win "leave-notify-event" [ on-leave yield ]
221 GtkWidget:leave-notify-event connect-signal
222 win "button-press-event" [ on-button-press yield ]
223 GtkWidget:button-press-event connect-signal
224 win "button-release-event" [ on-button-release yield ]
225 GtkWidget:button-release-event connect-signal
226 win "scroll-event" [ on-scroll yield ]
227 GtkWidget:scroll-event connect-signal
228 win "key-press-event" [ on-key-press yield ]
229 GtkWidget:key-press-event connect-signal
230 win "key-release-event" [ on-key-release yield ]
231 GtkWidget:key-release-event connect-signal
232 win "focus-in-event" [ on-focus-in yield ]
233 GtkWidget:focus-in-event connect-signal
234 win "focus-out-event" [ on-focus-out yield ]
235 GtkWidget:focus-out-event connect-signal ;
237 ! Window state events
239 : on-expose ( win event user-data -- ? )
240 2drop window relayout t ;
242 : on-configure ( win event user-data -- ? )
243 drop [ window ] [ GdkEventConfigure memory>struct ] bi*
244 [ event-loc >>window-loc ] [ event-dim >>dim ] bi
247 : on-delete ( win event user-data -- ? )
248 2drop window ungraft t ;
250 :: connect-win-state-signals ( win -- )
251 win "expose-event" [ on-expose yield ]
252 GtkWidget:expose-event connect-signal
253 win "configure-event" [ on-configure yield ]
254 GtkWidget:configure-event connect-signal
255 win "delete-event" [ on-delete yield ]
256 GtkWidget:delete-event connect-signal ;
260 : on-retrieve-surrounding ( im-context win -- ? )
261 window world-focus dup support-input-methods? [
262 cursor-surrounding [ utf8 string>alien -1 ] dip
263 gtk_im_context_set_surrounding t
266 : on-delete-surrounding ( im-context offset n win -- ? )
267 window world-focus dup support-input-methods?
268 [ delete-cursor-surrounding t ] [ 3drop f ] if nip ;
270 : on-commit ( im-context str win -- )
271 [ drop ] [ utf8 alien>string ] [ window ] tri* user-input ;
273 : gadget-cursor-location ( gadget -- rectangle )
274 [ screen-loc ] [ cursor-loc&dim ] bi [ v+ ] dip
275 [ first2 [ >fixnum ] bi@ ] bi@
276 cairo_rectangle_int_t <struct-boa> ;
278 : update-cursor-location ( im-context gadget -- )
279 gadget-cursor-location gtk_im_context_set_cursor_location ;
281 ! has to be called before the window signal handler
282 :: im-on-key-event ( win event im-context -- ? )
283 win window world-focus :> gadget
284 gadget support-input-methods? [
285 im-context gadget update-cursor-location
286 im-context event gtk_im_context_filter_keypress
287 ] [ im-context gtk_im_context_reset f ] if ;
289 : im-on-focus-in ( win event im-context -- ? )
291 [ gtk_im_context_focus_in ] [ gtk_im_context_reset ] bi f ;
293 : im-on-focus-out ( win event im-context -- ? )
295 [ gtk_im_context_focus_out ] [ gtk_im_context_reset ] bi f ;
297 : im-on-destroy ( win im-context -- )
298 nip [ f gtk_im_context_set_client_window ]
299 ! weird GLib-GObject-WARNING message appears after calling this code
300 ! [ g_object_unref ] bi ;
303 :: configure-im ( win im -- )
304 im win gtk_widget_get_window gtk_im_context_set_client_window
305 im f gtk_im_context_set_use_preedit
307 im "commit" [ on-commit yield ]
308 GtkIMContext:commit win connect-signal-with-data
309 im "retrieve-surrounding" [ on-retrieve-surrounding yield ]
310 GtkIMContext:retrieve-surrounding win connect-signal-with-data
311 im "delete-surrounding" [ on-delete-surrounding yield ]
312 GtkIMContext:delete-surrounding win connect-signal-with-data
314 win "key-press-event" [ im-on-key-event yield ]
315 GtkWidget:key-press-event im connect-signal-with-data
316 win "key-release-event" [ im-on-key-event yield ]
317 GtkWidget:key-release-event im connect-signal-with-data
318 win "focus-in-event" [ im-on-focus-in yield ]
319 GtkWidget:focus-out-event im connect-signal-with-data
320 win "focus-out-event" [ im-on-focus-out yield ]
321 GtkWidget:focus-out-event im connect-signal-with-data
322 win "destroy" [ im-on-destroy yield ]
323 GtkObject:destroy im connect-signal-with-data ;
327 CONSTANT: window-controls>decor-flags
330 { minimize-button $ GDK_DECOR_MINIMIZE }
331 { maximize-button $ GDK_DECOR_MAXIMIZE }
332 { resize-handles $ GDK_DECOR_RESIZEH }
333 { small-title-bar $ GDK_DECOR_TITLE }
334 { normal-title-bar $ GDK_DECOR_TITLE }
335 { textured-background 0 }
338 CONSTANT: window-controls>func-flags
340 { close-button $ GDK_FUNC_CLOSE }
341 { minimize-button $ GDK_FUNC_MINIMIZE }
342 { maximize-button $ GDK_FUNC_MAXIMIZE }
343 { resize-handles $ GDK_FUNC_RESIZE }
344 { small-title-bar 0 }
345 { normal-title-bar 0 }
346 { textured-background 0 }
349 : configure-window-controls ( win controls -- )
351 small-title-bar swap member-eq?
352 GDK_WINDOW_TYPE_HINT_UTILITY GDK_WINDOW_TYPE_HINT_NORMAL ?
353 gtk_window_set_type_hint
355 [ gtk_widget_get_window ] dip
356 window-controls>decor-flags symbols>flags
357 GDK_DECOR_BORDER bitor gdk_window_set_decorations
359 [ gtk_widget_get_window ] dip
360 window-controls>func-flags symbols>flags
361 GDK_FUNC_MOVE bitor gdk_window_set_functions
364 ! OpenGL and Pixel formats
366 PIXEL-FORMAT-ATTRIBUTE-TABLE: gl-config-attribs
367 ${ GDK_GL_USE_GL GDK_GL_RGBA }
369 { double-buffered ${ GDK_GL_DOUBLEBUFFER } }
370 { stereo ${ GDK_GL_STEREO } }
371 ! { offscreen ${ GDK_GL_DRAWABLE_TYPE 2 } }
372 ! { fullscreen ${ GDK_GL_DRAWABLE_TYPE 1 } }
373 ! { windowed ${ GDK_GL_DRAWABLE_TYPE 1 } }
374 { color-bits ${ GDK_GL_BUFFER_SIZE } }
375 { red-bits ${ GDK_GL_RED_SIZE } }
376 { green-bits ${ GDK_GL_GREEN_SIZE } }
377 { blue-bits ${ GDK_GL_BLUE_SIZE } }
378 { alpha-bits ${ GDK_GL_ALPHA_SIZE } }
379 { accum-red-bits ${ GDK_GL_ACCUM_RED_SIZE } }
380 { accum-green-bits ${ GDK_GL_ACCUM_GREEN_SIZE } }
381 { accum-blue-bits ${ GDK_GL_ACCUM_BLUE_SIZE } }
382 { accum-alpha-bits ${ GDK_GL_ACCUM_ALPHA_SIZE } }
383 { depth-bits ${ GDK_GL_DEPTH_SIZE } }
384 { stencil-bits ${ GDK_GL_STENCIL_SIZE } }
385 { aux-buffers ${ GDK_GL_AUX_BUFFERS } }
386 { sample-buffers ${ GDK_GL_SAMPLE_BUFFERS } }
387 { samples ${ GDK_GL_SAMPLES } }
390 M: gtk-ui-backend (make-pixel-format)
391 nip >gl-config-attribs-int-array gdk_gl_config_new ;
393 M: gtk-ui-backend (free-pixel-format)
394 handle>> g_object_unref ;
396 M: gtk-ui-backend (pixel-format-attribute)
397 [ handle>> ] [ >gl-config-attribs ] bi*
398 { gint } [ gdk_gl_config_get_attrib drop ]
399 with-out-parameters ;
401 M: window-handle select-gl-context ( handle -- )
403 [ gtk_widget_get_gl_window ] [ gtk_widget_get_gl_context ] bi
404 gdk_gl_drawable_make_current drop ;
406 M: window-handle flush-gl-context ( handle -- )
407 window>> gtk_widget_get_gl_window
408 gdk_gl_drawable_swap_buffers ;
412 : configure-gl ( world -- )
414 [ handle>> window>> ] [ handle>> ] bi*
415 f t GDK_GL_RGBA_TYPE gtk_widget_set_gl_capability drop
416 ] with-world-pixel-format ;
418 : auto-position ( win loc -- )
420 drop dup window topmost-window =
421 GTK_WIN_POS_CENTER GTK_WIN_POS_NONE ?
422 gtk_window_set_position
423 ] [ first2 gtk_window_move ] if ;
425 M:: gtk-ui-backend (open-window) ( world -- )
426 GTK_WINDOW_TOPLEVEL gtk_window_new :> win
427 gtk_im_multicontext_new :> im
429 win im <window-handle> world handle<<
431 world win register-window
433 win world [ window-loc>> auto-position ]
434 [ dim>> first2 gtk_window_set_default_size ] 2bi
436 win "factor" "Factor" [ utf8 string>alien ] bi@
437 gtk_window_set_wmclass
441 win gtk_widget_realize
442 win world window-controls>> configure-window-controls
445 win connect-user-input-signals
446 win connect-win-state-signals
448 win gtk_widget_show_all ;
450 M: gtk-ui-backend (close-window) ( handle -- )
451 window>> [ gtk_widget_destroy ] [ unregister-window ] bi
452 event-loop? [ gtk_main_quit ] unless ;
454 M: gtk-ui-backend set-title
455 swap [ handle>> window>> ] [ utf8 string>alien ] bi*
456 gtk_window_set_title ;
458 M: gtk-ui-backend (set-fullscreen)
459 [ handle>> ] dip [ >>fullscreen? ] keep
461 [ gtk_window_fullscreen ]
462 [ gtk_window_unfullscreen ] if ;
464 M: gtk-ui-backend (fullscreen?)
465 handle>> fullscreen?>> ;
467 M: gtk-ui-backend raise-window*
468 handle>> window>> gtk_window_present ;
470 : set-cursor ( win cursor -- )
472 [ gtk_widget_get_window ] dip
473 gdk_cursor_new &gdk_cursor_unref
474 gdk_window_set_cursor
477 M: gtk-ui-backend (grab-input)
479 [ gtk_grab_add ] [ GDK_BLANK_CURSOR set-cursor ] bi ;
481 M: gtk-ui-backend (ungrab-input)
483 [ gtk_grab_remove ] [ GDK_LEFT_PTR set-cursor ] bi ;
487 M: gtk-ui-backend beep
490 M:: gtk-ui-backend system-alert ( caption text -- )
492 f GTK_DIALOG_MODAL GTK_MESSAGE_WARNING GTK_BUTTONS_OK
493 caption utf8 string>alien f
494 gtk_message_dialog_new >k_widget_destroy
496 text utf8 string>alien f
497 gtk_message_dialog_format_secondary_text
498 ] [ gtk_dialog_run drop ] bi
501 M: gtk-ui-backend (with-ui)
503 0 gint <ref> f void* <ref> gtk_init
504 0 gint <ref> f void* <ref> gtk_gl_init
508 [ [ gtk_main ] with-timer ] with-event-loop
513 gtk-ui-backend ui-backend set-global
515 { "ui.backend.gtk" "io.backend.unix" }
516 "ui.backend.gtk.io.unix" require-when
518 { "ui.backend.gtk" "ui.gadgets.editors" }
519 "ui.backend.gtk.input-methods.editors" require-when
521 [ "DISPLAY" os-env "ui.tools" "listener" ? ] main-vocab-hook set-global