373 lines
12 KiB
Factor
373 lines
12 KiB
Factor
|
|
IN: concurrent-widgets
|
|
USING: io namespaces kernel hashtables math generic threads concurrency
|
|
lists sequences arrays xlib x ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
TUPLE: window display id ;
|
|
|
|
! dpy get create-window <window>
|
|
|
|
! window-object [ { 100 100 } move-window ] with-window-object
|
|
|
|
: create-window-object
|
|
dpy get create-window <window> ;
|
|
|
|
: with-window-object ( <window> quot -- )
|
|
[ swap dup window-display dpy set window-id win set call ] with-scope ; inline
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
! window-table add-to-window-table
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
SYMBOL: window-table
|
|
|
|
10 <hashtable> window-table set
|
|
|
|
: add-to-window-table ( <window> -- )
|
|
dup window-id window-table get set-hash ;
|
|
|
|
! The window-table is keyed on window ids. If support is added for
|
|
! multiple displays, then perhaps there should be a window table for
|
|
! each open display.
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
! handle-event
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
GENERIC: handle-key-press-event
|
|
GENERIC: handle-key-release-event
|
|
GENERIC: handle-button-press-event
|
|
GENERIC: handle-button-release-event
|
|
GENERIC: handle-expose-event
|
|
GENERIC: handle-configure-event
|
|
GENERIC: handle-enter-window-event
|
|
GENERIC: handle-leave-window-event
|
|
GENERIC: handle-destroy-window-event
|
|
GENERIC: handle-map-request-event
|
|
GENERIC: handle-map-event
|
|
GENERIC: handle-configure-request-event
|
|
GENERIC: handle-unmap-event
|
|
GENERIC: handle-property-event
|
|
|
|
: handle-event ( event obj -- )
|
|
over XAnyEvent-type
|
|
{ { [ dup Expose = ] [ drop handle-expose-event ] }
|
|
{ [ dup KeyPress = ] [ drop handle-key-press-event ] }
|
|
{ [ dup KeyRelease = ] [ drop handle-key-release-event ] }
|
|
{ [ dup ButtonPress = ] [ drop handle-button-press-event ] }
|
|
{ [ dup ButtonRelease = ] [ drop handle-button-release-event ] }
|
|
{ [ dup ConfigureNotify = ] [ drop handle-configure-event ] }
|
|
{ [ dup EnterNotify = ] [ drop handle-enter-window-event ] }
|
|
{ [ dup LeaveNotify = ] [ drop handle-leave-window-event ] }
|
|
{ [ dup DestroyNotify = ] [ drop handle-destroy-window-event ] }
|
|
{ [ dup MapRequest = ] [ drop handle-map-request-event ] }
|
|
{ [ dup MapNotify = ] [ drop handle-map-event ] }
|
|
{ [ dup ConfigureRequest = ] [ drop handle-configure-request-event ] }
|
|
{ [ dup UnmapNotify = ] [ drop handle-unmap-event ] }
|
|
{ [ dup PropertyNotify = ] [ drop handle-property-event ] }
|
|
{ [ t ] [ "handle-event ignoring event" print 3drop ] } }
|
|
cond ;
|
|
|
|
M: window handle-configure-event ( event obj -- )
|
|
"Basic handle-configure-event called" print drop drop ;
|
|
|
|
M: window handle-destroy-window-event ( event obj -- )
|
|
"Basic handle-destroy-window-event called" print drop drop ;
|
|
|
|
M: window handle-map-event ( event obj -- )
|
|
"Basic handle-map-event called" print drop drop ;
|
|
|
|
M: window handle-expose-event ( event obj -- )
|
|
"Basic handle-expose-event called" print drop drop ;
|
|
|
|
M: window handle-button-release-event ( event obj -- )
|
|
"Basic handle-button-release-event called" print drop drop ;
|
|
|
|
M: window handle-unmap-event ( event obj -- )
|
|
"Basic handle-unmap-event called" print drop drop ;
|
|
|
|
M: window handle-key-press-event ( event obj -- )
|
|
"Basic handle-key-press-event called" print drop drop ;
|
|
|
|
M: window handle-key-release-event ( event obj -- )
|
|
"Basic handle-key-release-event called" print drop drop ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
! <label>
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
TUPLE: label text ;
|
|
|
|
: create-label ( text -- <label> )
|
|
>r create-window-object r> <label> dup >r set-delegate r>
|
|
dup add-to-window-table
|
|
dup >r
|
|
>r ExposureMask r> [ select-input ] with-window-object
|
|
r> ;
|
|
|
|
DEFER: draw-string%
|
|
DEFER: window-size%
|
|
DEFER: window-children%
|
|
DEFER: set-window-width%
|
|
DEFER: set-window-height%
|
|
DEFER: vertical-layout%
|
|
DEFER: map-subwindows%
|
|
DEFER: reparent-window%
|
|
DEFER: unmap-window%
|
|
|
|
! M: label handle-expose-event ( event <label> -- )
|
|
! nip dup window-size% { 1/2 1/2 } v* swap
|
|
! dup label-text swap
|
|
! [ draw-string-middle-center ] with-window-object ;
|
|
|
|
M: label handle-expose-event ( event <label> -- )
|
|
nip
|
|
[ window-size% { 1/2 1/2 } v* ] keep
|
|
[ label-text ] keep
|
|
[ draw-string-middle-center ] with-window-object ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
! <button>
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
TUPLE: button action ;
|
|
|
|
: create-button ( text action -- <button> )
|
|
swap create-label swap <button> dup >r set-delegate r>
|
|
dup add-to-window-table
|
|
>r ExposureMask ButtonPressMask bitor r>
|
|
dup >r [ select-input ] with-window-object
|
|
r> ;
|
|
|
|
M: button handle-button-press-event ( event <button> -- )
|
|
nip button-action call ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
! <menu>
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
TUPLE: menu item-width item-height space ;
|
|
|
|
: create-menu ( -- <menu> )
|
|
create-window-object 100 20 1 <menu> [ set-delegate ] keep ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: set-menu-children-height ( menu -- )
|
|
dup menu-item-height swap window-children%
|
|
[ set-window-height+ ]
|
|
each-with ;
|
|
|
|
: set-menu-children-width ( menu -- )
|
|
dup menu-item-width swap window-children%
|
|
[ set-window-width+ ]
|
|
each-with ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: center-menu-items ( menu -- )
|
|
window-children% [ center-window-horizontally+ ] each ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: set-menu-width ( menu -- )
|
|
dup menu-space 2 *
|
|
over menu-item-width +
|
|
swap set-window-width% ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: menu-items-height ( menu -- height )
|
|
dup window-children% length swap menu-item-height * ;
|
|
|
|
: menu-space-height ( menu -- height )
|
|
dup window-children% length 1 - 2 +
|
|
swap menu-space * ;
|
|
|
|
: menu-height ( menu -- height )
|
|
dup menu-items-height swap menu-space-height + ;
|
|
|
|
: set-menu-height ( menu -- )
|
|
dup menu-height swap set-window-height% ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: refresh-menu ( menu -- )
|
|
dup set-menu-children-height
|
|
dup set-menu-children-width
|
|
dup set-menu-width
|
|
dup set-menu-height
|
|
dup menu-space over vertical-layout%
|
|
dup center-menu-items
|
|
map-subwindows% ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: add-menu-item ( text action menu -- )
|
|
-rot create-button dupd reparent-window%
|
|
refresh-menu ;
|
|
|
|
: modify-action-to-unmap ( action menu -- action )
|
|
[ unmap-window% ] cons append ;
|
|
|
|
: add-popup-menu-item ( text action menu -- )
|
|
tuck modify-action-to-unmap
|
|
swap add-menu-item ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
! <pwindow>
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
! window with parameterizable responses to events
|
|
|
|
TUPLE: pwindow resize-action last-size move-action last-position
|
|
key-action button-action motion-action expose-action ;
|
|
|
|
! resize-action ( { width height } <pwindow> -- )
|
|
! move-action ( { x y } <pwindow> -- )
|
|
|
|
: create-pwindow ( -- <pwindow> )
|
|
create-window-object f f f f f f f f <pwindow> dup >r set-delegate r>
|
|
dup add-to-window-table ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: XConfigureEvent-size ( event -- { width height } )
|
|
dup XConfigureEvent-width swap XConfigureEvent-height 2array ;
|
|
|
|
: XConfigureEvent-position ( event -- { x y } )
|
|
dup XConfigureEvent-x swap XConfigureEvent-y 2array ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: size-changed? ( event obj -- ? )
|
|
pwindow-last-size swap XConfigureEvent-size = not ;
|
|
|
|
: update-last-size ( event obj -- )
|
|
swap XConfigureEvent-size swap set-pwindow-last-size ;
|
|
|
|
: call-resize-action ( event obj -- ? )
|
|
swap XConfigureEvent-size swap dup pwindow-resize-action call ;
|
|
|
|
: maybe-handle-resize ( event obj -- )
|
|
2dup size-changed? [ 2dup update-last-size call-resize-action ] [ 2drop ] if ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: position-changed? ( event obj -- ? )
|
|
pwindow-last-position swap XConfigureEvent-position = not ;
|
|
|
|
: update-last-position ( event obj -- )
|
|
swap XConfigureEvent-position swap set-pwindow-last-position ;
|
|
|
|
: call-move-action ( event obj -- ? )
|
|
swap XConfigureEvent-position swap dup pwindow-move-action call ;
|
|
|
|
: maybe-handle-move ( event obj )
|
|
2dup position-changed?
|
|
[ 2dup update-last-position call-move-action ] [ 2drop ] if ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
M: pwindow handle-configure-event ( event obj -- )
|
|
2dup maybe-handle-resize maybe-handle-move ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
M: pwindow handle-key-press-event ( event obj -- )
|
|
dup pwindow-key-action call ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
M: pwindow handle-button-press-event ( event obj -- )
|
|
dup pwindow-button-action call ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
M: pwindow handle-expose-event ( event obj -- )
|
|
dup pwindow-expose-action call ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
! event-loop
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
! : event-loop ( -- )
|
|
! next-event ! event
|
|
! dup ! event event
|
|
! XAnyEvent-window ! event window
|
|
! window-table get ! event window table
|
|
! hash ! event obj-or-f
|
|
! dup ! event obj-or-f obj-or-f
|
|
! [ handle-event ]
|
|
! [ drop drop ] ! event obj-or-f obj-or-f [ handle-event ] [ drop drop ]
|
|
! if
|
|
! event-loop ;
|
|
|
|
! It's possible to have multiple displays open simultaneously.
|
|
! Maybe there can be an event loop for each display. Each event loop
|
|
! would run in it's own thread.
|
|
|
|
: concurrent-next-event ( -- event )
|
|
! QueuedAlready events-queued 0 >
|
|
QueuedAfterFlush events-queued 0 >
|
|
[ next-event ]
|
|
[ 100 sleep concurrent-next-event ]
|
|
if ;
|
|
|
|
: concurrent-event-loop ( -- )
|
|
concurrent-next-event ! event
|
|
dup ! event event
|
|
XAnyEvent-window ! event window
|
|
window-table get ! event window table
|
|
hash ! event obj-or-f
|
|
dup ! event obj-or-f obj-or-f
|
|
[ handle-event ]
|
|
[ drop drop ] ! event obj-or-f obj-or-f [ handle-event ] [ drop drop ]
|
|
if
|
|
concurrent-event-loop ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
! Not categorized
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: set-window-width% [ set-window-width ] with-window-object ;
|
|
: set-window-height% [ set-window-height ] with-window-object ;
|
|
|
|
: select-input% [ select-input ] with-window-object ;
|
|
: set-input-focus% [ set-input-focus ] with-window-object ;
|
|
: move-window% [ move-window ] with-window-object ;
|
|
: resize-window% [ resize-window ] with-window-object ;
|
|
: set-window-border-width% [ set-window-border-width ] with-window-object ;
|
|
: map-window% [ map-window ] with-window-object ;
|
|
: map-subwindows% [ map-subwindows ] with-window-object ;
|
|
: valid-window?% [ valid-window? ] with-window-object ;
|
|
: window-position% [ window-position ] with-window-object ;
|
|
: window-size% [ window-size ] with-window-object ;
|
|
: window-map-state% [ window-map-state ] with-window-object ;
|
|
|
|
: reparent-window% ( parent window -- )
|
|
>r window-id r> [ reparent-window ] with-window-object ;
|
|
|
|
: destroy-window% [ destroy-window ] with-window-object ;
|
|
: raise-window% [ raise-window ] with-window-object ;
|
|
: window-override-redirect% [ window-override-redirect ] with-window-object ;
|
|
: add-to-save-set% [ add-to-save-set ] with-window-object ;
|
|
: window-x% [ window-x ] with-window-object ;
|
|
: window-y% [ window-y ] with-window-object ;
|
|
: window-width% [ window-width ] with-window-object ;
|
|
: window-height% [ window-height ] with-window-object ;
|
|
: unmap-window% [ unmap-window ] with-window-object ;
|
|
: set-window-background% [ set-window-background ] with-window-object ;
|
|
: grab-pointer% [ grab-pointer ] with-window-object ;
|
|
: mouse-sensor% [ mouse-sensor ] with-window-object ;
|
|
: window-children% [ window-children ] with-window-object ;
|
|
|
|
: vertical-layout% [ vertical-layout ] with-window-object ;
|
|
|
|
: draw-string% [ draw-string ] with-window-object ;
|
|
|
|
: get-transient-for-hint% [ get-transient-for-hint ] with-window-object ;
|
|
|
|
: fetch-name% [ fetch-name ] with-window-object ; |