orion-wm/src/move-wm.scm

(define-options-spec move-wm-options-spec
  (titlebar-colors colors '("#aaaaaa" "#eeeeee" "#777777" "black"))
  (titlebar-colors-focused colors '("#666699" "#aaaacc" "#333366" "#eeeeee"))
  (titlebar-height int 18)
  (titlebar-style symbol 'flat)
  (font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*")
  (border-width int 3)
  (corner-width int 10)
  (border-style symbol 'raised) ;; raised | sunken | flat
  (border-colors colors '("#333333" "#dddddd"))
  )

(define (create-move-wm out-channel dpy parent options default-options
			. children)
  (create-wm dpy parent options (append default-options
					'((focus-policy . (click))))
	     children
	     (manager-type move) move-wm-options-spec
	     out-channel
	     (lambda (wm in-channel)
	       (init-move-wm wm in-channel)
	       wm)))

(define (init-move-wm wm channel)
  (let* ((dpy (wm:dpy wm))
	 (window (wm:window wm))
	 (gc (create-gc dpy window '())))
    (spawn* (list 'move-wm wm)
	    (lambda (release)
	      (release)
	      (call-with-current-continuation
	       (lambda (exit)
		 (let loop ()
		   (let ((msg (receive channel)))
		     (handle-message wm gc exit msg)
		     (loop)))))
	      (free-gc dpy gc)))))

(define (handle-message wm 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
			 (lambda args
			   (sync-point-release sp)
			   (apply exit args))
			 message)
	 (sync-point-release sp)))
      
      ((deinit-manager)
       (exit 'deinit-manager))

      ((draw-main-window) #t)

      ((update-manager-state) #t)
      
      ((fit-windows)
       (map (lambda (client)
	      (assert-client-visible wm client))
	    (wm-clients wm)))
      
      ((init-client)
       (init-client wm (second msg) (third msg)))
      
      ((deinit-client)
       (deinit-client wm (second msg)))
      
      ((configure-window)
       (let ((window (second msg))
	     (changes (third msg))
	     (client? (client-of-window wm window)))
	 (if (window-exists? dpy window) (begin
	 (let* ((r (window-rectangle dpy window))
		(dx (cond
		     ((assq (window-change x) changes) =>
		      (lambda (c.x) (- (cdr c.x) (rectangle:x r))))
		     (else 0)))
		(dy (cond
		     ((assq (window-change y) changes) =>
		      (lambda (c.y) (- (cdr c.y) (rectangle:y r))))
		     (else 0)))
		(dw (cond
		     ((assq (window-change width) changes) =>
		      (lambda (c.w) (- (cdr c.w) (rectangle:width r))))
		     (else 0)))
		(dh (cond
		     ((assq (window-change height) changes) =>
		      (lambda (c.h) (- (cdr c.h) (rectangle:height r))))
		     (else 0)))
		(send-synthetic-event
		 (lambda ()
		   (let ((r (root-rectangle dpy window)))
		     (send-event dpy window #f (event-mask structure-notify)
				 (create-configure-event
				  (event-type configure-notify) 0 #t dpy
				  window window
				  ;; TODO: border-width/gravity ?
				  (rectangle:x r) (rectangle:y r)
				  (rectangle:width r) (rectangle:height r)
				  0 none #f))))))
	   (cond
	    ((or (assq (window-change width) changes)
		 (assq (window-change height) changes)
		 (assq (window-change border-width) changes))
	     (if client?
		 (let* ((cw (client:client-window client?))
			(cr (window-rectangle dpy cw)))
		   (configure-window
		    dpy cw
		    (append (make-window-change-alist
			     (border-width 0)
			     (x (+ (rectangle:x cr) dx))
			     (y (+ (rectangle:y cr) dy))
			     (width (+ (rectangle:width cr) dw))
			     (height (+ (rectangle:height cr) dh)))
			    changes)))
		 (configure-window dpy window
				   (append (make-window-change-alist
					    (border-width 0))
					   changes))))
	    ((or (assq (window-change x) changes)
		 (assq (window-change y) changes)
		 (assq (window-change stack-mode) changes))
	     (if client?
		 (let* ((cw (client:client-window client?))
			(cr (window-rectangle dpy cw)))
		   (configure-window
		    dpy cw
		    (append (make-window-change-alist
			     (border-width 0)
			     (x (+ (rectangle:x cr) dx))
			     (y (+ (rectangle:y cr) dy)))
			    changes))))
	     (send-synthetic-event))
	    (else (send-synthetic-event))))))))

      ((iconify-client)
       (let ((client (second msg)))
	 (if (not (client-data:icon client))
	     (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-data:icon! client icon)
		 (map-icon icon))))))

      ((maximize-client)
       (let ((client (second msg)))
	 (maximize-window dpy (client:client-window client))))

      ((normalize-client)
       (let ((client (second msg)))
	 (if (client-data:icon client)
	     (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)))))
      
      ((draw-client-window)
       (draw-client-window wm (second msg) gc))
      
      ((fit-client)
       ;; client-window changed it's size
       (fit-client-windows wm (second msg)))
      
      ((fit-client-window)
       ;; client changed it's size ??
       (fit-client-window wm (second msg)))
      
      ((manager-focused) #t)
      
      ((update-client-state)
       (let* ((client (second msg))
	      (focused? (third msg))
	      (state (if focused?
			 'focused
			 'normal))
	      (titlebar (client-data:titlebar client)))
	 (set-titlebar-state! titlebar state)))
      
      ((update-client-name)
       (let ((client (second msg))
	     (name (third msg)))
	 (let ((titlebar (client-data:titlebar client)))
	   (set-titlebar-title! titlebar name))))

      ((show-clients)
       (let ((clients (second msg)))
	 (for-each (lambda (c)
		     (if (client-data:icon c)
			 (handle-message wm 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)
  (list titlebar resizer icon))

(define (client-data:titlebar client)
  (first (client:data client)))

(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) =>
    (lambda (hints)
      (mdisplay (motif-wm-hints:decorations hints) "\n")
      (or (not (motif-wm-hints:decorations hints))
	  (not (null? (enum-set->list (motif-wm-hints:decorations hints)))))))
   (else #t)))

(define (init-client wm client maybe-rect)
  (let ((dpy (wm:dpy wm)))
    (let* ((r (initial-client-rect wm client maybe-rect))
	   (channel (make-channel))
	   (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-titlebar-title! titlebar (client-name dpy client))
      (let* ((bw (get-option-value options 'border-width))
	     (th (get-option-value options 'titlebar-height))
	     (x.y (if (window-wants-decoration? dpy (client:window client))
		      (cons (rectangle:x r) (rectangle:y r))
		      (cons (- (rectangle:x r) bw)
			    (- (rectangle:y r) (+ bw th))))))
	(move-resize-window dpy (client:client-window client)
			    (car x.y) (cdr x.y)
			    (+ (rectangle:width r) (* 2 bw))
			    (+ (rectangle:height r) (* 2 bw) th)))
      (fit-client-windows wm client)

      (install-dragging-control channel dpy
				(titlebar:window titlebar)
				(client:client-window client))
      (spawn*
       (list 'move-wm-client-handler wm client)
       (lambda (release)
	 (release)
	 (let loop ()
	   (select*
	    (wrap (receive-rv channel)
		  (lambda (msg)
		    (case (car msg)
		     ((drop)
		      ;; check if outside...
		      (let ((window-x (second msg))
			    (window-y (third msg))
			    (root-x (fourth msg))
			    (root-y (fifth msg)))
			(let ((r (root-rectangle dpy (wm:window wm))))
			  (if (point-in-rectangle? r root-x root-y)
			      (move-window dpy (client:client-window client)
					   window-x window-y)
			      (send (wm:out-channel wm)
				    (list 'root-drop (client:window client)
					  root-x root-y))))))
		     ((click)
		      (wm-select-client wm client (fourth msg)))
		     ;; from titlebar-buttons
		     ((kill)
		      (delete-window dpy (client:window client) (second msg)))
		     ((iconify)
		      (wm-iconify-window wm (client:window client)))
		     ((maximize)
		      (wm-maximize-window wm (client:window client)))
		     ))))
	   ;; TODO: internal channel
	   (loop))
	 (destroy-resizer dpy resizer)))
      
      (map-titlebar titlebar)
      (if (window-exists? dpy (client:window client))
	  (map-window dpy (client:window client)))
      (map-window dpy (client:client-window client)))))

(define (create-client-titlebar channel wm client)
  (let ((options (wm:options wm)))
    (create-titlebar channel (wm:dpy wm) (client:client-window client)
		     (wm:colormap wm)
		     (list (cons 'buttons '(kill maximize iconify))
			   (cons 'normal-colors
				 (get-option options 'titlebar-colors))
			   (cons 'active-colors
				 (get-option options'titlebar-colors-focused))
			   (cons 'focused-colors
				 (get-option options 'titlebar-colors-focused))
			   (cons 'border-style
				 (get-option options 'titlebar-style))))))

(define (deinit-client wm client)
  (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)
  (let* ((dpy (wm:dpy wm))
	 (options (wm:options wm))
	 (border-width (get-option-value options 'border-width))
	 (titlebar-height (get-option-value options 'titlebar-height))
	 (wa (get-window-attributes dpy (client:client-window client))))
    ;; TODO: is called much too often
    (if (window-exists? dpy (client:window client))
	(move-resize-window dpy (client:window client)
			    border-width
			    (+ border-width titlebar-height)
			    (- (window-attribute:width wa)
			       (* 2 border-width))  
			    (- (window-attribute:height wa)
			       (+ (* 2 border-width) titlebar-height))))
    (move-resize-titlebar
     (client-data:titlebar client)
     (make-rectangle border-width border-width
		     (- (window-attribute:width wa) (* 2 border-width))
		     titlebar-height))))

(define (fit-client-window wm client)
  (let* ((dpy (wm:dpy wm))
	 (options (wm:options wm))
	 (border-width (get-option-value options 'border-width))
	 (titlebar-height (get-option-value options 'titlebar-height)))
    (if (window-exists? dpy (client:window client))
	(let ((wa (get-window-attributes dpy (client:window client))))
	  (resize-window dpy (client:client-window client)
			 (+ (window-attribute:width wa) (* 2 border-width))
			 (+ (window-attribute:height wa)
			    (* 2 border-width)
			    titlebar-height))))))

(define (assert-client-visible wm client)
  (let* ((dpy (wm:dpy wm))
	 (win (client:client-window client))
	 (x (window-x dpy win))
	 (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)
	(set-window-y! dpy win (- h 10)))))

(define (draw-client-window wm client gc)
  (let* ((options (wm:options wm))
	 (colors (get-option-value options 'border-colors))
	 (window (client:client-window client))
	 (dpy (wm:dpy wm))
	 (border-style (get-option-value options 'border-style))
	 (border-width (get-option-value options 'border-width))
	 (clip-rect (clip-rectangle dpy window)))
    (if (not (eq? border-style 'flat))
	(let ((light (if (eq? border-style 'sunken)
			 (car colors) (cadr colors)))
	      (dark (if (eq? border-style 'sunken)
			(cadr colors) (car colors))))
	  (for-each (lambda (i)
		      (let ((r (make-rectangle
				(+ i (rectangle:x clip-rect))
				(+ i (rectangle:y clip-rect))
				(- (rectangle:width clip-rect) (* i 2))
				(- (rectangle:height clip-rect) (* i 2)))))
			(draw-shadow-rectangle dpy window gc
					       r light dark)))
		    (iota border-width))))))

(define (initial-client-rect wm client maybe-rect)
  (let* ((dpy (wm:dpy wm))
	 (win (client:window client))
	 (default-width (if maybe-rect (rectangle:width maybe-rect) 400))
	 (default-height (if maybe-rect (rectangle:height maybe-rect) 200))
	 (w.h (initial-client-size wm client default-width default-height))
	 ;; TODO: Transients centered?
	 (options (wm:options wm))
	 (maybe-x.y
	  (let* ((bw (get-option-value options 'border-width))
		 (th (get-option-value options 'titlebar-height))
		 (x.y (find-free-position wm client w.h '(0 . 0))))
	    x.y))
	 (x.y (desired-position/hints dpy win maybe-x.y)))
    (make-rectangle (car x.y) (cdr x.y)
		    (car w.h) (cdr w.h))))

(define (initial-client-size wm client default-width default-height)
  (let* ((dpy (wm:dpy wm))
	 (win (client:window client))
	 (w.h-1
	  (let ((w.h (minimal-size/hints dpy win default-width
					 default-height)))
	    (cons (if (< default-width (car w.h))
		      (car w.h)
		      default-width)
		  (if (< default-height (cdr w.h))
		      (cdr w.h)
		      default-height))))
	 (w.h (maximal-size/hints dpy win (car w.h-1) (cdr w.h-1))))
	 ;;(w.h (desired-size/hints dpy win w.h-2)))
    w.h))

(define (find-free-position wm client size default-pos)
  (let* ((dpy (wm:dpy wm))
	 (max-w (window-width dpy (wm:window wm)))
	 (max-h (window-height dpy (wm:window wm)))
	 (w (car size))
	 (h (cdr size))
	 (rects (map (lambda (client)
		       (window-rectangle dpy (client:client-window client)))
		     (filter (lambda (c)
			       (and (not (eq? c client))
				    (not (client-data:icon c))))
			     (wm-clients wm))))
	 (list1 (map (lambda (x.y)
		       (make-rectangle (car x.y) (cdr x.y) w h))
		     (possible-positions rects)))
	 (list2 (filter (lambda (r) (rect-ok? r rects))
			list1))
	 ;; list2 may contain rects that are outside the wm
	 (list3 (filter (lambda (r)
			  (not (or (> (+ (rectangle:x r) (rectangle:width r))
				      max-w)
				   (> (+ (rectangle:y r) (rectangle:height r))
				      max-h))))
			list2)))
    (if (null? list3)
	default-pos
	(let ((r (car list3)))
	  (cons (rectangle:x r) (rectangle:y r))))))

;; possible positions are all rect-corners except the upper left, and
;; all intersection points of all bottom and right sides of the rects.
(define (possible-positions rects)
  (let ((corners (flatten
		  (map (lambda (r)
			 (let* ((x1 (rectangle:x r))
				(y1 (rectangle:y r))
				(x2 (+ x1 (rectangle:width r)))
				(y2 (+ y1 (rectangle:height r))))
			   (list (cons x1 y2)
				 ;; (cons x2 y2) also included below
				 (cons x2 y1))))
		       rects)))
	(xs (map (lambda (r)
		   (+ (rectangle:x r) (rectangle:width r)))
		 rects))
	(ys (map (lambda (r)
		   (+ (rectangle:y r) (rectangle:height r)))
		 rects)))
    (append (list (cons 0 0))
	    corners
	    (flatten (map (lambda (x)
			    (map (lambda (y) (cons x y))
				 ys))
			  xs)))))

;; it's ok if it does not overlap with any rect
(define (rect-ok? rect rects)
  (not (any (lambda (r)
	      (rectangles-overlap? rect r))
	    rects)))