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 . children)
  (create-wm dpy parent options children
	     (manager-type move) move-wm-options-spec
	     out-channel
	     (lambda (wm in-channel)
	       (spawn* (list 'move-wm wm)
		       (lambda (release)
			 (release)
			 (move-wm-handler wm in-channel)))
	       wm)))

(define (move-wm-handler wm channel)
  (let* ((dpy (wm:dpy wm))
	 (window (wm:window wm))
	 (gc (create-gc dpy window '())))
    (let loop ()
      (let ((msg (receive channel)))
	(case (car msg)
	  ((draw-main-window)
	   (set-gc-foreground! dpy gc (black-pixel dpy))
	   (fill-rectangle* dpy window gc
			    (clip-rectangle dpy window)))

	  ((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)))
	     ;; TODO: exact sizes ?!
	     (configure-window dpy window
			       (append (make-window-change-alist
					(border-width 0))
				       changes))))

	  ((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)))
	  
	  ((update-client-state)
	   (let* ((client (second msg))
		  (dpy (wm:dpy wm))
		  (window (client:window client))
		  (state (if (window-contains-focus? dpy window)
			     'focused
			     'normal))
		  (titlebar (car (client:data client)))
		  (name (client-name (wm:dpy wm) client)))
	     (set-titlebar-state! titlebar state)
	     (set-titlebar-title! titlebar name)))
	  ))
      (loop))
    (free-gc (wm:dpy wm) gc)))

(define (init-client wm client maybe-rect)
  (let ((dpy (wm:dpy wm)))
    (let* ((r (initial-client-rect wm (client:window 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 (list titlebar resizer))
      (move-resize-window dpy (client:client-window client)
			  (rectangle:x r) (rectangle:y r)
			  (rectangle:width r) (rectangle:height r))
      (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)))
		     ))))
	   ;; TODO: internal channel
	   (loop))))
      
      (map-titlebar titlebar)
      (map-window dpy (client:client-window client))
      ;;(select-client wm 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)
		     ;; TODO: buttons
		     (list (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)))
    #t))

;; ***

(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
    (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
     (car (client:data 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))
	 (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)))
    #t)) ;; ... TODO

(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 win maybe-rect)
  (if maybe-rect
      maybe-rect
      (let* ((dpy (wm:dpy wm))
	     (w.h (desired-size/hints dpy win
				      (maximal-size/hints dpy win 400 200)))
	     (x.y (desired-position/hints dpy win (cons 0 0))))
	(make-rectangle (car x.y) (cdr x.y)
			(car w.h) (cdr w.h)))))