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.strings arrays
4 assocs classes.struct combinators continuations destructors
5 environment gdk.ffi gdk.gl.ffi gdk.pixbuf.ffi glib.ffi gobject.ffi
6 gtk.ffi gtk.gl.ffi io.encodings.binary io.encodings.utf8 io.files
7 io.pathnames kernel libc literals locals math math.bitwise
8 math.vectors namespaces sequences strings system threads ui ui.backend
9 ui.backend.gtk.input-methods ui.backend.gtk.io ui.backend.x11.keys
10 ui.clipboards ui.event-loop ui.gadgets ui.gadgets.private
11 ui.gadgets.worlds ui.gestures ui.pixel-formats
12 ui.private vocabs.loader ;
15 SINGLETON: gtk-ui-backend
17 TUPLE: window-handle window drawable im-context fullscreen? ;
19 : <window-handle> ( window drawable im-context -- window-handle )
22 : connect-signal-with-data ( object signal-name callback data -- )
23 [ utf8 string>alien ] 2dip g_signal_connect drop ;
25 : connect-signal ( object signal-name callback -- )
26 f connect-signal-with-data ;
30 TUPLE: gtk-clipboard handle ;
32 C: <gtk-clipboard> gtk-clipboard
34 M: gtk-clipboard clipboard-contents
36 handle>> gtk_clipboard_wait_for_text
37 [ &g_free utf8 alien>string ] [ f ] if*
40 : save-global-clipboard ( -- )
41 clipboard get-global handle>> gtk_clipboard_store ;
43 M: gtk-clipboard set-clipboard-contents
44 swap [ handle>> ] [ [ 0 = ] trim-tail utf8 string>alien ] bi*
45 -1 gtk_clipboard_set_text
46 save-global-clipboard ;
48 : init-clipboard ( -- )
52 utf8 string>alien gdk_atom_intern_static_string
53 gtk_clipboard_get <gtk-clipboard> swap set-global
58 : set-timeout*-value ( alien value -- )
59 swap 0 set-alien-signed-4 ; inline
61 : timer-prepare ( source timeout* -- ? )
62 nip sleep-time 1,000,000,000 or
63 [ 1,000,000 /i set-timeout*-value ] keep 0 = ;
65 : timer-check ( source -- ? )
68 : timer-dispatch ( source callback user_data -- ? )
71 : <timer-funcs> ( -- timer-funcs )
72 GSourceFuncs malloc-struct
73 [ timer-prepare ] GSourceFuncsPrepareFunc >>prepare
74 [ timer-check ] GSourceFuncsCheckFunc >>check
75 [ timer-dispatch ] GSourceFuncsDispatchFunc >>dispatch ;
77 :: with-timer ( quot -- )
79 GSource heap-size g_source_new &g_source_unref :> source
80 source G_PRIORITY_DEFAULT_IDLE g_source_set_priority
81 source f g_source_attach drop
83 [ source g_source_destroy ] finally ;
89 GDK_POINTER_MOTION_MASK
90 GDK_POINTER_MOTION_HINT_MASK
94 GDK_BUTTON_RELEASE_MASK
100 : event-loc ( event -- loc )
101 [ x>> ] [ y>> ] bi [ >fixnum ] bi@ 2array ;
103 : event-dim ( event -- dim )
104 [ width>> ] [ height>> ] bi 2array ;
106 : scroll-direction ( event -- pair )
108 { $ GDK_SCROLL_UP { 0 -1 } }
109 { $ GDK_SCROLL_DOWN { 0 1 } }
110 { $ GDK_SCROLL_LEFT { -1 0 } }
111 { $ GDK_SCROLL_RIGHT { 1 0 } }
114 : on-motion ( win event user-data -- ? )
116 [ event-loc ] dip window
117 move-hand fire-motion t ;
119 : on-leave ( win event user-data -- ? )
120 3drop forget-rollover t ;
122 :: on-button-press ( win event user-data -- ? )
124 event type>> GDK_BUTTON_PRESS = [
129 event event-modifiers swap <button-down>
137 :: on-button-release ( win event user-data -- ? )
139 event type>> GDK_BUTTON_RELEASE = [
141 { 8 [ world left-action send-action ] }
142 { 9 [ world right-action send-action ] }
144 event event-modifiers swap <button-up>
152 : on-scroll ( win event user-data -- ? )
154 [ scroll-direction ] [ event-loc ] bi
155 ] dip window send-scroll t ;
157 : key-sym ( keyval -- string/f action? )
158 code>sym [ dup integer? [ gdk_keyval_to_unicode 1string ] when ] dip ;
160 : key-event>gesture ( event -- key-gesture )
161 [ event-modifiers ] [ keyval>> key-sym ] [
162 type>> GDK_KEY_PRESS = [ <key-down> ] [ <key-up> ] if
165 : on-key-press/release ( win event user-data -- ? )
166 drop swap [ key-event>gesture ] [ window ] bi* propagate-key-gesture f ;
168 : on-focus-in ( win event user-data -- ? )
169 2drop window focus-world f ;
171 : on-focus-out ( win event user-data -- ? )
172 2drop window unfocus-world f ;
174 CONSTANT: default-icon-path "resource:misc/icons/Factor_128x128.png"
176 : default-icon-data ( -- byte-array/f )
178 default-icon-path binary file-contents
179 ] [ drop f ] recover ;
183 icon-data [ default-icon-data ] initialize
185 : vocab-icon-data ( vocab-name -- byte-array )
186 dup vocab-dir { "icon.png" "icon.ico" } [
187 append-path vocab-append-path
188 ] 2with map default-icon-path suffix
189 [ file-exists? ] find nip binary file-contents ;
194 data>GInputStream &g_object_unref
195 GInputStream>GdkPixbuf gtk_window_set_default_icon
199 :: connect-user-input-signals ( win -- )
200 win "motion-notify-event" [ on-motion yield ]
201 GtkWidget:motion-notify-event connect-signal
202 win "leave-notify-event" [ on-leave yield ]
203 GtkWidget:leave-notify-event connect-signal
204 win "button-press-event" [ on-button-press yield ]
205 GtkWidget:button-press-event connect-signal
206 win "button-release-event" [ on-button-release yield ]
207 GtkWidget:button-release-event connect-signal
208 win "scroll-event" [ on-scroll yield ]
209 GtkWidget:scroll-event connect-signal
210 win "key-press-event" [ on-key-press/release yield ]
211 GtkWidget:key-press-event connect-signal
212 win "key-release-event" [ on-key-press/release yield ]
213 GtkWidget:key-release-event connect-signal
214 win "focus-in-event" [ on-focus-in yield ]
215 GtkWidget:focus-in-event connect-signal
216 win "focus-out-event" [ on-focus-out yield ]
217 GtkWidget:focus-out-event connect-signal ;
219 ! Window state events
221 : on-expose ( win event user-data -- ? )
222 2drop gtk_widget_get_toplevel window relayout t ;
224 : on-configure ( window event user-data -- ? )
225 drop swap dup gtk_widget_get_toplevel [ = ] keep window dup active?>> [
226 swap [ swap GdkEventConfigure memory>struct ] dip
227 [ event-loc >>window-loc drop ]
228 [ event-dim >>dim relayout-1 ] if
231 : on-map ( win event user-data -- ? )
232 2drop window t >>active? drop t ;
234 : on-delete ( win event user-data -- ? )
235 2drop window ungraft t ;
237 : connect-configure-signal ( winhandle -- )
238 [ window>> ] [ drawable>> ] bi "configure-event"
239 [ on-configure yield ] GtkWidget:configure-event
240 [ connect-signal ] 2curry bi@ ;
242 : connect-expose-sigal ( drawable -- )
243 "expose-event" [ on-expose yield ]
244 GtkWidget:expose-event connect-signal ;
246 :: connect-win-state-signals ( win -- )
247 win "delete-event" [ on-delete yield ]
248 GtkWidget:delete-event connect-signal
249 win "map-event" [ on-map yield ]
250 GtkWidget:map-event connect-signal ;
254 : on-retrieve-surrounding ( im-context win -- ? )
255 window world-focus dup support-input-methods? [
256 cursor-surrounding [ utf8 string>alien -1 ] dip
257 gtk_im_context_set_surrounding t
260 : on-delete-surrounding ( im-context offset n win -- ? )
261 window world-focus dup support-input-methods?
262 [ delete-cursor-surrounding t ] [ 3drop f ] if nip ;
264 : on-commit ( im-context str win -- )
265 [ drop ] [ utf8 alien>string ] [ window ] tri* user-input ;
267 : gadget-cursor-location ( gadget -- rectangle )
268 [ screen-loc ] [ cursor-loc&dim ] bi [ v+ ] dip
269 [ first2 [ >fixnum ] bi@ ] bi@
270 cairo_rectangle_int_t boa ;
272 : update-cursor-location ( im-context gadget -- )
273 gadget-cursor-location gtk_im_context_set_cursor_location ;
275 ! has to be called before the window signal handler
276 :: im-on-key-event ( win event im-context -- ? )
277 win window world-focus :> gadget
278 gadget support-input-methods? [
279 im-context gadget update-cursor-location
280 im-context event gtk_im_context_filter_keypress
281 ] [ im-context gtk_im_context_reset f ] if ;
283 : im-on-focus-in ( win event im-context -- ? )
285 [ gtk_im_context_focus_in ] [ gtk_im_context_reset ] bi f ;
287 : im-on-focus-out ( win event im-context -- ? )
289 [ gtk_im_context_focus_out ] [ gtk_im_context_reset ] bi f ;
291 : im-on-destroy ( win im-context -- )
292 nip [ f gtk_im_context_set_client_window ]
293 ! weird GLib-GObject-WARNING message appears after calling this code
294 ! [ g_object_unref ] bi ;
297 :: configure-im ( win im -- )
298 im win gtk_widget_get_window gtk_im_context_set_client_window
299 im f gtk_im_context_set_use_preedit
301 im "commit" [ on-commit yield ]
302 GtkIMContext:commit win connect-signal-with-data
303 im "retrieve-surrounding" [ on-retrieve-surrounding yield ]
304 GtkIMContext:retrieve-surrounding win connect-signal-with-data
305 im "delete-surrounding" [ on-delete-surrounding yield ]
306 GtkIMContext:delete-surrounding win connect-signal-with-data
308 win "key-press-event" [ im-on-key-event yield ]
309 GtkWidget:key-press-event im connect-signal-with-data
310 win "key-release-event" [ im-on-key-event yield ]
311 GtkWidget:key-release-event im connect-signal-with-data
312 win "focus-in-event" [ im-on-focus-in yield ]
313 GtkWidget:focus-out-event im connect-signal-with-data
314 win "focus-out-event" [ im-on-focus-out yield ]
315 GtkWidget:focus-out-event im connect-signal-with-data
316 win "destroy" [ im-on-destroy yield ]
317 GtkObject:destroy im connect-signal-with-data ;
321 CONSTANT: window-controls>decor-flags
324 { minimize-button $ GDK_DECOR_MINIMIZE }
325 { maximize-button $ GDK_DECOR_MAXIMIZE }
326 { resize-handles $ GDK_DECOR_RESIZEH }
327 { small-title-bar $ GDK_DECOR_TITLE }
328 { normal-title-bar $ GDK_DECOR_TITLE }
329 { textured-background 0 }
333 CONSTANT: window-controls>func-flags
335 { close-button $ GDK_FUNC_CLOSE }
336 { minimize-button $ GDK_FUNC_MINIMIZE }
337 { maximize-button $ GDK_FUNC_MAXIMIZE }
338 { resize-handles $ GDK_FUNC_RESIZE }
339 { small-title-bar 0 }
340 { normal-title-bar 0 }
341 { textured-background 0 }
345 : set-window-hint ( win controls -- )
347 { [ dialog-window over member-eq? ] [ drop GDK_WINDOW_TYPE_HINT_DIALOG ] }
348 { [ small-title-bar over member-eq? ] [ drop GDK_WINDOW_TYPE_HINT_UTILITY ] }
349 [ drop GDK_WINDOW_TYPE_HINT_NORMAL ]
350 } cond gtk_window_set_type_hint ;
352 : configure-window-controls ( win controls -- )
356 [ gtk_widget_get_window ] dip
357 window-controls>decor-flags symbols>flags
358 GDK_DECOR_BORDER bitor gdk_window_set_decorations
360 [ gtk_widget_get_window ] dip
361 window-controls>func-flags symbols>flags
362 GDK_FUNC_MOVE bitor gdk_window_set_functions
365 ! OpenGL and Pixel formats
366 CONSTANT: perm-attribs ${ GDK_GL_USE_GL GDK_GL_RGBA }
368 CONSTANT: attrib-table H{
369 { double-buffered ${ GDK_GL_DOUBLEBUFFER } }
370 { stereo ${ GDK_GL_STEREO } }
371 { color-bits ${ GDK_GL_BUFFER_SIZE } }
372 { red-bits ${ GDK_GL_RED_SIZE } }
373 { green-bits ${ GDK_GL_GREEN_SIZE } }
374 { blue-bits ${ GDK_GL_BLUE_SIZE } }
375 { alpha-bits ${ GDK_GL_ALPHA_SIZE } }
376 { accum-red-bits ${ GDK_GL_ACCUM_RED_SIZE } }
377 { accum-green-bits ${ GDK_GL_ACCUM_GREEN_SIZE } }
378 { accum-blue-bits ${ GDK_GL_ACCUM_BLUE_SIZE } }
379 { accum-alpha-bits ${ GDK_GL_ACCUM_ALPHA_SIZE } }
380 { depth-bits ${ GDK_GL_DEPTH_SIZE } }
381 { stencil-bits ${ GDK_GL_STENCIL_SIZE } }
382 { aux-buffers ${ GDK_GL_AUX_BUFFERS } }
383 { sample-buffers ${ GDK_GL_SAMPLE_BUFFERS } }
384 { samples ${ GDK_GL_SAMPLES } }
387 M: gtk-ui-backend (make-pixel-format)
388 nip perm-attribs attrib-table
389 pixel-format-attributes>int-array gdk_gl_config_new ;
391 M: gtk-ui-backend (free-pixel-format)
392 handle>> g_object_unref ;
394 M: window-handle select-gl-context
396 [ gtk_widget_get_gl_window ] [ gtk_widget_get_gl_context ] bi
397 gdk_gl_drawable_make_current drop ;
399 M: window-handle flush-gl-context
400 drawable>> gtk_widget_get_gl_window
401 gdk_gl_drawable_swap_buffers ;
405 : configure-gl ( world -- )
407 [ handle>> drawable>> ] [ handle>> ] bi*
408 f t GDK_GL_RGBA_TYPE gtk_widget_set_gl_capability drop
409 ] with-world-pixel-format ;
411 : auto-position ( win loc -- )
413 drop dup window topmost-window =
414 GTK_WIN_POS_CENTER GTK_WIN_POS_NONE ?
415 gtk_window_set_position
416 ] [ first2 gtk_window_move ] if ;
418 M:: gtk-ui-backend (open-window) ( world -- )
419 GTK_WINDOW_TOPLEVEL gtk_window_new :> win
420 gtk_drawing_area_new :> drawable
421 win drawable gtk_container_add
422 gtk_im_multicontext_new :> im
424 win drawable im <window-handle> world handle<<
426 world win register-window
428 win world [ window-loc>> auto-position ]
429 [ dim>> first2 gtk_window_set_default_size ] 2bi
431 win "factor" "Factor" [ utf8 string>alien ] bi@
432 gtk_window_set_wmclass
436 ! This must be done before realize due to #776.
437 win events-mask gtk_widget_add_events
439 win gtk_widget_realize
441 ! And this must be done after and in this order due to #1307
442 win connect-user-input-signals
443 win connect-win-state-signals
445 world handle>> connect-configure-signal
446 drawable connect-expose-sigal
448 win world window-controls>> configure-window-controls
449 win gtk_widget_show_all ;
451 M: gtk-ui-backend (close-window)
452 window>> [ gtk_widget_destroy ] [ unregister-window ] bi
453 event-loop? [ gtk_main_quit ] unless ;
455 M: gtk-ui-backend resize-window
456 [ handle>> window>> ] [ first2 ] bi* gtk_window_resize ;
458 M: gtk-ui-backend set-title
459 swap [ handle>> window>> ] [ utf8 string>alien ] bi*
460 gtk_window_set_title ;
462 M: gtk-ui-backend (set-fullscreen)
463 [ handle>> ] dip [ >>fullscreen? ] keep
465 [ gtk_window_fullscreen ]
466 [ gtk_window_unfullscreen ] if ;
468 M: gtk-ui-backend (fullscreen?)
469 handle>> fullscreen?>> ;
471 M: gtk-ui-backend raise-window*
472 handle>> window>> gtk_window_present ;
474 : set-cursor ( win cursor -- )
476 [ gtk_widget_get_window ] dip
477 gdk_cursor_new &gdk_cursor_unref
478 gdk_window_set_cursor
481 M: gtk-ui-backend (grab-input)
483 [ gtk_grab_add ] [ GDK_BLANK_CURSOR set-cursor ] bi ;
485 M: gtk-ui-backend (ungrab-input)
487 [ gtk_grab_remove ] [ GDK_LEFT_PTR set-cursor ] bi ;
491 M: gtk-ui-backend beep
494 M:: gtk-ui-backend system-alert ( caption text -- )
496 f GTK_DIALOG_MODAL GTK_MESSAGE_WARNING GTK_BUTTONS_OK
497 caption utf8 string>alien f
498 gtk_message_dialog_new >k_widget_destroy
500 text utf8 string>alien f
501 gtk_message_dialog_format_secondary_text
502 ] [ gtk_dialog_run drop ] bi
505 M: gtk-ui-backend (with-ui)
506 f f gtk_init_check [ "Unable to initialize GTK" throw ] unless
512 [ [ gtk_main ] with-timer ] with-event-loop
515 M: gtk-ui-backend stop-event-loop
518 os { linux freebsd } member? [
519 gtk-ui-backend ui-backend set-global
522 { "ui.backend.gtk" "ui.gadgets.editors" }
523 "ui.backend.gtk.input-methods.editors" require-when
525 M: gtk-ui-backend ui-backend-available?
526 "DISPLAY" os-env >boolean ;