103 lines
3.2 KiB
Factor
Executable File
103 lines
3.2 KiB
Factor
Executable File
|
|
USING: kernel io combinators namespaces arrays assocs sequences math
|
|
x11.xlib
|
|
x11.constants
|
|
vars mortar slot-accessors
|
|
x x.keysym-table x.widgets x.widgets.wm.child x.widgets.wm.frame ;
|
|
|
|
IN: x.widgets.wm.root
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
SYMBOL: <wm-root>
|
|
|
|
<wm-root>
|
|
<widget>
|
|
{ "keymap" } accessors
|
|
define-simple-class
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
VAR: wm-root
|
|
|
|
: create-wm-root ( -- )
|
|
<wm-root> new-empty
|
|
dpy> >>dpy
|
|
dpy> $default-root $id >>id
|
|
SubstructureRedirectMask >>mask
|
|
<- add-to-window-table
|
|
SubstructureRedirectMask <-- select-input
|
|
H{ } clone >>keymap
|
|
>wm-root ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: find-in-table ( window -- object )
|
|
dup >r $id dpy get $window-table at r> or ;
|
|
|
|
: circulate-focus ( -- )
|
|
dpy get $default-root <- children
|
|
[ find-in-table ] map [ <- mapped? ] subset dup length 1 >
|
|
[ reverse dup first <- lower drop
|
|
second <- raise
|
|
dup <wm-frame> is? [ $child ] [ ] if
|
|
RevertToPointerRoot CurrentTime <--- set-input-focus drop ]
|
|
[ drop ]
|
|
if ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: managed? ( id -- ? )
|
|
dpy get $window-table values [ <wm-child> is? ] subset [ $id ] map member? ;
|
|
|
|
: event>keyname ( event -- keyname ) lookup-keysym keysym>name ;
|
|
|
|
: event>state-and-name ( event -- array )
|
|
dup XKeyEvent-state swap event>keyname 2array ;
|
|
|
|
: resolve-key-event ( keymap event -- item ) event>state-and-name swap at ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
<wm-root> {
|
|
|
|
"handle-map-request" !( event wm-root -- ) [
|
|
{ { [ over XMapRequestEvent-window managed? ]
|
|
[ "<wm-root> handle-map-request :: window already managed" print flush
|
|
2drop ] }
|
|
{ [ t ] [ drop XMapRequestEvent-window <wm-frame> <<- create drop ] } }
|
|
cond ]
|
|
|
|
"handle-unmap" !( event wm-root -- ) [ 2drop ]
|
|
|
|
"handle-key-press" !( event wm-root -- )
|
|
[ $keymap swap resolve-key-event call ]
|
|
|
|
"grab-key" !( wm-root modifiers keyname -- wm-root modifiers keyname ) [
|
|
3dup name>keysym keysym-to-keycode spin
|
|
False GrabModeAsync GrabModeAsync grab-key ]
|
|
|
|
"set-key-action" !( wm-root modifiers keyname action -- wm-root ) [
|
|
>r <--- grab-key r>
|
|
-rot 2array pick $keymap set-at ]
|
|
|
|
"handle-configure-request" !( event wm-root -- ) [
|
|
$dpy over XConfigureRequestEvent-window <window> new ! event window
|
|
{ { [ over dup CWX? swap CWY? and ]
|
|
[ over XConfigureRequestEvent-position <-- move ] }
|
|
{ [ over CWX? ] [ over XConfigureRequestEvent-x <-- set-x ] }
|
|
{ [ over CWY? ] [ over XConfigureRequestEvent-y <-- set-y ] }
|
|
{ [ t ] [ "<wm-root> handle-configure-request :: move not requested"
|
|
print flush ] } }
|
|
cond
|
|
|
|
{ { [ over dup CWWidth? swap CWHeight? and ]
|
|
[ over XConfigureRequestEvent-size <-- resize ] }
|
|
{ [ over CWWidth? ] [ over XConfigureRequestEvent-width <-- set-width ] }
|
|
{ [ over CWHeight? ] [ over XConfigureRequestEvent-height <-- set-height ] }
|
|
{ [ t ] [ "<wm-root> handle-configure-request :: resize not requested"
|
|
print flush ] } }
|
|
cond
|
|
2drop ]
|
|
|
|
} add-methods |