Things to support new Factory changes
wayo.cavazos
parent
e722fdb590
commit
5e14ba0474
|
|
@ -100,16 +100,6 @@ M: window handle-leave-window-event ( event obj -- )
|
|||
"Basic handle-leave-window-event called" print flush drop drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! <label>
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: label text ;
|
||||
|
||||
: create-label ( text -- <label> )
|
||||
<label>
|
||||
create-window-object over set-delegate
|
||||
dup add-to-window-table
|
||||
ExposureMask over select-input% ;
|
||||
|
||||
DEFER: draw-string%
|
||||
DEFER: draw-string-middle-center%
|
||||
|
|
@ -122,6 +112,21 @@ DEFER: map-subwindows%
|
|||
DEFER: reparent-window%
|
||||
DEFER: unmap-window%
|
||||
DEFER: add-input%
|
||||
DEFER: select-input%
|
||||
DEFER: set-window-background%
|
||||
DEFER: clear-window%
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! <label>
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: label text ;
|
||||
|
||||
: create-label ( text -- <label> )
|
||||
<label>
|
||||
create-window-object over set-delegate
|
||||
dup add-to-window-table
|
||||
ExposureMask over select-input% ;
|
||||
|
||||
M: label handle-expose-event ( event <label> -- )
|
||||
nip
|
||||
|
|
@ -363,6 +368,7 @@ dup pwindow-expose-action call ;
|
|||
: valid-window?% [ valid-window? ] with-window-object ;
|
||||
: window-position% [ window-position ] with-window-object ;
|
||||
: window-size% [ window-size ] with-window-object ;
|
||||
: window-rect% [ window-rect ] with-window-object ;
|
||||
: window-map-state% [ window-map-state ] with-window-object ;
|
||||
: window-parent% [ window-parent ] with-window-object ;
|
||||
|
||||
|
|
@ -388,6 +394,7 @@ dup pwindow-expose-action call ;
|
|||
: draw-string% [ draw-string ] with-window-object ;
|
||||
: draw-string-middle-center% [ draw-string-middle-center ]
|
||||
with-window-object ;
|
||||
: draw-string-top-left% [ draw-string-top-left ] with-window-object ;
|
||||
|
||||
: get-transient-for-hint% [ get-transient-for-hint ]
|
||||
with-window-object ;
|
||||
|
|
@ -395,3 +402,6 @@ dup pwindow-expose-action call ;
|
|||
: fetch-name% [ fetch-name ] with-window-object ;
|
||||
|
||||
: clear-window% [ clear-window ] with-window-object ;
|
||||
|
||||
: init-widgets ( display-string -- )
|
||||
initialize-x [ concurrent-event-loop ] in-thread ;
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
USING: namespaces kernel compiler math arrays strings alien sequences io
|
||||
USING: namespaces kernel words compiler math arrays strings alien sequences io
|
||||
prettyprint x11 rectangle ;
|
||||
|
||||
IN: x
|
||||
|
|
@ -57,7 +57,7 @@ SYMBOL: font
|
|||
|
||||
! 3.7 - Configuring Windows
|
||||
|
||||
: move-window ( { x y } -- ) >r dpy get win get r> [ ] each XMoveWindow drop ;
|
||||
: move-window ( { x y } -- ) dpy get win get rot first2 XMoveWindow drop ;
|
||||
|
||||
DEFER: window-position
|
||||
DEFER: window-width
|
||||
|
|
@ -145,6 +145,8 @@ change-window-attributes ;
|
|||
: window-x 0 window-position nth ;
|
||||
: window-y 1 window-position nth ;
|
||||
|
||||
: window-rect ( -- <rect> ) window-position window-size <rect> ;
|
||||
|
||||
: get-window-attributes ( -- <XWindowAttributes> )
|
||||
dpy get win get "XWindowAttributes" <c-object> dup >r XGetWindowAttributes drop r> ;
|
||||
|
||||
|
|
@ -202,7 +204,7 @@ SYMBOL: event-masks
|
|||
} event-masks set-global
|
||||
|
||||
: bit-test ( a b -- t-or-f ) bitand 0 = not ;
|
||||
|
||||
|
||||
: name>event-mask ( str -- i )
|
||||
event-masks get [ first over = ] find 2nip second ;
|
||||
|
||||
|
|
@ -253,9 +255,9 @@ terpri ;
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: lookup-color ( name -- pixel )
|
||||
>r dpy get colormap get r> "XColor" <c-object> dup >r "XColor" <c-object> XLookupColor drop
|
||||
dpy get colormap get r> dup >r XAllocColor drop
|
||||
r> XColor-pixel ;
|
||||
>r dpy get colormap get r> "XColor" <c-object> dup >r "XColor" <c-object>
|
||||
XLookupColor drop
|
||||
dpy get colormap get r> dup >r XAllocColor drop r> XColor-pixel ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! 7 - Graphics Context Functions
|
||||
|
|
@ -330,10 +332,70 @@ dpy get win get r> 0 0 XReparentWindow drop ;
|
|||
|
||||
: ungrab-server ( -- ) dpy get XUngrabServer drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! 10 - Events
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: event-types ( -- seq )
|
||||
{ f
|
||||
f
|
||||
"KeyPress"
|
||||
"KeyRelease"
|
||||
"ButtonPress"
|
||||
"ButtonRelease"
|
||||
"MotionNotify"
|
||||
"EnterNotify"
|
||||
"LeaveNotify"
|
||||
"FocusIn"
|
||||
"FocusOut"
|
||||
"KeymapNotify"
|
||||
"Expose"
|
||||
"GraphicsExpose"
|
||||
"NoExpose"
|
||||
"VisibilityNotify"
|
||||
"CreateNotify"
|
||||
"DestroyNotify"
|
||||
"UnmapNotify"
|
||||
"MapNotify"
|
||||
"MapRequest"
|
||||
"ReparentNotify"
|
||||
"ConfigureNotify"
|
||||
"ConfigureRequest"
|
||||
"GravityNotify"
|
||||
"ResizeRequest"
|
||||
"CirculateNotify"
|
||||
"CirculateRequest"
|
||||
"PropertyNotify"
|
||||
"SelectionClear"
|
||||
"SelectionRequest"
|
||||
"SelectionNotify"
|
||||
"ColormapNotify"
|
||||
"ClientMessage"
|
||||
"MappingNotify"
|
||||
"LASTEvent" } ;
|
||||
|
||||
: event-type>name ( i -- str ) event-types nth ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: XButtonEvent-position ( event -- { x y } )
|
||||
dup XButtonEvent-x swap XButtonEvent-y 2array ;
|
||||
|
||||
: XButtonEvent-root-position ( event -- { x y } )
|
||||
dup XButtonEvent-x_root swap XButtonEvent-y_root 2array ;
|
||||
|
||||
: XMotionEvent-position ( event -- { x y } )
|
||||
dup XMotionEvent-x swap XMotionEvent-y 2array ;
|
||||
|
||||
: XMotionEvent-root-position ( event -- { x y } )
|
||||
dup XMotionEvent-x_root swap XMotionEvent-y_root 2array ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! 11 - Event Handling Functions
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: bitmask ( seq -- mask ) 0 [ execute bitor ] reduce ;
|
||||
|
||||
: select-input ( mask -- ) >r dpy get win get r> XSelectInput drop ;
|
||||
|
||||
: add-input ( mask -- )
|
||||
|
|
@ -365,8 +427,7 @@ error-handler-quot set error-handler-callback XSetErrorHandler drop ;
|
|||
! 12 - Input Device Functions
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: set-input-focus ( revert-to time -- )
|
||||
>r >r dpy get win get r> r> XSetInputFocus drop ;
|
||||
! 12.1 - Pointer Grabbing
|
||||
|
||||
: grab-pointer ( mask -- )
|
||||
>r dpy get win get 0 r> GrabModeAsync GrabModeAsync None None CurrentTime
|
||||
|
|
@ -375,9 +436,19 @@ XGrabPointer drop ;
|
|||
: ungrab-pointer ( time -- )
|
||||
>r dpy get r> XUngrabPointer drop ;
|
||||
|
||||
: change-active-pointer-grab ( mask -- )
|
||||
dpy get swap None CurrentTime XChangeActivePointerGrab drop ;
|
||||
|
||||
! 12.2 - Keyboard Grabbing
|
||||
|
||||
: grab-key ( keycode modifiers owner-events pointer-mode keyboard-mode -- )
|
||||
>r >r >r >r >r dpy get r> r> win get r> r> r> XGrabKey drop ;
|
||||
|
||||
! 12.5 - Controlling Input Focus
|
||||
|
||||
: set-input-focus ( revert-to time -- )
|
||||
>r >r dpy get win get r> r> XSetInputFocus drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! 14 - Inter-Client Communication Functions
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
|
|||
Loading…
Reference in New Issue