USING: kernel alien compiler namespaces generic math sequences hashtables io arrays words prettyprint concurrency process vars rectangle x11 x concurrent-widgets ; IN: factory ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DEFER: workspace-menu DEFER: wm-frame? DEFER: manage-window DEFER: window-list DEFER: refresh-window-list DEFER: layout-frame DEFER: mapped-windows DEFER: workspace-1 DEFER: workspace-2 DEFER: workspace-3 DEFER: workspace-4 DEFER: switch-to DEFER: update-title DEFER: delete-frame ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : popup-window ( -- ) mouse-sensor move-window raise-window map-window ; : popup-window% [ popup-window ] with-window-object ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: root-menu : setup-root-menu ( -- ) create-menu root-menu set "black" lookup-color root-menu get set-window-background% "Terminal" [ "gnome-terminal &" system ] root-menu get add-popup-menu-item "Emacs" [ "emacs &" system ] root-menu get add-popup-menu-item "Firefox" [ "firefox &" system ] root-menu get add-popup-menu-item "Workspaces" [ workspace-menu get popup-window% ] root-menu get add-popup-menu-item ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: drag-gc : make-drag-gc ( -- GC ) create-gc dup [ IncludeInferiors set-subwindow-mode GXxor set-function white-pixel get set-foreground ] with-gcontext ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! VARS: event frame push position ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : event-type ( -- type ) event> XAnyEvent-type ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : drag-offset ( -- offset ) position> push> v- ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : draw-rubber-band ( -- ) root get [ drag-gc get [ draw-rect ] with-gcontext ] with-win ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! drag-move-frame ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : draw-frame-outline ( -- ) drag-offset frame> window-position% v+ frame> window-size% draw-rubber-band ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : drag-move-frame-loop ( -- ) next-event >event { { [ event-type MotionNotify = ] [ draw-frame-outline event> XMotionEvent-root-position >position draw-frame-outline drag-move-frame-loop ] } { [ event-type ButtonRelease = ] [ draw-frame-outline drag-offset frame> window-position% v+ frame> move-window% ] } { [ t ] [ "[drag-move-frame-loop] Ignoring event type: " write event-type event-type>name write terpri flush drag-move-frame-loop ] } } cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : drag-move-frame ( event -- ) [ >frame >event event> XButtonEvent-root-position >push event> XButtonEvent-root-position >position draw-frame-outline drag-move-frame-loop frame> raise-window% ] with-scope ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! drag-size-frame ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : draw-size-outline ( -- ) frame> window-position% position> over v- draw-rubber-band ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : drag-size-frame-loop ( -- ) next-event >event { { [ event-type MotionNotify = ] [ draw-size-outline event> XMotionEvent-root-position >position draw-size-outline drag-size-frame-loop ] } { [ event-type ButtonRelease = ] [ draw-size-outline position> frame> window-position% v- frame> resize-window% frame> layout-frame ] } { [ t ] [ "[drag-size-frame-loop] ignoring event" print flush drag-size-frame-loop ] } } cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : drag-size-frame ( event -- ) [ >frame >event event> XButtonEvent-root-position >position draw-size-outline drag-size-frame-loop ] with-scope ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! GENERIC: move-request-x GENERIC: move-request-y GENERIC: move-request-position GENERIC: execute-move-request GENERIC: size-request-width GENERIC: size-request-height GENERIC: size-request-size GENERIC: execute-size-request ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! wm-root ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! TUPLE: wm-root ; : wm-root-mask ( -- mask ) [ SubstructureRedirectMask SubstructureNotifyMask ButtonPressMask ButtonReleaseMask KeyPressMask KeyReleaseMask ] bitmask ; : create-wm-root ( window-id -- ) dpy get swap tuck set-delegate dup add-to-window-table wm-root-mask over select-input% ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! M: wm-root handle-map-request-event ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : id>obj ( id -- obj ) dup window-table get hash dup [ nip ] [ drop dpy get swap ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! M: wm-root handle-map-request-event ( event -- ) "handle-map-request-event called on wm-root" print flush drop XMapRequestEvent-window id>obj ! obj { { [ dup wm-frame? ] [ map-window% ] } { [ dup valid-window?% not ] [ "Not a valid window." print flush drop ] } { [ dup window-override-redirect% 1 = ] [ "Not reparenting: " print "new window has override_redirect attribute set." print flush drop ] } { [ dup window-id window-parent+ id>obj wm-frame? ] [ "Window is already managed" print flush drop ] } { [ t ] [ window-id manage-window ] } } cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Words for working with an XConfigureRequestEvent ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : bit-test ( a b -- t-or-f ) bitand 0 = not ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : move-request-x? ( event -- ) XConfigureRequestEvent-value_mask CWX bit-test ; : move-request-y? ( event -- ) XConfigureRequestEvent-value_mask CWY bit-test ; : move-request? ( event -- ? ) dup move-request-x? swap move-request-y? or ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : size-request-width? ( event -- ) XConfigureRequestEvent-value_mask CWWidth bit-test ; : size-request-height? ( event -- ) XConfigureRequestEvent-value_mask CWHeight bit-test ; : size-request? ( event -- ) dup size-request-width? swap size-request-height? or ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! M: wm-root handle-configure-request-event ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! M: wm-root move-request-x ( event wm-root -- x ) drop dup move-request-x? [ XConfigureRequestEvent-x ] [ XConfigureRequestEvent-window [ window-x ] with-win ] if ; M: wm-root move-request-y ( event wm-root -- y ) drop dup move-request-y? [ XConfigureRequestEvent-y ] [ XConfigureRequestEvent-window [ window-y ] with-win ] if ; M: wm-root move-request-position ( event wm-root -- { x y } ) 2dup move-request-x -rot move-request-y 2array ; M: wm-root execute-move-request ( event wm-root -- ) dupd move-request-position swap XConfigureRequestEvent-window move-window+ ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! M: wm-root size-request-width ( event wm-root -- width ) drop dup size-request-width? [ XConfigureRequestEvent-width ] [ XConfigureRequestEvent-window [ window-width ] with-win ] if ; M: wm-root size-request-height ( event wm-root -- height ) drop dup size-request-height? [ XConfigureRequestEvent-height ] [ XConfigureRequestEvent-window [ window-height ] with-win ] if ; M: wm-root size-request-size ( event wm-root -- { width height } ) 2dup size-request-width -rot size-request-height 2array ; M: wm-root execute-size-request ( event wm-root -- ) dupd size-request-size swap XConfigureRequestEvent-window resize-window+ ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! M: wm-root handle-configure-request-event ( event wm-root -- ) over move-request? [ 2dup execute-move-request ] when over size-request? [ 2dup execute-size-request ] when drop drop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! M: wm-root handle-button-press-event ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : 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 ; M: wm-root handle-button-press-event ( event wm-root -- ) drop ! event { { [ dup XButtonEvent-button Button1 = ] [ root-menu get window-map-state% IsUnmapped = [ XButtonEvent-root-position root-menu get move-window% root-menu get raise-window% root-menu get map-window% ] [ root-menu get unmap-window% ] if ] } { [ dup XButtonEvent-button Button2 = ] [ window-list get window-map-state% IsUnmapped = [ XButtonEvent-root-position window-list get move-window% window-list get raise-window% window-list get refresh-window-list window-list get map-window% ] [ window-list get unmap-window% ] if ] } { [ t ] [ "Button has no function on root window." print flush drop ] } } cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! M: wm-root handle-key-press-event ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : True 1 ; : False 0 ; : f1-keycode ( -- code ) 67 ; : f2-keycode ( -- code ) 68 ; : f3-keycode ( -- code ) 69 ; : f4-keycode ( -- code ) 70 ; : grab-keys ( -- ) f1-keycode Mod1Mask False GrabModeAsync GrabModeAsync grab-key f2-keycode Mod1Mask False GrabModeAsync GrabModeAsync grab-key f3-keycode Mod1Mask False GrabModeAsync GrabModeAsync grab-key f4-keycode Mod1Mask False GrabModeAsync GrabModeAsync grab-key ; M: wm-root handle-key-press-event ( event wm-root -- ) drop { { [ dup XKeyEvent-keycode f1-keycode = ] [ workspace-1 get switch-to ] } { [ dup XKeyEvent-keycode f2-keycode = ] [ workspace-2 get switch-to ] } { [ dup XKeyEvent-keycode f3-keycode = ] [ workspace-3 get switch-to ] } { [ dup XKeyEvent-keycode f4-keycode = ] [ workspace-4 get switch-to ] } { [ t ] [ "wm-root ignoring key press" print drop ] } } cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! TUPLE: wm-child ; : create-wm-child ( window-id -- ) dpy get swap tuck set-delegate dup add-to-window-table ; M: wm-child handle-property-event ( event -- ) "A received a property event" print flush nip window-parent% window-table get hash dup [ update-title ] [ drop ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! TUPLE: wm-frame child ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : wm-frame-mask ( -- mask ) [ SubstructureRedirectMask SubstructureNotifyMask ExposureMask ButtonPressMask ButtonReleaseMask PointerMotionMask EnterWindowMask ] bitmask ; : create-wm-frame ( -- ) create-window-object over set-delegate dup add-to-window-table wm-frame-mask over select-input% ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : update-title ( -- ) dup clear-window% { 5 1 } swap dup wm-frame-child fetch-name% swap draw-string-top-left% ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! VARS: child frame button ; : manage-window ( window -- ) flush-dpy grab-server flush-dpy create-wm-child dup create-wm-frame [ child frame ] [ "cornflowerblue" lookup-color frame> set-window-background% child> add-to-save-set% child> window-position% frame> move-window% 0 child> set-window-border-width% frame> child> reparent-window% child> window-size% { 10 20 } v+ frame> resize-window% { 5 15 } child> move-window% "" frame> [ delete-frame ] curry create-button [ button ] [ frame> button> reparent-window% { 9 9 } button> resize-window% frame> window-width% 9 - 5 - 3 2array button> move-window% NorthEastGravity button> set-window-gravity% black-pixel get button> set-window-background% ] let PropertyChangeMask child> select-input% frame> map-subwindows% frame> map-window% frame> update-title flush-dpy 0 sync-dpy ungrab-server flush-dpy ] let ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : destroy-window-event-match? ( event -- ? ) window-id swap XDestroyWindowEvent-window = ; M: wm-frame handle-destroy-window-event ( event -- ) 2dup destroy-window-event-match? [ destroy-window% drop ] [ 2drop ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : map-request-event-match? ( event -- ? ) window-id swap XMapRequestEvent-window = ; M: wm-frame handle-map-request-event ( event -- ) 2dup map-request-event-match? ! event frame ? [ dup wm-frame-child map-window% map-window% drop ] [ drop drop ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : map-event-match? ( event -- ? ) window-id swap XMapEvent-window = ; M: wm-frame handle-map-event ( event -- ) 2dup map-event-match? [ dup map-window% raise-window% drop ] [ drop drop ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! M: wm-frame handle-configure-request-event ( event frame ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! M: wm-frame move-request-x ( event frame -- x ) over move-request-x? [ drop XConfigureRequestEvent-x ] [ nip window-x% ] if ; M: wm-frame move-request-y ( event frame -- y ) over move-request-y? [ drop XConfigureRequestEvent-y ] [ nip window-y% ] if ; M: wm-frame move-request-position ( event frame -- { x y } ) 2dup move-request-x -rot move-request-y 2array ; M: wm-frame execute-move-request ( event frame ) dup -rot move-request-position swap move-window% ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! M: wm-frame size-request-width ( event frame -- width ) over size-request-width? [ drop XConfigureRequestEvent-width ] [ nip wm-frame-child window-width% ] if ; M: wm-frame size-request-height ( event frame -- height ) over size-request-height? [ drop XConfigureRequestEvent-height ] [ nip wm-frame-child window-height% ] if ; M: wm-frame size-request-size ( event frame -- size ) 2dup size-request-width -rot size-request-height 2array ; : execute-size-request/child ( event frame ) dup wm-frame-child -rot size-request-size swap resize-window% ; : execute-size-request/frame ( event frame ) dup -rot size-request-size { 10 20 } v+ swap resize-window% ; M: wm-frame execute-size-request ( event frame ) 2dup execute-size-request/child execute-size-request/frame ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! M: wm-frame handle-configure-request-event ( event frame ) over move-request? [ 2dup execute-move-request ] when over size-request? [ 2dup execute-size-request ] when drop drop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : unmap-event-match? ( event frame -- ? ) wm-frame-child window-id swap XUnmapEvent-window = ; M: wm-frame handle-unmap-event ( event frame ) 2dup unmap-event-match? [ unmap-window% drop ] [ drop drop ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! M: wm-frame handle-button-press-event ( event frame ) over XButtonEvent-button ! event frame button { { [ dup Button1 = ] [ drop drag-move-frame ] } { [ dup Button2 = ] [ drop drag-size-frame ] } { [ dup Button3 = ] [ drop nip unmap-window% ] } { [ t ] [ drop drop drop ] } } cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! M: wm-frame handle-enter-window-event ( event frame ) nip dup wm-frame-child valid-window?% [ wm-frame-child >r RevertToPointerRoot CurrentTime r> set-input-focus% ] [ destroy-window% ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! M: wm-frame handle-property-event ( event frame -- ) "Inside handle-property-event" print flush 2drop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! M: wm-frame handle-expose-event ( event frame -- ) nip dup clear-window% update-title ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : frame-position-child ( frame -- ) wm-frame-child { 5 15 } swap move-window% ; : frame-fit-child ( frame -- ) dup window-size% { 10 20 } v- swap wm-frame-child resize-window% ; : layout-frame ( frame -- ) dup frame-position-child frame-fit-child ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: WM_PROTOCOLS SYMBOL: WM_DELETE_WINDOW : delete-frame ( frame -- ) wm-frame-child window-id [ WM_PROTOCOLS get WM_DELETE_WINDOW get send-client-message ] with-win ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Workspaces ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! GENERIC: switch-to SYMBOL: current-workspace TUPLE: workspace windows ; : create-workspace [ ] ; M: workspace switch-to ( workspace -- ) mapped-windows dup current-workspace get set-workspace-windows [ unmap-window+ ] each dup workspace-windows [ map-window+ ] each current-workspace set-global ; SYMBOL: workspace-1 SYMBOL: workspace-2 SYMBOL: workspace-3 SYMBOL: workspace-4 create-workspace workspace-1 set-global create-workspace workspace-2 set-global create-workspace workspace-3 set-global create-workspace workspace-4 set-global workspace-1 get current-workspace set-global ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: workspace-menu : setup-workspace-menu ( -- ) create-menu workspace-menu set "black" lookup-color workspace-menu get set-window-background% "Workspace 1" [ workspace-1 get switch-to ] workspace-menu get add-popup-menu-item "Workspace 2" [ workspace-2 get switch-to ] workspace-menu get add-popup-menu-item "Workspace 3" [ workspace-3 get switch-to ] workspace-menu get add-popup-menu-item "Workspace 4" [ workspace-4 get switch-to ] workspace-menu get add-popup-menu-item ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : invalid-frame? ( -- ? ) wm-frame-child window-id valid-window?+ not ; : remove-invalid-frames ( -- ) window-table get hash-values [ wm-frame? ] subset [ invalid-frame? ] subset [ window-id window-table get remove-hash ] each ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! window-list ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: window-list : setup-window-list ( -- ) create-menu window-list set-global "black" lookup-color window-list get set-window-background% 300 window-list get set-menu-item-width ; : not-transient? ( frame -- ? ) wm-frame-child get-transient-for-hint% not ; : add-window-to-list ( window-list frame -- window-list ) dup ! window-list frame frame wm-frame-child ! window-list frame child fetch-name% ! window-list frame name-or-f dup ! window-list frame name-or-f name-or-f [ ] [ drop "*untitled*" ] if ! window-list frame name swap ! window-list name frame [ map-window% ] ! window-list name frame [ map-window% ] curry ! window-list name action pick ! window-list name action window-list add-popup-menu-item ; : refresh-window-list ( window-list -- ) dup window-children% [ destroy-window+ ] each clean-window-table remove-invalid-frames window-table get hash-values [ wm-frame? ] subset [ not-transient? ] subset [ add-window-to-list ] each drop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : window-is-mapped? ( window -- ? ) window-map-state+ IsUnmapped = not ; : mapped-windows ( -- [ a b c d ... ] ) root get window-children+ [ window-is-mapped? ] subset ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : manage-existing-windows ( -- ) mapped-windows [ manage-window ] each ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : start-factory ( dpy-string -- ) initialize-x [ "X11 : error-handler called" print flush ] set-error-handler root get [ make-drag-gc ] with-win drag-gc set root get [ black-pixel get set-window-background clear-window ] with-win root get create-wm-root root get [ grab-keys ] with-win "WM_PROTOCOLS" False intern-atom WM_PROTOCOLS set "WM_DELETE_WINDOW" False intern-atom WM_DELETE_WINDOW set "cornflowerblue" lookup-color menu-enter-color set "white" lookup-color menu-leave-color set setup-root-menu setup-window-list setup-workspace-menu manage-existing-windows [ concurrent-event-loop ] spawn ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IN: shells USE: listener : factory f start-factory listener ;