528 lines
16 KiB
Factor
528 lines
16 KiB
Factor
! Copyright (C) 2010, 2011 Anton Gorenko, Philipp Bruschweiler.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors alien.accessors alien.c-types alien.strings arrays
|
|
assocs classes.struct combinators continuations destructors
|
|
environment gdk.ffi gdk.gl.ffi gdk.pixbuf.ffi glib.ffi gobject.ffi
|
|
gtk.ffi gtk.gl.ffi io.encodings.binary io.encodings.utf8 io.files
|
|
io.pathnames kernel libc literals locals math math.bitwise
|
|
math.vectors namespaces sequences strings system threads ui ui.backend
|
|
ui.backend.gtk.input-methods ui.backend.gtk.io ui.backend.x11.keys
|
|
ui.clipboards ui.event-loop ui.gadgets ui.gadgets.private
|
|
ui.gadgets.worlds ui.gestures ui.pixel-formats
|
|
ui.pixel-formats.private ui.private vocabs.loader ;
|
|
IN: ui.backend.gtk
|
|
|
|
SINGLETON: gtk-ui-backend
|
|
|
|
TUPLE: window-handle window drawable im-context fullscreen? ;
|
|
|
|
: <window-handle> ( window drawable im-context -- window-handle )
|
|
f window-handle boa ;
|
|
|
|
: connect-signal-with-data ( object signal-name callback data -- )
|
|
[ utf8 string>alien ] 2dip g_signal_connect drop ;
|
|
|
|
: connect-signal ( object signal-name callback -- )
|
|
f connect-signal-with-data ;
|
|
|
|
! Clipboards
|
|
|
|
TUPLE: gtk-clipboard handle ;
|
|
|
|
C: <gtk-clipboard> gtk-clipboard
|
|
|
|
M: gtk-clipboard clipboard-contents
|
|
[
|
|
handle>> gtk_clipboard_wait_for_text
|
|
[ &g_free utf8 alien>string ] [ f ] if*
|
|
] with-destructors ;
|
|
|
|
: save-global-clipboard ( -- )
|
|
clipboard get-global handle>> gtk_clipboard_store ;
|
|
|
|
M: gtk-clipboard set-clipboard-contents
|
|
swap [ handle>> ] [ utf8 string>alien ] bi*
|
|
-1 gtk_clipboard_set_text
|
|
save-global-clipboard ;
|
|
|
|
: init-clipboard ( -- )
|
|
selection "PRIMARY"
|
|
clipboard "CLIPBOARD"
|
|
[
|
|
utf8 string>alien gdk_atom_intern_static_string
|
|
gtk_clipboard_get <gtk-clipboard> swap set-global
|
|
] 2bi@ ;
|
|
|
|
! Timer
|
|
|
|
: set-timeout*-value ( alien value -- )
|
|
swap 0 set-alien-signed-4 ; inline
|
|
|
|
: timer-prepare ( source timeout* -- ? )
|
|
nip sleep-time 1,000,000,000 or
|
|
[ 1,000,000 /i set-timeout*-value ] keep 0 = ;
|
|
|
|
: timer-check ( source -- ? )
|
|
drop sleep-time 0 = ;
|
|
|
|
: timer-dispatch ( source callback user_data -- ? )
|
|
3drop yield t ;
|
|
|
|
: <timer-funcs> ( -- timer-funcs )
|
|
GSourceFuncs malloc-struct
|
|
[ timer-prepare ] GSourceFuncsPrepareFunc >>prepare
|
|
[ timer-check ] GSourceFuncsCheckFunc >>check
|
|
[ timer-dispatch ] GSourceFuncsDispatchFunc >>dispatch ;
|
|
|
|
:: with-timer ( quot -- )
|
|
<timer-funcs> &free
|
|
GSource heap-size g_source_new &g_source_unref :> source
|
|
source f g_source_attach drop
|
|
[ quot call( -- ) ]
|
|
[ source g_source_destroy ] [ ] cleanup ;
|
|
|
|
! User input
|
|
|
|
CONSTANT: events-mask
|
|
flags{
|
|
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
|
|
}
|
|
|
|
: 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 ;
|
|
|
|
: on-motion ( win event user-data -- ? )
|
|
drop swap
|
|
[ event-loc ] dip window
|
|
move-hand fire-motion t ;
|
|
|
|
: on-leave ( win event user-data -- ? )
|
|
3drop forget-rollover t ;
|
|
|
|
:: on-button-press ( win event user-data -- ? )
|
|
win window :> world
|
|
event type>> GDK_BUTTON_PRESS = [
|
|
event button>> {
|
|
{ 8 [ ] }
|
|
{ 9 [ ] }
|
|
[
|
|
event event-modifiers swap <button-down>
|
|
event event-loc
|
|
world
|
|
send-button-down
|
|
]
|
|
} case
|
|
] when t ;
|
|
|
|
:: on-button-release ( win event user-data -- ? )
|
|
win window :> world
|
|
event type>> GDK_BUTTON_RELEASE = [
|
|
event button>> {
|
|
{ 8 [ world left-action send-action ] }
|
|
{ 9 [ world right-action send-action ] }
|
|
[
|
|
event event-modifiers swap <button-up>
|
|
event event-loc
|
|
world
|
|
send-button-up
|
|
]
|
|
} case
|
|
] when t ;
|
|
|
|
: on-scroll ( win event user-data -- ? )
|
|
drop swap [
|
|
[ scroll-direction ] [ event-loc ] bi
|
|
] dip window send-scroll t ;
|
|
|
|
: key-sym ( keyval -- string/f action? )
|
|
code>sym [ dup integer? [ gdk_keyval_to_unicode 1string ] when ] dip ;
|
|
|
|
: key-event>gesture ( event -- key-gesture )
|
|
[ event-modifiers ] [ keyval>> key-sym ] [
|
|
type>> GDK_KEY_PRESS = [ <key-down> ] [ <key-up> ] if
|
|
] tri ;
|
|
|
|
: on-key-press/release ( win event user-data -- ? )
|
|
drop swap [ key-event>gesture ] [ window ] bi* propagate-key-gesture t ;
|
|
|
|
: on-focus-in ( win event user-data -- ? )
|
|
2drop window focus-world t ;
|
|
|
|
: on-focus-out ( win event user-data -- ? )
|
|
2drop window unfocus-world t ;
|
|
|
|
CONSTANT: default-icon-path "resource:misc/icons/Factor_128x128.png"
|
|
|
|
: default-icon-data ( -- byte-array/f )
|
|
[
|
|
default-icon-path binary file-contents
|
|
] [ drop f ] recover ;
|
|
|
|
SYMBOL: icon-data
|
|
|
|
icon-data [ default-icon-data ] initialize
|
|
|
|
: vocab-icon-data ( vocab-name -- byte-array )
|
|
dup vocab-dir { "icon.png" "icon.ico" } [
|
|
append-path vocab-append-path
|
|
] 2with map default-icon-path suffix
|
|
[ exists? ] find nip binary file-contents ;
|
|
|
|
: load-icon ( -- )
|
|
icon-data get [
|
|
[
|
|
data>GInputStream &g_object_unref
|
|
GInputStream>GdkPixbuf gtk_window_set_default_icon
|
|
] with-destructors
|
|
] when* ;
|
|
|
|
:: connect-user-input-signals ( win -- )
|
|
win "motion-notify-event" [ on-motion yield ]
|
|
GtkWidget:motion-notify-event connect-signal
|
|
win "leave-notify-event" [ on-leave yield ]
|
|
GtkWidget:leave-notify-event connect-signal
|
|
win "button-press-event" [ on-button-press yield ]
|
|
GtkWidget:button-press-event connect-signal
|
|
win "button-release-event" [ on-button-release yield ]
|
|
GtkWidget:button-release-event connect-signal
|
|
win "scroll-event" [ on-scroll yield ]
|
|
GtkWidget:scroll-event connect-signal
|
|
win "key-press-event" [ on-key-press/release yield ]
|
|
GtkWidget:key-press-event connect-signal
|
|
win "key-release-event" [ on-key-press/release yield ]
|
|
GtkWidget:key-release-event connect-signal
|
|
win "focus-in-event" [ on-focus-in yield ]
|
|
GtkWidget:focus-in-event connect-signal
|
|
win "focus-out-event" [ on-focus-out yield ]
|
|
GtkWidget:focus-out-event connect-signal ;
|
|
|
|
! Window state events
|
|
|
|
: on-expose ( win event user-data -- ? )
|
|
2drop gtk_widget_get_toplevel window relayout t ;
|
|
|
|
: on-configure ( window event user-data -- ? )
|
|
drop swap dup gtk_widget_get_toplevel [ = ] keep window dup active?>> [
|
|
swap [ swap GdkEventConfigure memory>struct ] dip
|
|
[ event-loc >>window-loc drop ]
|
|
[ event-dim >>dim relayout-1 ] if
|
|
] [ 3drop ] if f ;
|
|
|
|
: on-map ( win event user-data -- ? )
|
|
2drop window t >>active? drop t ;
|
|
|
|
: on-delete ( win event user-data -- ? )
|
|
2drop window ungraft t ;
|
|
|
|
: connect-configure-signal ( winhandle -- )
|
|
[ window>> ] [ drawable>> ] bi "configure-event"
|
|
[ on-configure yield ] GtkWidget:configure-event
|
|
[ connect-signal ] 2curry bi@ ;
|
|
|
|
: connect-expose-sigal ( drawable -- )
|
|
"expose-event" [ on-expose yield ]
|
|
GtkWidget:expose-event connect-signal ;
|
|
|
|
:: connect-win-state-signals ( win -- )
|
|
win "delete-event" [ on-delete yield ]
|
|
GtkWidget:delete-event connect-signal
|
|
win "map-event" [ on-map yield ]
|
|
GtkWidget:map-event connect-signal ;
|
|
|
|
! Input methods
|
|
|
|
: on-retrieve-surrounding ( im-context win -- ? )
|
|
window world-focus dup support-input-methods? [
|
|
cursor-surrounding [ utf8 string>alien -1 ] dip
|
|
gtk_im_context_set_surrounding t
|
|
] [ 2drop f ] if ;
|
|
|
|
: on-delete-surrounding ( im-context offset n win -- ? )
|
|
window world-focus dup support-input-methods?
|
|
[ delete-cursor-surrounding t ] [ 3drop f ] if nip ;
|
|
|
|
: on-commit ( im-context str win -- )
|
|
[ drop ] [ utf8 alien>string ] [ window ] tri* user-input ;
|
|
|
|
: gadget-cursor-location ( gadget -- rectangle )
|
|
[ screen-loc ] [ cursor-loc&dim ] bi [ v+ ] dip
|
|
[ first2 [ >fixnum ] bi@ ] bi@
|
|
cairo_rectangle_int_t <struct-boa> ;
|
|
|
|
: update-cursor-location ( im-context gadget -- )
|
|
gadget-cursor-location gtk_im_context_set_cursor_location ;
|
|
|
|
! has to be called before the window signal handler
|
|
:: im-on-key-event ( win event im-context -- ? )
|
|
win window world-focus :> gadget
|
|
gadget support-input-methods? [
|
|
im-context gadget update-cursor-location
|
|
im-context event gtk_im_context_filter_keypress
|
|
] [ im-context gtk_im_context_reset f ] if ;
|
|
|
|
: im-on-focus-in ( win event im-context -- ? )
|
|
2nip
|
|
[ gtk_im_context_focus_in ] [ gtk_im_context_reset ] bi f ;
|
|
|
|
: im-on-focus-out ( win event im-context -- ? )
|
|
2nip
|
|
[ gtk_im_context_focus_out ] [ gtk_im_context_reset ] bi f ;
|
|
|
|
: im-on-destroy ( win im-context -- )
|
|
nip [ f gtk_im_context_set_client_window ]
|
|
! weird GLib-GObject-WARNING message appears after calling this code
|
|
! [ g_object_unref ] bi ;
|
|
[ drop ] bi ;
|
|
|
|
:: configure-im ( win im -- )
|
|
im win gtk_widget_get_window gtk_im_context_set_client_window
|
|
im f gtk_im_context_set_use_preedit
|
|
|
|
im "commit" [ on-commit yield ]
|
|
GtkIMContext:commit win connect-signal-with-data
|
|
im "retrieve-surrounding" [ on-retrieve-surrounding yield ]
|
|
GtkIMContext:retrieve-surrounding win connect-signal-with-data
|
|
im "delete-surrounding" [ on-delete-surrounding yield ]
|
|
GtkIMContext:delete-surrounding win connect-signal-with-data
|
|
|
|
win "key-press-event" [ im-on-key-event yield ]
|
|
GtkWidget:key-press-event im connect-signal-with-data
|
|
win "key-release-event" [ im-on-key-event yield ]
|
|
GtkWidget:key-release-event im connect-signal-with-data
|
|
win "focus-in-event" [ im-on-focus-in yield ]
|
|
GtkWidget:focus-out-event im connect-signal-with-data
|
|
win "focus-out-event" [ im-on-focus-out yield ]
|
|
GtkWidget:focus-out-event im connect-signal-with-data
|
|
win "destroy" [ im-on-destroy yield ]
|
|
GtkObject:destroy im connect-signal-with-data ;
|
|
|
|
! Window controls
|
|
|
|
CONSTANT: window-controls>decor-flags
|
|
H{
|
|
{ close-button 0 }
|
|
{ minimize-button $ GDK_DECOR_MINIMIZE }
|
|
{ maximize-button $ GDK_DECOR_MAXIMIZE }
|
|
{ resize-handles $ GDK_DECOR_RESIZEH }
|
|
{ small-title-bar $ GDK_DECOR_TITLE }
|
|
{ normal-title-bar $ GDK_DECOR_TITLE }
|
|
{ textured-background 0 }
|
|
{ dialog-window 0 }
|
|
}
|
|
|
|
CONSTANT: window-controls>func-flags
|
|
H{
|
|
{ close-button $ GDK_FUNC_CLOSE }
|
|
{ minimize-button $ GDK_FUNC_MINIMIZE }
|
|
{ maximize-button $ GDK_FUNC_MAXIMIZE }
|
|
{ resize-handles $ GDK_FUNC_RESIZE }
|
|
{ small-title-bar 0 }
|
|
{ normal-title-bar 0 }
|
|
{ textured-background 0 }
|
|
{ dialog-window 0 }
|
|
}
|
|
|
|
: set-window-hint ( win controls -- )
|
|
{
|
|
{ [ dialog-window over member-eq? ] [ drop GDK_WINDOW_TYPE_HINT_DIALOG ] }
|
|
{ [ small-title-bar over member-eq? ] [ drop GDK_WINDOW_TYPE_HINT_UTILITY ] }
|
|
[ drop GDK_WINDOW_TYPE_HINT_NORMAL ]
|
|
} cond gtk_window_set_type_hint ;
|
|
|
|
: configure-window-controls ( win controls -- )
|
|
[
|
|
set-window-hint
|
|
] [
|
|
[ gtk_widget_get_window ] dip
|
|
window-controls>decor-flags symbols>flags
|
|
GDK_DECOR_BORDER bitor gdk_window_set_decorations
|
|
] [
|
|
[ gtk_widget_get_window ] dip
|
|
window-controls>func-flags symbols>flags
|
|
GDK_FUNC_MOVE bitor gdk_window_set_functions
|
|
] 2tri ;
|
|
|
|
! OpenGL and Pixel formats
|
|
|
|
PIXEL-FORMAT-ATTRIBUTE-TABLE: gl-config-attribs
|
|
${ GDK_GL_USE_GL GDK_GL_RGBA }
|
|
H{
|
|
{ double-buffered ${ GDK_GL_DOUBLEBUFFER } }
|
|
{ stereo ${ GDK_GL_STEREO } }
|
|
! { offscreen ${ GDK_GL_DRAWABLE_TYPE 2 } }
|
|
! { fullscreen ${ GDK_GL_DRAWABLE_TYPE 1 } }
|
|
! { windowed ${ GDK_GL_DRAWABLE_TYPE 1 } }
|
|
{ color-bits ${ GDK_GL_BUFFER_SIZE } }
|
|
{ red-bits ${ GDK_GL_RED_SIZE } }
|
|
{ green-bits ${ GDK_GL_GREEN_SIZE } }
|
|
{ blue-bits ${ GDK_GL_BLUE_SIZE } }
|
|
{ alpha-bits ${ GDK_GL_ALPHA_SIZE } }
|
|
{ accum-red-bits ${ GDK_GL_ACCUM_RED_SIZE } }
|
|
{ accum-green-bits ${ GDK_GL_ACCUM_GREEN_SIZE } }
|
|
{ accum-blue-bits ${ GDK_GL_ACCUM_BLUE_SIZE } }
|
|
{ accum-alpha-bits ${ GDK_GL_ACCUM_ALPHA_SIZE } }
|
|
{ depth-bits ${ GDK_GL_DEPTH_SIZE } }
|
|
{ stencil-bits ${ GDK_GL_STENCIL_SIZE } }
|
|
{ aux-buffers ${ GDK_GL_AUX_BUFFERS } }
|
|
{ sample-buffers ${ GDK_GL_SAMPLE_BUFFERS } }
|
|
{ samples ${ GDK_GL_SAMPLES } }
|
|
}
|
|
|
|
M: gtk-ui-backend (make-pixel-format)
|
|
nip >gl-config-attribs-int-array gdk_gl_config_new ;
|
|
|
|
M: gtk-ui-backend (free-pixel-format)
|
|
handle>> g_object_unref ;
|
|
|
|
M: window-handle select-gl-context ( handle -- )
|
|
drawable>>
|
|
[ gtk_widget_get_gl_window ] [ gtk_widget_get_gl_context ] bi
|
|
gdk_gl_drawable_make_current drop ;
|
|
|
|
M: window-handle flush-gl-context ( handle -- )
|
|
drawable>> gtk_widget_get_gl_window
|
|
gdk_gl_drawable_swap_buffers ;
|
|
|
|
! Window
|
|
|
|
: configure-gl ( world -- )
|
|
[
|
|
[ handle>> drawable>> ] [ handle>> ] bi*
|
|
f t GDK_GL_RGBA_TYPE gtk_widget_set_gl_capability drop
|
|
] with-world-pixel-format ;
|
|
|
|
: auto-position ( win loc -- )
|
|
dup { 0 0 } = [
|
|
drop dup window topmost-window =
|
|
GTK_WIN_POS_CENTER GTK_WIN_POS_NONE ?
|
|
gtk_window_set_position
|
|
] [ first2 gtk_window_move ] if ;
|
|
|
|
M:: gtk-ui-backend (open-window) ( world -- )
|
|
GTK_WINDOW_TOPLEVEL gtk_window_new :> win
|
|
gtk_drawing_area_new :> drawable
|
|
win drawable gtk_container_add
|
|
gtk_im_multicontext_new :> im
|
|
|
|
win drawable im <window-handle> world handle<<
|
|
|
|
world win register-window
|
|
|
|
win world [ window-loc>> auto-position ]
|
|
[ dim>> first2 gtk_window_set_default_size ] 2bi
|
|
|
|
win "factor" "Factor" [ utf8 string>alien ] bi@
|
|
gtk_window_set_wmclass
|
|
|
|
world configure-gl
|
|
|
|
! This must be done before realize due to #776.
|
|
win events-mask gtk_widget_add_events
|
|
|
|
win gtk_widget_realize
|
|
|
|
! And this must be done after and in this order due to #1307
|
|
win im configure-im
|
|
win connect-user-input-signals
|
|
win connect-win-state-signals
|
|
world handle>> connect-configure-signal
|
|
drawable connect-expose-sigal
|
|
|
|
win world window-controls>> configure-window-controls
|
|
win gtk_widget_show_all ;
|
|
|
|
M: gtk-ui-backend (close-window) ( handle -- )
|
|
window>> [ gtk_widget_destroy ] [ unregister-window ] bi
|
|
event-loop? [ gtk_main_quit ] unless ;
|
|
|
|
M: gtk-ui-backend resize-window
|
|
[ handle>> window>> ] [ first2 ] bi* gtk_window_resize ;
|
|
|
|
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)
|
|
window>>
|
|
[ gtk_grab_add ] [ GDK_BLANK_CURSOR set-cursor ] bi ;
|
|
|
|
M: gtk-ui-backend (ungrab-input)
|
|
window>>
|
|
[ gtk_grab_remove ] [ GDK_LEFT_PTR set-cursor ] bi ;
|
|
|
|
! Misc.
|
|
|
|
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 >k_widget_destroy
|
|
[
|
|
text utf8 string>alien f
|
|
gtk_message_dialog_format_secondary_text
|
|
] [ gtk_dialog_run drop ] bi
|
|
] with-destructors ;
|
|
|
|
M: gtk-ui-backend (with-ui)
|
|
[
|
|
f f gtk_init
|
|
f f gtk_gl_init
|
|
load-icon
|
|
init-clipboard
|
|
start-ui
|
|
[
|
|
[ [ gtk_main ] with-timer ] with-event-loop
|
|
] with-destructors
|
|
] ui-running ;
|
|
|
|
os linux? [
|
|
gtk-ui-backend ui-backend set-global
|
|
] when
|
|
|
|
{ "ui.backend.gtk" "ui.gadgets.editors" }
|
|
"ui.backend.gtk.input-methods.editors" require-when
|
|
|
|
M: gtk-ui-backend ui-backend-available?
|
|
"DISPLAY" os-env >boolean ;
|