Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
b8ce02bea3
|
|
@ -1,14 +1,13 @@
|
|||
! Copyright (C) 2005, 2009 Eduardo Cavazos and Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.c-types arrays ui ui.private ui.gadgets
|
||||
ui.gadgets.private ui.gestures ui.backend ui.clipboards
|
||||
ui.gadgets.worlds ui.render ui.event-loop assocs kernel math
|
||||
namespaces opengl sequences strings x11 x11.xlib x11.events x11.xim
|
||||
x11.glx x11.clipboard x11.constants x11.windows x11.io
|
||||
io.encodings.string io.encodings.ascii io.encodings.utf8 combinators
|
||||
command-line math.vectors classes.tuple opengl.gl threads
|
||||
math.rectangles environment ascii literals
|
||||
ui.pixel-formats ui.pixel-formats.private ;
|
||||
USING: accessors alien.c-types arrays ascii assocs
|
||||
classes.struct combinators io.encodings.ascii
|
||||
io.encodings.string io.encodings.utf8 kernel literals math
|
||||
namespaces sequences strings ui ui.backend ui.clipboards
|
||||
ui.event-loop ui.gadgets ui.gadgets.private ui.gadgets.worlds
|
||||
ui.gestures ui.pixel-formats ui.pixel-formats.private
|
||||
ui.private x11 x11.clipboard x11.constants x11.events x11.glx
|
||||
x11.io x11.windows x11.xim x11.xlib environment command-line ;
|
||||
IN: ui.backend.x11
|
||||
|
||||
SINGLETON: x11-ui-backend
|
||||
|
|
@ -25,8 +24,7 @@ C: <x11-pixmap-handle> x11-pixmap-handle
|
|||
M: world expose-event nip relayout ;
|
||||
|
||||
M: world configure-event
|
||||
over configured-loc >>window-loc
|
||||
swap configured-dim >>dim
|
||||
swap [ event-loc >>window-loc ] [ event-dim >>dim ] bi
|
||||
! In case dimensions didn't change
|
||||
relayout-1 ;
|
||||
|
||||
|
|
@ -103,7 +101,7 @@ CONSTANT: key-codes
|
|||
dup key-codes at [ t ] [ 1string f ] ?if ;
|
||||
|
||||
: event-modifiers ( event -- seq )
|
||||
XKeyEvent-state modifiers modifier ;
|
||||
state>> modifiers modifier ;
|
||||
|
||||
: valid-input? ( string gesture -- ? )
|
||||
over empty? [ 2drop f ] [
|
||||
|
|
@ -132,10 +130,7 @@ M: world key-up-event
|
|||
[ key-up-event>gesture ] dip propagate-key-gesture ;
|
||||
|
||||
: mouse-event>gesture ( event -- modifiers button loc )
|
||||
[ event-modifiers ]
|
||||
[ XButtonEvent-button ]
|
||||
[ mouse-event-loc ]
|
||||
tri ;
|
||||
[ event-modifiers ] [ button>> ] [ event-loc ] tri ;
|
||||
|
||||
M: world button-down-event
|
||||
[ mouse-event>gesture [ <button-down> ] dip ] dip
|
||||
|
|
@ -146,7 +141,7 @@ M: world button-up-event
|
|||
send-button-up ;
|
||||
|
||||
: mouse-event>scroll-direction ( event -- pair )
|
||||
XButtonEvent-button {
|
||||
button>> {
|
||||
{ 4 { 0 -1 } }
|
||||
{ 5 { 0 1 } }
|
||||
{ 6 { -1 0 } }
|
||||
|
|
@ -154,7 +149,7 @@ M: world button-up-event
|
|||
} at ;
|
||||
|
||||
M: world wheel-event
|
||||
[ [ mouse-event>scroll-direction ] [ mouse-event-loc ] bi ] dip
|
||||
[ [ mouse-event>scroll-direction ] [ event-loc ] bi ] dip
|
||||
send-wheel ;
|
||||
|
||||
M: world enter-event motion-event ;
|
||||
|
|
@ -162,16 +157,13 @@ M: world enter-event motion-event ;
|
|||
M: world leave-event 2drop forget-rollover ;
|
||||
|
||||
M: world motion-event
|
||||
[ [ XMotionEvent-x ] [ XMotionEvent-y ] bi 2array ] dip
|
||||
move-hand fire-motion ;
|
||||
[ event-loc ] dip move-hand fire-motion ;
|
||||
|
||||
M: world focus-in-event
|
||||
nip
|
||||
[ handle>> xic>> XSetICFocus ] [ focus-world ] bi ;
|
||||
nip [ handle>> xic>> XSetICFocus ] [ focus-world ] bi ;
|
||||
|
||||
M: world focus-out-event
|
||||
nip
|
||||
[ handle>> xic>> XUnsetICFocus ] [ unfocus-world ] bi ;
|
||||
nip [ handle>> xic>> XUnsetICFocus ] [ unfocus-world ] bi ;
|
||||
|
||||
M: world selection-notify-event
|
||||
[ handle>> window>> selection-from-event ] keep
|
||||
|
|
@ -189,22 +181,18 @@ M: world selection-notify-event
|
|||
} case ;
|
||||
|
||||
: encode-clipboard ( string type -- bytes )
|
||||
XSelectionRequestEvent-target
|
||||
XA_UTF8_STRING = utf8 ascii ? encode ;
|
||||
target>> XA_UTF8_STRING = utf8 ascii ? encode ;
|
||||
|
||||
: set-selection-prop ( evt -- )
|
||||
dpy get swap
|
||||
[ XSelectionRequestEvent-requestor ] keep
|
||||
[ XSelectionRequestEvent-property ] keep
|
||||
[ XSelectionRequestEvent-target ] keep
|
||||
[ 8 PropModeReplace ] dip
|
||||
[
|
||||
XSelectionRequestEvent-selection
|
||||
clipboard-for-atom contents>>
|
||||
] keep encode-clipboard dup length XChangeProperty drop ;
|
||||
[ requestor>> ] keep
|
||||
[ property>> ] keep
|
||||
[ target>> 8 PropModeReplace ] keep
|
||||
[ selection>> clipboard-for-atom contents>> ] keep
|
||||
encode-clipboard dup length XChangeProperty drop ;
|
||||
|
||||
M: world selection-request-event
|
||||
drop dup XSelectionRequestEvent-target {
|
||||
drop dup target>> {
|
||||
{ [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
|
||||
{ [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
|
||||
{ [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
|
||||
|
|
@ -235,7 +223,7 @@ M: world client-event
|
|||
] [ wait-for-display wait-event ] if ;
|
||||
|
||||
M: x11-ui-backend do-events
|
||||
wait-event dup XAnyEvent-window window dup
|
||||
wait-event dup window>> window dup
|
||||
[ handle-event ] [ 2drop ] if ;
|
||||
|
||||
: x-clipboard@ ( gadget clipboard -- prop win )
|
||||
|
|
@ -269,17 +257,13 @@ M: x11-ui-backend set-title ( string world -- )
|
|||
[ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
|
||||
|
||||
M: x11-ui-backend (set-fullscreen) ( world ? -- )
|
||||
[
|
||||
handle>> window>> "XClientMessageEvent" <c-object>
|
||||
[ set-XClientMessageEvent-window ] keep
|
||||
] dip
|
||||
_NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
|
||||
over set-XClientMessageEvent-data0
|
||||
ClientMessage over set-XClientMessageEvent-type
|
||||
dpy get over set-XClientMessageEvent-display
|
||||
"_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type
|
||||
32 over set-XClientMessageEvent-format
|
||||
"_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1
|
||||
XClientMessageEvent <struct>
|
||||
swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0
|
||||
swap handle>> window>> >>window
|
||||
dpy get >>display
|
||||
"_NET_WM_STATE" x-atom >>message_type
|
||||
32 >>format
|
||||
"_NET_WM_STATE_FULLSCREEN" x-atom >>data1
|
||||
[ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ;
|
||||
|
||||
M: x11-ui-backend (open-window) ( world -- )
|
||||
|
|
@ -312,9 +296,9 @@ M: x11-pixmap-handle flush-gl-context ( handle -- )
|
|||
drop ;
|
||||
|
||||
M: x11-ui-backend (open-offscreen-buffer) ( world -- )
|
||||
dup [ [ dim>> ] [ handle>> ] bi* glx-pixmap ]
|
||||
with-world-pixel-format
|
||||
dup [ [ dim>> ] [ handle>> ] bi* glx-pixmap ] with-world-pixel-format
|
||||
<x11-pixmap-handle> >>handle drop ;
|
||||
|
||||
M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
|
||||
dpy get swap
|
||||
[ glx-pixmap>> glXDestroyGLXPixmap ]
|
||||
|
|
|
|||
|
|
@ -1,9 +1,8 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.strings alien.syntax arrays
|
||||
kernel math namespaces sequences io.encodings.string
|
||||
io.encodings.utf8 io.encodings.ascii x11 x11.xlib x11.constants
|
||||
specialized-arrays.int accessors ;
|
||||
USING: accessors alien.c-types alien.strings classes.struct
|
||||
io.encodings.utf8 kernel namespaces sequences
|
||||
specialized-arrays.int x11 x11.constants x11.xlib ;
|
||||
IN: x11.clipboard
|
||||
|
||||
! This code was based on by McCLIM's Backends/CLX/port.lisp
|
||||
|
|
@ -34,20 +33,15 @@ TUPLE: x-clipboard atom contents ;
|
|||
[ XGetWindowProperty drop ] keep snarf-property ;
|
||||
|
||||
: selection-from-event ( event window -- string )
|
||||
swap XSelectionEvent-property zero? [
|
||||
drop f
|
||||
] [
|
||||
selection-property 1 window-property
|
||||
] if ;
|
||||
swap property>> 0 =
|
||||
[ drop f ] [ selection-property 1 window-property ] if ;
|
||||
|
||||
: own-selection ( prop win -- )
|
||||
[ dpy get ] 2dip CurrentTime XSetSelectionOwner drop
|
||||
flush-dpy ;
|
||||
|
||||
: set-targets-prop ( evt -- )
|
||||
dpy get swap
|
||||
[ XSelectionRequestEvent-requestor ] keep
|
||||
XSelectionRequestEvent-property
|
||||
[ dpy get ] dip [ requestor>> ] [ property>> ] bi
|
||||
"TARGETS" x-atom 32 PropModeReplace
|
||||
{
|
||||
"UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP"
|
||||
|
|
@ -55,28 +49,27 @@ TUPLE: x-clipboard atom contents ;
|
|||
4 XChangeProperty drop ;
|
||||
|
||||
: set-timestamp-prop ( evt -- )
|
||||
dpy get swap
|
||||
[ XSelectionRequestEvent-requestor ] keep
|
||||
[ XSelectionRequestEvent-property ] keep
|
||||
[ "TIMESTAMP" x-atom 32 PropModeReplace ] dip
|
||||
XSelectionRequestEvent-time <int>
|
||||
[ dpy get ] dip
|
||||
[ requestor>> ]
|
||||
[ property>> "TIMESTAMP" x-atom 32 PropModeReplace ]
|
||||
[ time>> <int> ] tri
|
||||
1 XChangeProperty drop ;
|
||||
|
||||
: send-notify ( evt prop -- )
|
||||
"XSelectionEvent" <c-object>
|
||||
SelectionNotify over set-XSelectionEvent-type
|
||||
[ set-XSelectionEvent-property ] keep
|
||||
over XSelectionRequestEvent-display over set-XSelectionEvent-display
|
||||
over XSelectionRequestEvent-requestor over set-XSelectionEvent-requestor
|
||||
over XSelectionRequestEvent-selection over set-XSelectionEvent-selection
|
||||
over XSelectionRequestEvent-target over set-XSelectionEvent-target
|
||||
over XSelectionRequestEvent-time over set-XSelectionEvent-time
|
||||
[ dpy get swap XSelectionRequestEvent-requestor 0 0 ] dip
|
||||
XSelectionEvent <struct>
|
||||
SelectionNotify >>type
|
||||
swap >>property
|
||||
over display>> >>display
|
||||
over requestor>> >>requestor
|
||||
over selection>> >>selection
|
||||
over target>> >>target
|
||||
over time>> >>time
|
||||
[ [ dpy get ] dip requestor>> 0 0 ] dip
|
||||
XSendEvent drop
|
||||
flush-dpy ;
|
||||
|
||||
: send-notify-success ( evt -- )
|
||||
dup XSelectionRequestEvent-property send-notify ;
|
||||
dup property>> send-notify ;
|
||||
|
||||
: send-notify-failure ( evt -- )
|
||||
0 send-notify ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays hashtables io kernel math
|
||||
math.order namespaces prettyprint sequences strings combinators
|
||||
x11 x11.xlib ;
|
||||
USING: accessors arrays classes.struct combinators kernel
|
||||
math.order namespaces x11 x11.xlib ;
|
||||
IN: x11.events
|
||||
|
||||
GENERIC: expose-event ( event window -- )
|
||||
|
|
@ -36,14 +35,14 @@ GENERIC: selection-request-event ( event window -- )
|
|||
GENERIC: client-event ( event window -- )
|
||||
|
||||
: next-event ( -- event )
|
||||
dpy get "XEvent" <c-object> [ XNextEvent drop ] keep ;
|
||||
dpy get XEvent <struct> [ XNextEvent drop ] keep ;
|
||||
|
||||
: mask-event ( mask -- event )
|
||||
[ dpy get ] dip "XEvent" <c-object> [ XMaskEvent drop ] keep ;
|
||||
[ dpy get ] dip XEvent <struct> [ XMaskEvent drop ] keep ;
|
||||
|
||||
: events-queued ( mode -- n ) [ dpy get ] dip XEventsQueued ;
|
||||
|
||||
: wheel? ( event -- ? ) XButtonEvent-button 4 7 between? ;
|
||||
: wheel? ( event -- ? ) button>> 4 7 between? ;
|
||||
|
||||
: button-down-event$ ( event window -- )
|
||||
over wheel? [ wheel-event ] [ button-down-event ] if ;
|
||||
|
|
@ -52,34 +51,31 @@ GENERIC: client-event ( event window -- )
|
|||
over wheel? [ 2drop ] [ button-up-event ] if ;
|
||||
|
||||
: handle-event ( event window -- )
|
||||
over XAnyEvent-type {
|
||||
{ Expose [ expose-event ] }
|
||||
{ ConfigureNotify [ configure-event ] }
|
||||
{ ButtonPress [ button-down-event$ ] }
|
||||
{ ButtonRelease [ button-up-event$ ] }
|
||||
{ EnterNotify [ enter-event ] }
|
||||
{ LeaveNotify [ leave-event ] }
|
||||
{ MotionNotify [ motion-event ] }
|
||||
{ KeyPress [ key-down-event ] }
|
||||
{ KeyRelease [ key-up-event ] }
|
||||
{ FocusIn [ focus-in-event ] }
|
||||
{ FocusOut [ focus-out-event ] }
|
||||
{ SelectionNotify [ selection-notify-event ] }
|
||||
{ SelectionRequest [ selection-request-event ] }
|
||||
{ ClientMessage [ client-event ] }
|
||||
over type>> {
|
||||
{ Expose [ XExposeEvent>> expose-event ] }
|
||||
{ ConfigureNotify [ XConfigureEvent>> configure-event ] }
|
||||
{ ButtonPress [ XButtonEvent>> button-down-event$ ] }
|
||||
{ ButtonRelease [ XButtonEvent>> button-up-event$ ] }
|
||||
{ EnterNotify [ XCrossingEvent>> enter-event ] }
|
||||
{ LeaveNotify [ XCrossingEvent>> leave-event ] }
|
||||
{ MotionNotify [ XMotionEvent>> motion-event ] }
|
||||
{ KeyPress [ XKeyEvent>> key-down-event ] }
|
||||
{ KeyRelease [ XKeyEvent>> key-up-event ] }
|
||||
{ FocusIn [ XFocusChangeEvent>> focus-in-event ] }
|
||||
{ FocusOut [ XFocusChangeEvent>> focus-out-event ] }
|
||||
{ SelectionNotify [ XSelectionEvent>> selection-notify-event ] }
|
||||
{ SelectionRequest [ XSelectionRequestEvent>> selection-request-event ] }
|
||||
{ ClientMessage [ XClientMessageEvent>> client-event ] }
|
||||
[ 3drop ]
|
||||
} case ;
|
||||
|
||||
: configured-loc ( event -- dim )
|
||||
[ XConfigureEvent-x ] [ XConfigureEvent-y ] bi 2array ;
|
||||
: event-loc ( event -- loc )
|
||||
[ x>> ] [ y>> ] bi 2array ;
|
||||
|
||||
: configured-dim ( event -- dim )
|
||||
[ XConfigureEvent-width ] [ XConfigureEvent-height ] bi 2array ;
|
||||
|
||||
: mouse-event-loc ( event -- loc )
|
||||
[ XButtonEvent-x ] [ XButtonEvent-y ] bi 2array ;
|
||||
: event-dim ( event -- dim )
|
||||
[ width>> ] [ height>> ] bi 2array ;
|
||||
|
||||
: close-box? ( event -- ? )
|
||||
[ XClientMessageEvent-message_type "WM_PROTOCOLS" x-atom = ]
|
||||
[ XClientMessageEvent-data0 "WM_DELETE_WINDOW" x-atom = ]
|
||||
[ message_type>> "WM_PROTOCOLS" x-atom = ]
|
||||
[ data0>> "WM_DELETE_WINDOW" x-atom = ]
|
||||
bi and ;
|
||||
|
|
|
|||
|
|
@ -1,15 +1,15 @@
|
|||
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types hashtables kernel math math.vectors
|
||||
math.bitwise namespaces sequences x11 x11.xlib x11.constants x11.glx
|
||||
arrays fry ;
|
||||
USING: accessors kernel math math.bitwise math.vectors
|
||||
namespaces sequences x11 x11.xlib x11.constants x11.glx arrays
|
||||
fry classes.struct ;
|
||||
IN: x11.windows
|
||||
|
||||
: create-window-mask ( -- n )
|
||||
{ CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ;
|
||||
|
||||
: create-colormap ( visinfo -- colormap )
|
||||
[ dpy get root get ] dip XVisualInfo-visual AllocNone
|
||||
[ dpy get root get ] dip visual>> AllocNone
|
||||
XCreateColormap ;
|
||||
|
||||
: event-mask ( -- n )
|
||||
|
|
@ -28,15 +28,15 @@ IN: x11.windows
|
|||
} flags ;
|
||||
|
||||
: window-attributes ( visinfo -- attributes )
|
||||
"XSetWindowAttributes" <c-object>
|
||||
0 over set-XSetWindowAttributes-background_pixel
|
||||
0 over set-XSetWindowAttributes-border_pixel
|
||||
[ [ create-colormap ] dip set-XSetWindowAttributes-colormap ] keep
|
||||
event-mask over set-XSetWindowAttributes-event_mask ;
|
||||
XSetWindowAttributes <struct>
|
||||
0 >>background_pixel
|
||||
0 >>border_pixel
|
||||
event-mask >>event_mask
|
||||
swap create-colormap >>colormap ;
|
||||
|
||||
: set-size-hints ( window -- )
|
||||
"XSizeHints" <c-object>
|
||||
USPosition over set-XSizeHints-flags
|
||||
XSizeHints <struct>
|
||||
USPosition >>flags
|
||||
[ dpy get ] 2dip XSetWMNormalHints ;
|
||||
|
||||
: auto-position ( window loc -- )
|
||||
|
|
@ -47,8 +47,8 @@ IN: x11.windows
|
|||
: create-window ( loc dim visinfo -- window )
|
||||
pick [
|
||||
[ [ [ dpy get root get ] dip >xy ] dip { 1 1 } vmax >xy 0 ] dip
|
||||
[ XVisualInfo-depth InputOutput ] keep
|
||||
[ XVisualInfo-visual create-window-mask ] keep
|
||||
[ depth>> InputOutput ] keep
|
||||
[ visual>> create-window-mask ] keep
|
||||
window-attributes XCreateWindow
|
||||
dup
|
||||
] dip auto-position ;
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue