Window titles and close buttons for frames in Factory

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 <wm-child> received a property event" print flush drop drop ;
+M: wm-child handle-property-event ( event <wm-child> -- )
+  "A <wm-child> 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 ( <wm-frame> -- )
+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

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 ;
@@ -376,3 +377,5 @@ dup pwindow-expose-action call ;
 : get-transient-for-hint% [ get-transient-for-hint ] with-window-object ;
 
 : fetch-name%			[ fetch-name ] with-window-object ;
+
+: clear-window%			[ clear-window ] with-window-object ;

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" <c-object> 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 <Window> dup >r XGetTransientForHint r>
   swap 0 = [ drop f ] [ *Window ] if ;
 
+! 14.1.10.  Setting and Reading the WM_PROTOCOLS Property
+
+: <Atom**> ( value -- address ) <Atom> <void*> ;
+
+: get-wm-protocols ( -- protocols )
+dpy get win get 0 <Atom**> 0 <int> 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" <c-array> dup >r 10 0 <alien> 0 <alien> XLookupString r>
 char-array>string ;
+
+: send-client-message ( atom x -- )
+
+"XClientMessageEvent" <c-object>			! 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 ;