- added normalize-window/client signal

- replaced client icons with a pager for move-wm

src/manager.scm

@@ -198,23 +198,18 @@
 	 (if (and client window (window-exists? dpy window))
 	     (reparent-to-root dpy window))))
 
-      ((iconify-window)
+      ((iconify-window normalize-window maximize-window)
        (let* ((window (second msg))
 	      (client (find (lambda (c)
 			      (eq? window (client:window c)))
 			    (wm:clients wm))))
 	 (if client
 	     (send internal-out-channel
-		   (list 'iconify-client client)))))
+		   (list (case (first msg)
-
+			   ((iconify-window) 'iconify-client)
-      ((maximize-window)
+			   ((normalize-window) 'normalize-client)
-       (let* ((window (second msg))
+			   ((maximize-window) 'maximize-client))
-	      (client (find (lambda (c)
+			 client)))))
-			      (eq? window (client:window c)))
-			    (wm:clients wm))))
-	 (if client
-	     (send internal-out-channel
-		   (list 'maximize-client client)))))
       
       ((destroy-manager)
        (send-message+wait internal-out-channel '(deinit-manager))
@@ -268,6 +263,9 @@
 (define (wm-iconify-window wm window)
   (send (wm:in-channel wm) (list 'iconify-window window)))
 
+(define (wm-normalize-window wm window)
+  (send (wm:in-channel wm) (list 'normalize-window window)))
+
 (define (wm-maximize-window wm window)
   (send (wm:in-channel wm) (list 'maximize-window window)))
 
@@ -284,13 +282,14 @@
 ;; *** client ********************************************************
 
 (define-record-type client :client
-  (make-client window client-window in-channel data focused?)
+  (make-client window client-window in-channel data focused? wm-state)
   client?
   (window client:window set-client:window!)
   (client-window client:client-window)
   (in-channel client:in-channel)
   (data client:data set-client:data!)
-  (focused? client:focused? set-client:focused?!))
+  (focused? client:focused? set-client:focused?!)
+  (wm-state client:wm-state set-client:wm-state!))
 
 (define (set-client-focused?! wm client focused?)
   (let ((prev (client:focused? client)))
@@ -314,7 +313,13 @@
 					      (white-pixel dpy)
 					      (black-pixel dpy)))
 	 (in-channel (make-channel))
-	 (client (make-client window client-window in-channel #f #f)))
+	 (wm-state (let ((s.i (get-wm-state dpy window)))
+		     ;; TODO initial-state? see root-manager
+		     (if s.i
+			 (car s.i)
+			 (wm-state withdrawn))))
+	 (client (make-client window client-window in-channel #f #f
+			      wm-state)))
     ;; transparent by default.
     (set-window-background-pixmap! dpy client-window parent-relative)
     (define-cursor dpy client-window

src/move-wm-pager.scm

@@ -0,0 +1,214 @@
+(define-record-type move-wm-pager :move-wm-pager
+  (make-move-wm-pager dpy window wm in-channel options buttons-alist width)
+  move-wm-pager?
+  (dpy pager:dpy)
+  (window pager:window)
+  (wm pager:wm)
+  (in-channel pager:in-channel)
+  (options pager:options)
+  ;; client -> button
+  (buttons-alist pager:buttons-alist set-pager:buttons-alist!)
+  (width pager:width set-pager:width!))
+
+;; TODO: hide buttons/keys
+;; TODO: client-name <-> WM_ICON_NAME?
+
+(define (repeat-infinitely fun) ;; -> utils
+  (call-with-current-continuation
+   (lambda (exit)
+     (let loop ()
+       (fun exit)
+       (loop)))))
+
+(define (create-move-wm-pager wm out-channel options)
+  (let* ((dpy (wm:dpy wm))
+	 (parent (wm:window wm))
+	 (rect (calc-pager-rect wm))
+	 (bg-color (first (get-option-value options 'pager-colors)))
+	 (window (create-simple-window dpy parent
+				       (rectangle:x rect) (rectangle:y rect)
+				       (rectangle:width rect)
+				       (rectangle:height rect)
+				       0 (black-pixel dpy)
+				       bg-color))
+	 (in-channel (make-channel))
+	 (gc (create-gc dpy window '()))
+	 (colormap (screen:default-colormap (display:default-screen dpy)))
+	 (pager (make-move-wm-pager dpy window wm in-channel options '()
+				    (rectangle:width rect))))
+    (spawn*
+     (list 'move-wm-pager wm window)
+     (lambda (release)
+       (call-with-event-channel
+	dpy window
+	(event-mask exposure
+		    button-press button-release
+		    visibility-change)
+	(lambda (window-channel)
+	  (release)
+	  (repeat-infinitely
+	   (lambda (exit)
+	     (select*
+	      (wrap (receive-rv in-channel)
+		    (lambda (msg)
+		      (cond
+		       ((and (pair? (first msg))
+			     (eq? 'button (car (first msg))))
+			(let ((client (cdr (first msg)))
+			      (time (second msg))
+			      (event (third msg)))
+			  (pager-action pager client time event)))
+		       ((not (pair? (first msg)))
+			(case (first msg)
+			  ((add-client)
+			   (let* ((client (second msg))
+				  (button (pager-create-button
+					   pager client
+					   (make-rectangle 0 0 1 1))))
+			     (set-pager:buttons-alist!
+			      pager
+			      (append (pager:buttons-alist pager)
+				      (list (cons client button))))
+			     (pager-refit-buttons pager)
+			     (map-button button)))
+			  ((remove-client)
+			   (let* ((client (second msg))
+				  (button (assq/false
+					   client
+					   (pager:buttons-alist pager))))
+			     (set-pager:buttons-alist!
+			      pager
+			      (alist-delete client
+					    (pager:buttons-alist pager)))
+			     (if button
+				 (begin
+				   (destroy-button button)
+				   (pager-refit-buttons pager))
+				 (warn "pager-remove-client: unknown client."
+				       pager client))))
+			  )))))
+
+	      (wrap (receive-rv window-channel)
+		    (lambda (xevent)
+		      (cond
+		       ((expose-event? xevent)
+			(if (zero? (expose-event-count xevent))
+			    (pager-draw pager gc)))
+		       ((destroy-window-event? xevent) ;; mask?
+			;; destroy-button not necessary
+			(exit))))))))
+	  (free-gc dpy gc)
+	  ;;(free-options options #t) ;; common with wm
+	  ))))
+    (map-window dpy window)
+    pager))
+
+(define (pager-create-button pager client rect)
+  (let* ((dpy (pager:dpy pager))
+	 (options (pager:options pager))
+	 (colors (get-option options 'pager-colors))
+	 (main-color (second colors))
+	 (light (third colors))
+	 (dark (fourth colors))
+	 (font-color (fifth colors)))
+    (create-button (pager:dpy pager) (pager:window pager)
+		   (screen:default-colormap (display:default-screen dpy))
+		   rect (pager:in-channel pager)
+		   (cons 'button client)
+		   `(;; TODO: don't let every button allocate the
+		     ;; colors, and load the font.
+		     (up-colors . ,(list main-color light dark font-color))
+		     (down-colors . ,(list main-color dark light font-color))
+		     (font . ,(get-option options 'font))
+		     (content . ,(client-name (pager:dpy pager) client))
+		     (type . switch)
+		     (initial-state . up)))))
+
+(define (calc-pager-rect wm)
+  (let ((dpy (wm:dpy wm))
+	(window (wm:window wm))
+	(options (wm:options wm))) ;; wm-options = pager-options!?
+    (let* ((g (get-geometry dpy window))
+	   (width (vector-ref g 3))
+	   (height (vector-ref g 4))
+	   (pager-height (get-option-value options 'pager-height)))
+      (make-rectangle 0 (- height pager-height)
+		      width pager-height))))
+
+(define (pager-action pager client time event) ;, event??
+  (let ((wm (pager:wm pager)))
+  ;; normalize/iconify directly via client?!
+    (if (eq? (client:wm-state client)
+	     (wm-state iconic))
+	(begin
+	  (wm-normalize-window wm (client:window client))
+	  (wm-select-client wm client time))
+	(if (client:focused? client) ;; this should better be "on top?"
+	    ;; select a different one?
+	    (wm-iconify-window wm (client:window client))
+	    (wm-select-client wm client time)))))
+
+(define (pager-draw pager gc)
+  (clear-window (pager:dpy pager) (pager:window pager)))
+
+(define (pager-button-rects pager)
+  (let ((alist (pager:buttons-alist pager))
+	(options (pager:options pager)))
+    (if (null? alist)
+	'()
+	(let* ((width (pager:width pager))
+	       (bwidth (min (get-option-value options
+					      'pager-maximum-button-width)
+			    (- (quotient width (length alist)) 2)))
+	       (bheight (- (get-option-value options 'pager-height) 4))
+	       (x 2)
+	       (y 2))
+	  (map (lambda (c.b)
+		      (let ((r (make-rectangle x y bwidth bheight)))
+			(set! x (+ x bwidth 2))
+			(cons (cdr c.b) r)))
+		    alist)))))
+
+(define (pager-refit-buttons pager)
+  (for-each (lambda (b.r)
+	      (move-resize-button (car b.r) (cdr b.r)))
+	    (pager-button-rects pager)))
+
+;; "external functions"
+
+(define (pager-refit pager)
+  (let ((r (calc-pager-rect (pager:wm pager))))
+    (set-pager:width! pager (rectangle:width r))
+    (move-resize-window (pager:dpy pager) (pager:window pager)
+		   (rectangle:x r) (rectangle:y r)
+		   (rectangle:width r) (rectangle:height r))
+    (pager-refit-buttons pager)))
+
+(define (pager-add-client pager client)
+  (send (pager:in-channel pager)
+	(list 'add-client client)))
+
+(define (pager-remove-client pager client)
+  (send (pager:in-channel pager)
+	(list 'remove-client client)))
+
+(define (pager-update-button pager button client)
+  (if (eq? (client:wm-state client)
+	   (wm-state iconic))
+      (button-set-state! button 'down)
+      (button-set-state! button 'up))
+  (button-set-content! button
+		       (client-name (pager:dpy pager) client)))
+
+(define (pager-update-client pager client)
+  (let ((button (assq/false client (pager:buttons-alist pager))))
+    (if button
+	(pager-update-button pager button client)
+	(warn "pager-update-client: unknown client" pager client))))
+
+(define (pager-update pager)
+  (for-each (lambda (c.b)
+	      (let ((client (car c.b))
+		    (button (cdr c.b)))
+		(pager-update-button pager button client)))
+	    (pager:buttons-alist pager)))

src/move-wm.scm

@@ -8,6 +8,10 @@
   (corner-width int 10)
   (border-style symbol 'raised) ;; raised | sunken | flat
   (border-colors colors '("#333333" "#dddddd"))
+  (pager-colors colors ;; bg, button, light, dark, font
+		'("#808080" "#aaaaaa" "#eeeeee" "#777777" "black"))
+  (pager-maximum-button-width int 140)
+  (pager-height int 24)
   )
 
 (define (create-move-wm out-channel dpy parent options default-options
@@ -24,7 +28,9 @@
 (define (init-move-wm wm channel)
   (let* ((dpy (wm:dpy wm))
 	 (window (wm:window wm))
-	 (gc (create-gc dpy window '())))
+	 (gc (create-gc dpy window '()))
+	 (pager-channel (make-channel))
+	 (pager (create-move-wm-pager wm pager-channel (wm:options wm))))
     (spawn* (list 'move-wm wm)
 	    (lambda (release)
 	      (release)
@@ -32,18 +38,18 @@
 	       (lambda (exit)
 		 (let loop ()
 		   (let ((msg (receive channel)))
-		     (handle-message wm gc exit msg)
+		     (handle-message wm pager gc exit msg)
 		     (loop)))))
 	      (free-gc dpy gc)))))
 
-(define (handle-message wm gc exit msg)
+(define (handle-message wm pager gc exit msg)
   (let ((dpy (wm:dpy wm))
 	(window (wm:window wm)))
     (case (car msg)
       ((wait)
        (let ((sp (second msg))
 	     (message (third msg)))
-	 (handle-message wm gc
+	 (handle-message wm pager gc
 			 (lambda args
 			   (sync-point-release sp)
 			   (apply exit args))
@@ -60,13 +66,21 @@
       ((fit-windows)
        (map (lambda (client)
 	      (assert-client-visible wm client))
-	    (wm-clients wm)))
+	    (wm-clients wm))
+       (pager-refit pager))
       
       ((init-client)
-       (init-client wm (second msg) (third msg)))
+       (let ((client (second msg))
+	     (maybe-rect (third msg)))
+	 (init-client wm client maybe-rect)
+	 (pager-add-client pager client)
+	 ;; for (properly) transient windows this would not be necessary:
+	 (wm-select-client wm client current-time)))
       
       ((deinit-client)
-       (deinit-client wm (second msg)))
+       (let ((client (second msg)))
+	 (deinit-client wm client)
+	 (pager-remove-client pager client)))
       
       ((configure-window)
        (let ((window (second msg))
@@ -139,30 +153,30 @@
 
       ((iconify-client)
        (let ((client (second msg)))
-	 (if (not (client-data:icon client))
+	 (if (not (eq? (client:wm-state client) (wm-state iconic)))
 	     (begin
 	       (unmap-window dpy (client:client-window client))
 	       (unmap-window dpy (client:window client))
 	       (set-wm-state! dpy (client:window client) (wm-state iconic)
 			      none)
-	       (let ((icon (create-client-icon wm client)))
+	       (set-client:wm-state! client (wm-state iconic))))
-		 (set-client-data:icon! client icon)
+	 (pager-update-client pager client)))
-		 (map-icon icon))))))
 
       ((maximize-client)
+       ;; TODO: maybe exclude pager?
        (let ((client (second msg)))
 	 (maximize-window dpy (client:client-window client))))
 
       ((normalize-client)
        (let ((client (second msg)))
-	 (if (client-data:icon client)
+	 (if (not (eq? (client:wm-state client) (wm-state normal)))
 	     (begin
-	       (destroy-icon (client-data:icon client))
 	       (map-window dpy (client:window client))
 	       (map-window dpy (client:client-window client))
 	       (set-wm-state! dpy (client:window client) (wm-state normal)
 			      none)
-	       (set-client-data:icon! client #f)))))
+	       (set-client:wm-state! client (wm-state normal))))
+	 (pager-update-client pager client)))
       
       ((draw-client-window)
        (draw-client-window wm (second msg) gc))
@@ -184,27 +198,29 @@
 			 'focused
 			 'normal))
 	      (titlebar (client-data:titlebar client)))
-	 (set-titlebar-state! titlebar state)))
+	 (set-titlebar-state! titlebar state)
+	 (pager-update-client pager client)))
       
       ((update-client-name)
        (let ((client (second msg))
 	     (name (third msg)))
 	 (let ((titlebar (client-data:titlebar client)))
-	   (set-titlebar-title! titlebar name))))
+	   (set-titlebar-title! titlebar name)
+	   (pager-update-client pager client))))
 
       ((show-clients)
        (let ((clients (second msg)))
 	 (for-each (lambda (c)
-		     (if (client-data:icon c)
+		     (if (eq? (client:wm-state c) (wm-state iconic))
-			 (handle-message wm gc exit
+			 (handle-message wm pager gc exit
 					 (list 'normalize-client c)))
 		     (raise-window dpy (client:client-window c)))
 		   clients)))
       
       (else (warn "unhandled move-wm message" wm msg)))))
 
-(define (make-client-data titlebar resizer icon)
+(define (make-client-data titlebar resizer)
-  (list titlebar resizer icon))
+  (list titlebar resizer))
 
 (define (client-data:titlebar client)
   (first (client:data client)))
@@ -212,12 +228,6 @@
 (define (client-data:resizer client)
   (second (client:data client)))
 
-(define (client-data:icon client)
-  (third (client:data client)))
-
-(define (set-client-data:icon! client icon)
-  (set-car! (cddr (client:data client)) icon))
-
 (define (window-wants-decoration? dpy window)
   (cond
    ((get-motif-wm-hints dpy window) =>
@@ -234,7 +244,7 @@
 	   (titlebar (create-client-titlebar channel wm client))
 	   (resizer (create-resizer wm client))
 	   (options (wm:options wm)))
-      (set-client:data! client (make-client-data titlebar resizer #f))
+      (set-client:data! client (make-client-data titlebar resizer))
       (set-titlebar-title! titlebar (client-name dpy client))
       (let* ((bw (get-option-value options 'border-width))
 	     (th (get-option-value options 'titlebar-height))
@@ -310,13 +320,6 @@
   (let ((dpy (wm:dpy wm)))
     (set-input-focus dpy (wm:window wm) (revert-to parent) current-time)))
 
-(define (create-client-icon wm client)
-  (let* ((other-icons (filter (lambda (x) x)
-			      (map client-data:icon (wm-clients wm))))
-	 (r (find-icon-rect (clip-rectangle (wm:dpy wm) (wm:window wm))
-			    other-icons)))
-    (create-icon wm client r)))
-
 ;; ***
 
 (define (fit-client-windows wm client)
@@ -360,7 +363,6 @@
 	 (y (window-y dpy win))
 	 (w (window-width dpy (wm:window wm)))
 	 (h (window-height dpy (wm:window wm))))
-    ;; TODO: assert-icon-visible ...
     (if (>= x w)
 	(set-window-x! dpy win (- w 10)))
     (if (>= y h)
@@ -432,7 +434,8 @@
 		       (window-rectangle dpy (client:client-window client)))
 		     (filter (lambda (c)
 			       (and (not (eq? c client))
-				    (not (client-data:icon c))))
+				    (not (eq? (client:wm-state c)
+					      (wm-state iconic)))))
 			     (wm-clients wm))))
 	 (list1 (map (lambda (x.y)
 		       (make-rectangle (car x.y) (cdr x.y) w h))

src/packages.scm

@@ -72,8 +72,11 @@
 (define-structure button
   (export create-button destroy-button
 	  map-button unmap-button
-	  move-resize-button)
+	  move-resize-button
+	  button-get-state button-set-state!
+	  button-set-content!)
   (open scheme list-lib rendezvous-channels
+	rendezvous placeholders
 	define-record-types
 	xlib
 	utils)
@@ -118,13 +121,16 @@
 	  create-wm destroy-wm
 	  wm-clients wm-current-client
 	  wm-manage-window wm-unmanage-window wm-select-client
-	  wm-configure-window wm-iconify-window wm-maximize-window
+	  wm-configure-window
+	  wm-iconify-window wm-normalize-window wm-maximize-window
 	  wm-deinit-client
 
 	  ignore-next-enter-notify!
 
 	  client? client:window client:client-window
 	  client:data set-client:data!
+	  client:wm-state set-client:wm-state!
+	  client:focused?
 	  client-name find-window-by-name get-all-window-names
 	  client-replace-window
 	  client-of-window)
@@ -143,13 +149,13 @@
   (export create-move-wm)
   (open scheme list-lib define-record-types signals
 	threads rendezvous-channels rendezvous
-	xlib
+	xlib button
 	manager key-grab
-	utils dragging titlebar
+	utils dragging titlebar button
 	motif enum-sets)
   (files move-wm
 	 move-wm-resizer
-	 move-wm-icon))
+	 move-wm-pager))
 
 ;; *** split manager *************************************************