--- /dev/null
+! Copyright (C) 2010 Anton Gorenko.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.enums alien.strings arrays ascii assocs
+classes.struct combinators.short-circuit command-line destructors
+io.encodings.utf8 kernel literals locals math namespaces
+sequences strings ui ui.backend ui.clipboards ui.event-loop
+ui.gadgets ui.gadgets.private ui.gestures ui.private
+glib glib.ffi gobject gobject.ffi gtk gtk.ffi gdk gdk.ffi
+gdk.gl gtk.gl gdk.gl.ffi gtk.gl.ffi ;
+IN: ui.backend.gtk
+
+SINGLETON: gtk-ui-backend
+
+TUPLE: handle ;
+TUPLE: window-handle < handle window fullscreen? ;
+
+: <window-handle> ( window -- window-handle )
+ [ window-handle new ] dip >>window ;
+
+TUPLE: gtk-clipboard handle ;
+
+C: <gtk-clipboard> gtk-clipboard
+
+CONSTANT: events-mask
+ {
+ GDK_POINTER_MOTION_MASK
+ GDK_POINTER_MOTION_HINT_MASK
+ GDK_ENTER_NOTIFY_MASK
+ GDK_LEAVE_NOTIFY_MASK
+ GDK_BUTTON_PRESS_MASK
+ GDK_BUTTON_RELEASE_MASK
+ GDK_KEY_PRESS_MASK
+ GDK_KEY_RELEASE_MASK
+ GDK_FOCUS_CHANGE_MASK
+ }
+
+CONSTANT: modifiers
+ {
+ { S+ $[ GDK_SHIFT_MASK enum>number ] }
+ { C+ $[ GDK_CONTROL_MASK enum>number ] }
+ { A+ $[ GDK_META_MASK enum>number ] }
+ }
+
+CONSTANT: action-key-codes
+ H{
+ ${ GDK_BackSpace "BACKSPACE" }
+ ${ GDK_Tab "TAB" }
+ ${ GDK_Return "RET" }
+ ${ GDK_KP_Enter "ENTER" }
+ ${ GDK_Escape "ESC" }
+ ${ GDK_Delete "DELETE" }
+ ${ GDK_Home "HOME" }
+ ${ GDK_Left "LEFT" }
+ ${ GDK_Up "UP" }
+ ${ GDK_Right "RIGHT" }
+ ${ GDK_Down "DOWN" }
+ ${ GDK_Page_Up "PAGE_UP" }
+ ${ GDK_Page_Down "PAGE_DOWN" }
+ ${ GDK_End "END" }
+ ${ GDK_Begin "BEGIN" }
+ ${ GDK_F1 "F1" }
+ ${ GDK_F2 "F2" }
+ ${ GDK_F3 "F3" }
+ ${ GDK_F4 "F4" }
+ ${ GDK_F5 "F5" }
+ ${ GDK_F6 "F6" }
+ ${ GDK_F7 "F7" }
+ ${ GDK_F8 "F8" }
+ ${ GDK_F9 "F9" }
+ ${ GDK_F10 "F10" }
+ ${ GDK_F11 "F11" }
+ ${ GDK_F12 "F12" }
+ }
+
+: event-modifiers ( event -- seq )
+ state>> modifiers modifier ;
+
+: event-loc ( event -- loc )
+ [ x>> ] [ y>> ] bi [ >fixnum ] bi@ 2array ;
+
+: event-dim ( event -- dim )
+ [ width>> ] [ height>> ] bi 2array ;
+
+: scroll-direction ( event -- pair )
+ direction>> {
+ ${ GDK_SCROLL_UP { 0 -1 } }
+ ${ GDK_SCROLL_DOWN { 0 1 } }
+ ${ GDK_SCROLL_LEFT { -1 0 } }
+ ${ GDK_SCROLL_RIGHT { 1 0 } }
+ } at ;
+
+: mouse-event>gesture ( event -- modifiers button loc )
+ [ event-modifiers ] [ button>> ] [ event-loc ] tri ;
+
+: on-motion ( sender event user-data -- result )
+ drop swap
+ [ GdkEventMotion memory>struct event-loc ] dip window
+ move-hand fire-motion t ;
+
+: on-enter ( sender event user-data -- result )
+ on-motion ;
+
+: on-leave ( sender event user-data -- result )
+ 3drop forget-rollover t ;
+
+: on-button-press ( sender event user-data -- result )
+ drop swap [
+ GdkEventButton memory>struct
+ mouse-event>gesture [ <button-down> ] dip
+ ] dip window send-button-down t ;
+
+: on-button-release ( sender event user-data -- result )
+ drop swap [
+ GdkEventButton memory>struct
+ mouse-event>gesture [ <button-up> ] dip
+ ] dip window send-button-up t ;
+
+: on-scroll ( sender event user-data -- result )
+ drop swap [
+ GdkEventScroll memory>struct
+ [ scroll-direction ] [ event-loc ] bi
+ ] dip window send-scroll t ;
+
+: key-sym ( event -- sym action? )
+ keyval>> dup action-key-codes at
+ [ t ] [ gdk_keyval_to_unicode 1string f ] ?if ;
+
+: key-event>gesture ( event -- modifiers sym action? )
+ [ event-modifiers ] [ key-sym ] bi ;
+
+: valid-input? ( string gesture -- ? )
+ over empty? [ 2drop f ] [
+ mods>> { f { S+ } } member? [
+ [ { [ 127 = not ] [ CHAR: \s >= ] } 1&& ] all?
+ ] [
+ [ { [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] } 1&& ] all?
+ ] if
+ ] if ;
+
+:: on-key-press ( sender event user-data -- result )
+ sender window :> world
+ event GdkEventKey memory>struct :> ev
+ ev key-event>gesture <key-down> :> gesture
+ gesture world propagate-key-gesture
+ ev keyval>> gdk_keyval_to_unicode 1string dup
+ gesture valid-input?
+ [ world user-input ] [ drop ] if
+ t ;
+
+: on-key-release ( sender event user-data -- result )
+ drop swap [
+ GdkEventKey memory>struct
+ key-event>gesture <key-up>
+ ] dip window propagate-key-gesture t ;
+
+: on-focus-in ( sender event user-data -- result )
+ 2drop window focus-world t ;
+
+: on-focus-out ( sender event user-data -- result )
+ 2drop window unfocus-world t ;
+
+: on-expose ( sender event user-data -- result )
+ 2drop window relayout t ;
+
+: on-configure ( sender event user-data -- result )
+ drop [ window ] dip GdkEventConfigure memory>struct
+ [ event-loc >>window-loc ] [ event-dim >>dim ] bi
+ relayout-1 t ;
+
+: on-delete ( sender event user-data -- result )
+ 2drop window ungraft t ;
+
+: init-clipboard ( -- )
+ selection "PRIMARY"
+ clipboard "CLIPBOARD"
+ [
+ utf8 string>alien gdk_atom_intern_static_string
+ gtk_clipboard_get <gtk-clipboard> swap set-global
+ ] 2bi@ ;
+
+M: gtk-ui-backend do-events
+ f gtk_main_iteration_do drop ui-wait ;
+
+M: gtk-ui-backend (with-ui)
+ [
+ f f gtk_init
+ f f gtk_gl_init
+ init-clipboard
+ start-ui
+ event-loop
+ ] ui-running ;
+
+: connect-signal ( object signal-name callback -- )
+ [ utf8 string>alien ] dip f f 0 g_signal_connect_data drop ;
+
+:: connect-signals ( win -- )
+ win events-mask [ enum>number ] [ bitor ] map-reduce
+ gtk_widget_add_events
+
+ win "expose-event" [ on-expose ]
+ GtkWidget:expose-event connect-signal
+ win "configure-event" [ on-configure ]
+ GtkWidget:configure-event connect-signal
+ win "motion-notify-event" [ on-motion ]
+ GtkWidget:motion-notify-event connect-signal
+ win "leave-notify-event" [ on-leave ]
+ GtkWidget:leave-notify-event connect-signal
+ win "enter-notify-event" [ on-enter ]
+ GtkWidget:enter-notify-event connect-signal
+ win "button-press-event" [ on-button-press ]
+ GtkWidget:button-press-event connect-signal
+ win "button-release-event" [ on-button-release ]
+ GtkWidget:button-release-event connect-signal
+ win "scroll-event" [ on-scroll ]
+ GtkWidget:scroll-event connect-signal
+ win "key-press-event" [ on-key-press ]
+ GtkWidget:key-press-event connect-signal
+ win "key-release-event" [ on-key-release ]
+ GtkWidget:key-release-event connect-signal
+ win "focus-in-event" [ on-focus-in ]
+ GtkWidget:focus-in-event connect-signal
+ win "focus-out-event" [ on-focus-out ]
+ GtkWidget:focus-out-event connect-signal
+ win "delete-event" [ on-delete ]
+ GtkWidget:delete-event connect-signal ;
+
+: enable-gl ( win -- ? )
+ ${
+ GDK_GL_MODE_RGBA
+ GDK_GL_MODE_DOUBLE
+ GDK_GL_MODE_DEPTH
+ GDK_GL_MODE_STENCIL
+ GDK_GL_MODE_ALPHA
+ } [ enum>number ] [ bitor ] map-reduce
+ gdk_gl_config_new_by_mode
+ f t GDK_GL_RGBA_TYPE enum>number gtk_widget_set_gl_capability ;
+
+M:: gtk-ui-backend (open-window) ( world -- )
+ GTK_WINDOW_TOPLEVEL gtk_window_new :> win
+ world [ window-loc>> win swap first2 gtk_window_move ]
+ [ dim>> win swap first2 gtk_window_set_default_size ] bi
+
+ win enable-gl drop ! сделать проверку на доступность OpenGL
+
+ win connect-signals
+
+ win <window-handle> world handle<<
+ world win register-window
+
+ win gtk_widget_show_all ;
+
+M: gtk-ui-backend (close-window) ( handle -- )
+ window>> [ unregister-window ] [ gtk_widget_destroy ] bi ;
+
+M: gtk-ui-backend set-title
+ swap [ handle>> window>> ] [ utf8 string>alien ] bi*
+ gtk_window_set_title ;
+
+M: gtk-ui-backend (set-fullscreen)
+ [ handle>> ] dip [ >>fullscreen? ] keep
+ [ window>> ] dip
+ [ gtk_window_fullscreen ]
+ [ gtk_window_unfullscreen ] if ;
+
+M: gtk-ui-backend (fullscreen?)
+ handle>> fullscreen?>> ;
+
+M: gtk-ui-backend raise-window*
+ handle>> window>> gtk_window_present ;
+
+: set-cursor ( win cursor -- )
+ [
+ [ gtk_widget_get_window ] dip
+ gdk_cursor_new &gdk_cursor_unref
+ gdk_window_set_cursor
+ ] with-destructors ;
+
+M: gtk-ui-backend (grab-input)
+ handle>> window>>
+ [ gtk_grab_add ] [ GDK_BLANK_CURSOR set-cursor ] bi ;
+
+M: gtk-ui-backend (ungrab-input)
+ handle>> window>>
+ [ gtk_grab_remove ] [ GDK_ARROW set-cursor ] bi ;
+
+M: window-handle select-gl-context ( handle -- )
+ window>>
+ [ gtk_widget_get_gl_window ] [ gtk_widget_get_gl_context ] bi
+ gdk_gl_drawable_make_current drop ;
+
+M: window-handle flush-gl-context ( handle -- )
+ window>> gtk_widget_get_gl_window
+ gdk_gl_drawable_swap_buffers ;
+
+M: gtk-ui-backend beep
+ gdk_beep ;
+
+M:: gtk-ui-backend system-alert ( caption text -- )
+ f GTK_DIALOG_MODAL GTK_MESSAGE_WARNING GTK_BUTTONS_OK
+ caption utf8 string>alien f gtk_message_dialog_new
+ [ text utf8 string>alien f gtk_message_dialog_format_secondary_text ]
+ [ gtk_dialog_run drop ]
+ [ gtk_widget_destroy ] tri ;
+
+M: gtk-clipboard clipboard-contents
+ handle>> gtk_clipboard_wait_for_text utf8 alien>string ;
+
+M: gtk-clipboard set-clipboard-contents
+ swap [ handle>> ] [ utf8 string>alien ] bi*
+ -1 gtk_clipboard_set_text ;
+
+gtk-ui-backend ui-backend set-global
+
+[ "ui.tools" ] main-vocab-hook set-global
+
projects / factor.git / commitdiff