Window titles and close buttons for frames in Factory

diff --git a/contrib/factory/factory.factor b/contrib/factory/factory.factor
index 778e95cc5d314e51b5b703bc9ad0b52c0a5a4aaa..37799d40531489a8a0c25c104d0fa7124a27f9e0 100644 (file)
--- 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 <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

diff --git a/contrib/x11/concurrent-widgets.factor b/contrib/x11/concurrent-widgets.factor
index 9f2a378453bfef014ec575f1e8fd02bc6d5af8f4..a16b5edf543a963e17de847d4a90d3364fcd4296 100644 (file)
--- 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 c6e9a9a07fab3d3290a65dc1f38b5c54fd033602..8214449add348d6a6a41df63b0a1a4be48bdd7c0 100644 (file)
--- a/contrib/x11/x.factor
+++ b/contrib/x11/x.factor
@@ -26,10 +26,15 @@ SYMBOL: font
 : *Window *XID ;
 : *Drawable *XID ;
 
+: True 1 ;
+: False 0 ;
+
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 3.3 - Creating Windows
+! 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
 ! properties to liking, then do the flush. This way is opposed to
@@ -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 ;
\ No newline at end of file