212 lines
5.6 KiB
Factor
212 lines
5.6 KiB
Factor
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
IN: x11
|
|
USING: arrays errors freetype gadgets gadgets-listener
|
|
gadgets-workspace hashtables kernel kernel-internals math
|
|
namespaces opengl sequences strings ;
|
|
|
|
! In the X11 backend, world-handle is a pair { window context }.
|
|
! The window is an X11 window ID, and the context is a
|
|
! GLX context pointer.
|
|
|
|
M: world expose-event nip relayout ;
|
|
|
|
: configured-loc ( event -- dim )
|
|
dup XConfigureEvent-x swap XConfigureEvent-y 2array ;
|
|
|
|
: configured-dim ( event -- dim )
|
|
dup XConfigureEvent-width swap XConfigureEvent-height 2array ;
|
|
|
|
M: world configure-event
|
|
over configured-loc over set-world-loc
|
|
swap configured-dim swap set-gadget-dim ;
|
|
|
|
: modifiers
|
|
{
|
|
{ S+ HEX: 1 }
|
|
{ C+ HEX: 4 }
|
|
{ A+ HEX: 8 }
|
|
} ;
|
|
|
|
: key-codes
|
|
H{
|
|
{ HEX: FF08 "BACKSPACE" }
|
|
{ HEX: FF09 "TAB" }
|
|
{ HEX: FF0D "RETURN" }
|
|
{ HEX: FF8D "ENTER" }
|
|
{ HEX: FF1B "ESCAPE" }
|
|
{ HEX: FFFF "DELETE" }
|
|
{ HEX: FF50 "HOME" }
|
|
{ HEX: FF51 "LEFT" }
|
|
{ HEX: FF52 "UP" }
|
|
{ HEX: FF53 "RIGHT" }
|
|
{ HEX: FF54 "DOWN" }
|
|
{ HEX: FF55 "PAGE_UP" }
|
|
{ HEX: FF56 "PAGE_DOWN" }
|
|
{ HEX: FF57 "END" }
|
|
{ HEX: FF58 "BEGIN" }
|
|
{ HEX: FFBE "F1" }
|
|
{ HEX: FFBF "F2" }
|
|
{ HEX: FFC0 "F3" }
|
|
{ HEX: FFC1 "F4" }
|
|
{ HEX: FFC2 "F5" }
|
|
{ HEX: FFC3 "F6" }
|
|
{ HEX: FFC4 "F7" }
|
|
{ HEX: FFC5 "F8" }
|
|
{ HEX: FFC6 "F9" }
|
|
} ;
|
|
|
|
: ignored-key? ( keycode -- ? )
|
|
{
|
|
HEX: FFE1 HEX: FFE2 HEX: FFE3 HEX: FFE4 HEX: FFE5
|
|
HEX: FFE6 HEX: FFE7 HEX: FFE8 HEX: FFE9 HEX: FFEA
|
|
HEX: FFEB HEX: FFEC HEX: FFED HEX: FFEE
|
|
} member? ;
|
|
|
|
: key-code ( event -- keycode )
|
|
lookup-string drop dup ignored-key? [
|
|
drop f
|
|
] [
|
|
dup key-codes hash [ ] [ ch>string ] ?if
|
|
] if ;
|
|
|
|
: event-modifiers XKeyEvent-state modifiers modifier ;
|
|
|
|
: key-event>gesture ( event -- modifiers gesture )
|
|
dup event-modifiers swap key-code ;
|
|
|
|
: key-down-event>gesture ( event -- gesture )
|
|
key-event>gesture [ <key-down> ] [ drop f ] if* ;
|
|
|
|
M: world key-down-event
|
|
world-focus over key-down-event>gesture [
|
|
over handle-gesture
|
|
[ swap lookup-string nip swap user-input ] [ 2drop ] if
|
|
] [
|
|
2drop
|
|
] if* ;
|
|
|
|
M: world key-up-event
|
|
world-focus swap key-event>gesture dup [
|
|
<key-up> dup [ swap handle-gesture drop ] [ 2drop ] if
|
|
] [
|
|
3drop
|
|
] if ;
|
|
|
|
: mouse-event-loc ( event -- loc )
|
|
dup XButtonEvent-x swap XButtonEvent-y 2array ;
|
|
|
|
: mouse-event>gesture ( event -- modifiers button loc )
|
|
dup event-modifiers over XButtonEvent-button
|
|
rot mouse-event-loc ;
|
|
|
|
M: world button-down-event
|
|
>r mouse-event>gesture >r <button-down> r> r>
|
|
send-button-down ;
|
|
|
|
M: world button-up-event
|
|
>r mouse-event>gesture >r <button-up> r> r>
|
|
send-button-up ;
|
|
|
|
: mouse-event>scroll-direction ( event -- pair )
|
|
XButtonEvent-button 4 = 1 -1 ? 0 swap 2array ;
|
|
|
|
M: world wheel-event
|
|
>r dup mouse-event>scroll-direction swap mouse-event-loc r>
|
|
send-wheel ;
|
|
|
|
M: world enter-event motion-event ;
|
|
|
|
M: world leave-event 2drop forget-rollover ;
|
|
|
|
M: world motion-event
|
|
>r dup XMotionEvent-x swap XMotionEvent-y 2array r>
|
|
move-hand fire-motion ;
|
|
|
|
M: world focus-in-event nip focus-world ;
|
|
|
|
M: world focus-out-event nip unfocus-world ;
|
|
|
|
M: world selection-notify-event
|
|
[ world-handle first selection-from-event ] keep
|
|
world-focus user-input ;
|
|
|
|
: supported-type? ( atom -- ? )
|
|
{ "STRING" "UTF8_STRING" "TEXT" }
|
|
[ x-atom = ] contains-with? ;
|
|
|
|
M: world selection-request-event
|
|
drop dup XSelectionRequestEvent-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 ] }
|
|
{ [ t ] [ drop send-notify-failure ] }
|
|
} cond ;
|
|
|
|
: close-box? ( event -- ? )
|
|
dup XClientMessageEvent-message_type "WM_PROTOCOLS" x-atom =
|
|
swap XClientMessageEvent-data0 "WM_DELETE_WINDOW" x-atom =
|
|
and ;
|
|
|
|
M: world client-event
|
|
swap close-box? [
|
|
dup world-handle
|
|
>r close-world
|
|
r> first2 destroy-window*
|
|
] [
|
|
drop
|
|
] if ;
|
|
|
|
: gadget-window ( world -- )
|
|
[
|
|
dup world-loc over rect-dim glx-window >r
|
|
[ register-window ] keep r> 2array
|
|
] keep set-world-handle ;
|
|
|
|
: event-loop ( -- )
|
|
windows get empty? [
|
|
[ do-events ] ui-try event-loop
|
|
] unless ;
|
|
|
|
IN: gadgets
|
|
|
|
: set-title ( string world -- )
|
|
world-handle first dpy get -rot swap XStoreName drop ;
|
|
|
|
: open-window* ( world -- )
|
|
dup gadget-window
|
|
dup start-world
|
|
world-handle first dup set-closable map-window ;
|
|
|
|
: raise-window ( world -- )
|
|
dpy get swap world-handle first XRaiseWindow drop ;
|
|
|
|
: select-gl-context ( handle -- )
|
|
dpy get swap first2 glXMakeCurrent
|
|
[ "Failed to set current GLX context" throw ] unless ;
|
|
|
|
: flush-gl-context ( handle -- )
|
|
dpy get swap first glXSwapBuffers ;
|
|
|
|
IN: shells
|
|
|
|
: ui ( -- )
|
|
[
|
|
f [
|
|
init-timers
|
|
init-clipboard
|
|
restore-windows? [
|
|
restore-windows
|
|
] [
|
|
init-ui
|
|
workspace-window
|
|
drop
|
|
] if
|
|
event-loop
|
|
] with-x
|
|
] with-freetype ;
|
|
|
|
IN: command-line
|
|
|
|
: default-shell "DISPLAY" os-env empty? "tty" "ui" ? ;
|