[STUMP] Groups are virtual desktops

[Magnus Henoch]

The attached patch makes stumpwm's groups behave like wm-spec's
virtual desktops.  In particular, "wmctrl -d" lists the groups,
"wmctrl -s FOO" switches to group FOO (name or number), and "wmctrl -r
WIN -t GROUP" moves window WIN to group GROUP.

wmspec requires virtual desktop numbers to be continuous and start
from 0, so I enforce that on group numbers too.

Magnus

cvs diff: Diffing .
Index: core.lisp
===================================================================
RCS file: /cvsroot/stumpwm/stumpwm/core.lisp,v
retrieving revision 1.148
diff -u -r1.148 core.lisp
--- core.lisp   13 Jun 2007 06:00:22 -0000      1.148
+++ core.lisp   18 Jun 2007 21:27:20 -0000
@@ -140,7 +140,7 @@
 
 (defun find-free-group-number (screen)
   "Return a free window number for GROUP."
-  (find-free-number (mapcar 'group-number (screen-groups screen)) 1))
+  (find-free-number (mapcar #'group-number (screen-groups screen)) 0))
 
 (defun group-current-window (group)
   (frame-window (tile-group-current-frame group)))
@@ -162,6 +162,9 @@
       (setf (screen-focus screen) nil)
       (focus-frame new-group (tile-group-current-frame new-group))
       (show-frame-indicator new-group)
+      (xlib:change-property (screen-root screen) :_NET_CURRENT_DESKTOP
+                          (list (group-number new-group))
+                         :cardinal 32)
       (run-hook-with-args *focus-group-hook* new-group old-group))))
 
 (defun move-window-to-group (window to-group)
@@ -181,9 +184,12 @@
       (when (eq (frame-window old-frame) window)
        (setf (frame-window old-frame) (first (frame-windows old-group 
old-frame)))
        (focus-frame old-group old-frame))
-      ;; maybe show the window in it's new frame
+      ;; maybe show the window in its new frame
       (when (null (frame-window (window-frame window)))
-        (frame-raise-window (window-group window) (window-frame window) 
window)))))
+        (frame-raise-window (window-group window) (window-frame window) 
window))
+      (xlib:change-property (window-xwin window) :_NET_WM_DESKTOP
+                           (list (group-number to-group))
+                           :cardinal 32))))
 
 (defun next-group (current &optional (list (screen-groups (group-screen 
current))))
   (let ((matches (member current list)))
@@ -203,7 +209,22 @@
   (when (> (length (screen-groups (group-screen group))) 1)
     (let ((screen (group-screen group)))
       (merge-groups group to-group)
-      (setf (screen-groups screen) (remove group (screen-groups screen))))))
+      (setf (screen-groups screen) (remove group (screen-groups screen)))
+      (renumber-groups screen)
+      (set-group-properties screen))))
+
+(defun renumber-groups (screen)
+  "By the NETWM standard, group numbers are continuous from 0."
+  (let ((sorted-groups (sort-groups screen)))
+    (loop for i from 0
+       for group in sorted-groups
+       do (when (/= i (group-number group))
+           (setf (group-number group) i)
+           ;; group number has changed; update window properties
+           (dolist (w (group-windows group))
+             (xlib:change-property (window-xwin w) :_NET_WM_DESKTOP
+                                   (list i)
+                                   :cardinal 32))))))
 
 (defun add-group (screen name)
   (check-type screen screen)
@@ -216,8 +237,33 @@
              :number (find-free-group-number screen)
              :name name)))
     (setf (screen-groups screen) (append (screen-groups screen) (list ng)))
+    (set-group-properties screen)
     ng))
 
+(defun set-group-properties (screen)
+  "Set NETWM properties regarding groups of SCREEN.
+Groups are known as \"virtual desktops\" in the NETWM standard."
+  (let ((root (screen-root screen)))
+    ;; _NET_NUMBER_OF_DESKTOPS
+    (xlib:change-property root :_NET_NUMBER_OF_DESKTOPS 
+                         (list (length (screen-groups screen)))
+                         :cardinal 32)
+
+    ;; _NET_CURRENT_DESKTOP
+    (xlib:change-property root :_NET_CURRENT_DESKTOP
+                          (list (group-number (screen-current-group screen)))
+                         :cardinal 32)
+
+    ;; _NET_DESKTOP_NAMES
+    (xlib:change-property root :_NET_DESKTOP_NAMES
+                         (let ((names (mapcan
+                                       (lambda (group)
+                                         (list (string-to-utf8 (group-name 
group))
+                                               '(0)))
+                                       (screen-groups screen))))
+                           (apply #'concatenate 'list names))
+                         :UTF8_STRING 8)))
+
 (defun find-group (screen name)
   "Return the group with the name, NAME. Or NIL if none exists."
   (find name (screen-groups screen) :key 'group-name :test 'string=))
@@ -698,6 +744,9 @@
     (setf (xwin-state xwin) +iconic-state+)
     ;; put the window at the end of the list
     (setf (group-windows group) (append (group-windows group) (list window)))
+    (xlib:change-property xwin :_NET_WM_DESKTOP
+                         (list (group-number group))
+                         :cardinal 32)
     window))
 
 (defun pick-prefered-frame (group)
@@ -807,6 +856,19 @@
     (when (window-in-current-group-p window)
       ;; since the window doesn't exist, it doesn't have focus.
       (setf (screen-focus screen) nil))
+    ;; update _NET_CLIENT_LIST
+    (let* ((root-window (xlib:screen-root (screen-number screen)))
+          (client-list (xlib:get-property root-window
+                                          :_NET_CLIENT_LIST
+                                          :type :window)))
+      (xlib:change-property root-window
+                           :_NET_CLIENT_LIST
+                           (remove (xlib:drawable-id (window-xwin window))
+                                   client-list)
+                           :window 32
+                           :mode :replace))
+    ;; remove _NET_WM_DESKTOP property
+    (xlib:delete-property (window-xwin window) :_NET_WM_DESKTOP)
     ;; If the current window was removed, then refocus the frame it
     ;; was in, since it has a new current window
     (when (eq (tile-group-current-frame group) f)
@@ -1786,16 +1848,17 @@
   "Return the current screen."
   (car *screen-list*))
 
-(defun net-set-properties (screen-number focus-window)
+(defun net-set-properties (screen focus-window)
   "Set NETWM properties on the root window of the specified screen.
 FOCUS-WINDOW is an extra window used for _NET_SUPPORTING_WM_CHECK."
-  (let ((root (xlib:screen-root screen-number)))
+  (let* ((screen-number (screen-number screen))
+        (root (xlib:screen-root screen-number)))
     ;; _NET_SUPPORTED
     (xlib:change-property root :_NET_SUPPORTED
                           (mapcar (lambda (a)
                                     (xlib:intern-atom *display* a))
                                   (append +netwm-supported+
-                                          (mapcar 'car +netwm-window-types+)))
+                                          (mapcar #'car +netwm-window-types+)))
                           :atom 32)
  
     ;; _NET_SUPPORTING_WM_CHECK
@@ -1814,10 +1877,7 @@
                           () :window 32
                           :transform #'xlib:drawable-id)
     ;; TODO: _NET_CLIENT_LIST_STACKING
- 
-    ;; _NET_NUMBER_OF_DESKTOPS
-    (xlib:change-property root :_NET_NUMBER_OF_DESKTOPS (list 1) :cardinal 32)
- 
+
     ;; _NET_DESKTOP_GEOMETRY
     (xlib:change-property root :_NET_DESKTOP_GEOMETRY
                           (list (xlib:screen-width screen-number)
@@ -1827,9 +1887,8 @@
     ;; _NET_DESKTOP_VIEWPORT
     (xlib:change-property root :_NET_DESKTOP_VIEWPORT
                           (list 0 0) :cardinal 32)
-    ;; _NET_CURRENT_DESKTOP
-    (xlib:change-property root :_NET_CURRENT_DESKTOP
-                          (list 0) :cardinal 32)))
+    
+    (set-group-properties screen)))
 
 (defun init-screen (screen-number id host)
   "Given a screen number, returns a screen structure with initialized members"
@@ -1874,7 +1933,7 @@
         (font (xlib:open-font *display* +default-font-name+))
         (group (make-tile-group
                 :screen screen
-                :number 1
+                :number 0
                 :name "Default")))
     ;; Create our screen structure
     ;; The focus window is mapped at all times
@@ -1911,7 +1970,7 @@
                                     :background (xlib:alloc-color 
(xlib:screen-default-colormap screen-number) +default-background-color+)))
     (setf (tile-group-frame-tree group) (make-initial-frame screen)
           (tile-group-current-frame group) (tile-group-frame-tree group))
-    (net-set-properties screen-number focus-window)
+    (net-set-properties screen focus-window)
     screen))
 
 
@@ -2295,6 +2348,31 @@
        (incf (window-unmap-ignores win)))
       (xlib:reparent-window (window-xwin win) (window-parent win) 0 0))))
 
+(define-stump-event-handler :client-message (window type #|format|# data)
+  (dformat 2 "client message: ~s ~s~%" type data)
+  (case type
+    (:_NET_CURRENT_DESKTOP             ;switch desktop
+     (let ((group-number (elt data 0))
+          (screen (find-screen window)))
+       (when screen
+        (let ((group (find group-number (screen-groups screen)
+                           :key #'group-number)))
+          (when group
+            (switch-to-group group))))))
+    (:_NET_WM_DESKTOP                  ;move window to desktop
+     (let* ((group-number (elt data 0))
+           (our-window (find-window window))
+           (screen (when our-window
+                     (window-screen our-window)))
+           (group (when screen
+                    (find group-number (screen-groups screen)
+                          :key #'group-number))))
+       (when (and our-window group)
+        (move-window-to-group our-window group))))
+       
+    (t
+     (dformat 2 "ignored message~%"))))
+
 (define-stump-event-handler :focus-out (window mode kind)
   (dformat 5 "address@hidden ~}~%" window mode kind))
 
Index: primitives.lisp
===================================================================
RCS file: /cvsroot/stumpwm/stumpwm/primitives.lisp,v
retrieving revision 1.81
diff -u -r1.81 primitives.lisp
--- primitives.lisp     13 May 2007 04:43:12 -0000      1.81
+++ primitives.lisp     18 Jun 2007 21:27:21 -0000
@@ -720,6 +720,15 @@
   #-sbcl
   (map 'string #'code-char octets))
 
+(defun string-to-utf8 (string)
+  "Convert the string to a vector of octets."
+  #+sbcl (sb-ext:string-to-octets
+         string
+         :external-format :utf-8)
+  ;; TODO: handle UTF-8 for other lisps
+  #-sbcl
+  (map 'list #'char-code string))
+
 (defvar *startup-message* "Welcome to The Stump Window Manager!"
   "StumpWM's startup message. Set to NIL to suppress.")
 
Index: user.lisp
===================================================================
RCS file: /cvsroot/stumpwm/stumpwm/user.lisp,v
retrieving revision 1.110
diff -u -r1.110 user.lisp
--- user.lisp   10 May 2007 10:36:14 -0000      1.110
+++ user.lisp   18 Jun 2007 21:27:21 -0000
@@ -1153,6 +1153,7 @@
          (define-key m (kbd "'") "gselect")
          (define-key m (kbd "m") "gmove")
          (define-key m (kbd "k") "gkill")
+         (define-key m (kbd "0") "gselect 0")
          (define-key m (kbd "1") "gselect 1")
          (define-key m (kbd "2") "gselect 2")
          (define-key m (kbd "3") "gselect 3")
@@ -1162,7 +1163,6 @@
          (define-key m (kbd "7") "gselect 7")
          (define-key m (kbd "8") "gselect 8")
          (define-key m (kbd "9") "gselect 9")
-         (define-key m (kbd "0") "gselect 10")
          m)))
 
 (defun group-forward (current list)