diff --git a/contrib/factory/factory.factor b/contrib/factory/factory.factor index 778e95cc5d..37799d4053 100644 --- a/contrib/factory/factory.factor +++ b/contrib/factory/factory.factor @@ -15,6 +15,7 @@ DEFER: layout-frame DEFER: mapped-windows DEFER: workspace-1 DEFER: workspace-2 DEFER: workspace-3 DEFER: workspace-4 DEFER: switch-to +DEFER: update-title ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -318,8 +319,10 @@ TUPLE: wm-child ; [ set-delegate ] keep [ add-to-window-table ] keep ; -M: wm-child handle-property-event ( child event -- ) - "A received a property event" print flush drop drop ; +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 ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -344,6 +347,11 @@ TUPLE: wm-frame child ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: update-title ( -- ) +dup clear-window% +{ 5 1 } swap dup wm-frame-child fetch-name% swap +[ draw-string-top-left ] with-window-object ; + : manage-window ( window -- ) flush-dpy grab-server @@ -365,14 +373,31 @@ TUPLE: wm-frame child ; reparent-window% dup wm-frame-child window-size% ! frame child-size - { 20 20 } v+ ! frame child-size+ + { 10 20 } v+ ! frame child-size+ over ! frame child-size+ frame - resize-window% + resize-window% ! frame - dup wm-frame-child { 10 10 } swap move-window% + + + dup wm-frame-child { 5 15 } swap move-window% dup map-window% - dup map-subwindows% + dup map-subwindows% ! frame + +! dup wm-frame-child fetch-name% ! frame title +! { 5 1 } swap ! frame point title +! pick ! frame point title frame +! [ draw-string-top-left ] with-window-object ! frame + + dup update-title ! frame + + "" over [ delete-frame ] curry create-button ! frame button + >r dup window-id r> + [ reparent-window { 13 13 } resize-window + dup window-width% 13 - 1 - 1 2array move-window + NorthEastGravity set-window-gravity + black-pixel get set-window-background map-window ] + with-window-object ! frame dup wm-frame-child PropertyChangeMask swap select-input% @@ -451,7 +476,7 @@ M: wm-frame size-request-size ( event frame -- size ) dup wm-frame-child -rot size-request-size swap resize-window% ; : execute-size-request/frame ( event frame ) - dup -rot size-request-size { 20 20 } v+ swap resize-window% ; + 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 ; @@ -495,19 +520,32 @@ M: wm-frame handle-enter-window-event ( event frame ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -M: wm-frame handle-property-event ( event frame ) - "Inside handle-property-event" print flush drop drop ; +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 ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : layout-frame ( frame -- ) - dup wm-frame-child { 10 10 } swap move-window% + dup wm-frame-child { 5 15 } swap move-window% dup wm-frame-child ! frame child over window-size% ! frame child size - { 20 20 } v- ! frame child child-size + { 10 20 } v- ! frame child child-size swap resize-window% ! frame drop ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +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 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -616,6 +654,8 @@ SYMBOL: window-list 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 setup-root-menu setup-window-list setup-workspace-menu diff --git a/contrib/x11/concurrent-widgets.factor b/contrib/x11/concurrent-widgets.factor index 9f2a378453..a16b5edf54 100644 --- a/contrib/x11/concurrent-widgets.factor +++ b/contrib/x11/concurrent-widgets.factor @@ -351,6 +351,7 @@ dup pwindow-expose-action call ; : window-position% [ window-position ] with-window-object ; : window-size% [ window-size ] with-window-object ; : window-map-state% [ window-map-state ] with-window-object ; +: window-parent% [ window-parent ] with-window-object ; : reparent-window% ( parent window -- ) >r window-id r> [ reparent-window ] with-window-object ; @@ -375,4 +376,6 @@ dup pwindow-expose-action call ; : get-transient-for-hint% [ get-transient-for-hint ] with-window-object ; -: fetch-name% [ fetch-name ] with-window-object ; \ No newline at end of file +: fetch-name% [ fetch-name ] with-window-object ; + +: clear-window% [ clear-window ] with-window-object ; diff --git a/contrib/x11/x.factor b/contrib/x11/x.factor index c6e9a9a07f..8214449add 100644 --- a/contrib/x11/x.factor +++ b/contrib/x11/x.factor @@ -26,9 +26,14 @@ SYMBOL: font : *Window *XID ; : *Drawable *XID ; +: True 1 ; +: False 0 ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! 3 - Window Functions +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! 3.3 - Creating Windows -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! create-window is radically simple. It takes no arguments but you get ! a window back! After you create-window you should modify it's @@ -89,9 +94,18 @@ DEFER: with-win ! 3.9 - Changing Window Attributes +: change-window-attributes ( valuemask attr -- ) +>r >r dpy get win get r> r> XChangeWindowAttributes drop ; + : set-window-background ( pixel -- ) >r dpy get win get r> XSetWindowBackground drop ; +: set-window-gravity ( gravity -- ) +CWWinGravity swap +"XSetWindowAttributes" tuck +set-XSetWindowAttributes-win_gravity +change-window-attributes ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 4 - Window Information Functions ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -148,6 +162,13 @@ get-window-attributes XWindowAttributes-all_event_masks ; : window-override-redirect get-window-attributes XWindowAttributes-override_redirect ; +! 4.3 - Properties and Atoms + +: intern-atom ( atom-name only-if-exists? -- atom ) +>r >r dpy get r> r> XInternAtom ; + +: get-atom-name ( atom -- name ) dpy get swap XGetAtomName ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: event-masks @@ -366,6 +387,18 @@ XGrabPointer drop ; dpy get win get 0 dup >r XGetTransientForHint r> swap 0 = [ drop f ] [ *Window ] if ; +! 14.1.10. Setting and Reading the WM_PROTOCOLS Property + +: ( value -- address ) ; + +: get-wm-protocols ( -- protocols ) +dpy get win get 0 0 2dup >r >r XGetWMProtocols drop +r> r> ! protocols-return count-return +swap *void* swap *int ! protocols count +[ over int-nth ] map +nip ; + + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Not Categorized Yet ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -485,3 +518,16 @@ swap >array [ swap char-nth ] map-with >string ; : lookup-string ( event -- string ) 10 "char" dup >r 10 0 0 XLookupString r> char-array>string ; + +: send-client-message ( atom x -- ) + +"XClientMessageEvent" ! atom x event + +ClientMessage over set-XClientMessageEvent-type +win get over set-XClientMessageEvent-window +rot over set-XClientMessageEvent-message_type ! x event +32 over set-XClientMessageEvent-format +swap over set-XClientMessageEvent-data0 ! event +CurrentTime over set-XClientMessageEvent-data1 ! event + +>r dpy get win get False NoEventMask r> XSendEvent drop ; \ No newline at end of file