scx/scheme/xlib/window.scm

;; Author: David Frese

;; create-window creates an unmapped subwindow for a specified parent
;; window. depth can be 'copy-from-parent. class can be one of
;; 'input-output, 'input-only or 'copy-from-parent. visual can be
;; 'copy-from-parent too (see create-simple-window). See
;; change-window-attributes and make-set-window-attribute-alist for
;; the attributes argument.

(define (create-window parent x y width height border-width depth class 
		       visual set-window-attribute-alist)
  (let ((attribs (set-window-attribute-alist->integer+vector
		  set-window-attribute-alist))
	(depth (cond
		((eq? depth 'copy-from-parent) #f)
		((number? depth) depth)
		(else (error "invalid depth" depth))))
	(class (case class
		 ((input-output) 0)
		 ((input-only) 1)
		 ((copy-from-parent) 2)
		 (else (error "invalid class specifier" class))))
	(visual (cond
		 ((eq? visual 'copy-from-parent) #f)
		 ((visual? visual) (visual-Xvisual visual))
		 (else (error "invalid visual") visual)))
	(display (window-display parent)))
    (let ((Xwindow (%create-window 
		    (display-Xdisplay display)
		    (window-Xwindow parent)
		    x y width height border-width
		    depth class visual
		    attribs)))
      (if (= Xwindow 0)
	  (error "cannot create window")
	  (make-window Xwindow display #t)))))

(import-lambda-definition %create-window 
  (Xdisplay Xparent x y width height border_width depth class Xvisual attribs)
  "scx_Create_Window")

;; create-simple-window calls create-window with the default value 1
;; for border-width, 0 for x and y, and 'copy-from-parent for depth,
;; class and visual.

(define (create-simple-window parent width height 
			      set-window-attribute-alist)
  (create-window parent 0 0 width height 0
		 'copy-from-parent 'copy-from-parent 'copy-from-parent
		 set-window-attribute-alist))

;; window-exists? returns #t if the windows still exists (makes sense,
;; doesn't it :-)

;; This version is easier and faster, but causes an X Protocol error,
;; if the window does not exist.
(define (window-exists? window)
  (and (integer? (window-Xwindow window)) ;; hasn't been destroyed by
					  ;; destroy-window
       (if (query-tree window)            ;; query-tree returns #f if
	   #t #f)))			  ;; the window does not
					  ;; exists.

; (define (window-exists? window)
;   (let ((dpy (window-display window)))
;     (letrec ((loop (lambda (w)
; 		     (or (eq? w window)
; 			 (any loop (window-children w))))))
;       (any loop (map (lambda (i)
; 		       (display-root-window dpy i))
; 		     (iota (display-screen-count dpy)))))))

;; Alternative version, seems to be slower
; (define (window-exists? window)
;   (let ((dpy (window-display window)))
;     (let loop ((candidates (map (lambda (i)
; 				  (display-root-window dpy i))
; 				(iota (display-screen-count dpy)))))
;       (cond
;        ((null? candidates) #f)
;        ((eq? (car candidates) window) #t)
;        (else (loop (append (cdr candidates)
; 			   (window-children (car candidates)))))))))

;; *** change-window-attributes **************************************

;; change-window-attributes takes an alist of set-window-attributes
;; mapping to specific values. See XChangeWindowAttributes.

(define (change-window-attributes window set-window-attribute-alist)
  (%change-window-attributes (window-Xwindow window)
			     (display-Xdisplay (window-display window))
			     (set-window-attribute-alist->integer+vector
			      set-window-attribute-alist)))

(import-lambda-definition %change-window-attributes (Xwindow Xdisplay attribs)
  "scx_Change_Window_Attributes")

;; simple functions that use change-window-attributes
;; TODO: a caching system for multiple calls to these functions

(define (make-win-attr-setter attribute)
  (lambda (window value)
    (change-window-attributes window (list (cons attribute value)))))

(define set-window-background-pixmap! 
  (make-win-attr-setter (set-window-attribute background-pixmap)))
(define set-window-background-pixel! 
  (make-win-attr-setter (set-window-attribute background-pixel)))
(define set-window-border-pixmap! 
  (make-win-attr-setter (set-window-attribute border-pixmap)))
(define set-window-border-pixel! 
  (make-win-attr-setter (set-window-attribute border-pixel)))
(define set-window-bit-gravity! 
  (make-win-attr-setter (set-window-attribute bit-gravity)))
(define set-window-gravity! 
  (make-win-attr-setter (set-window-attribute gravity)))
(define set-window-backing-store! 
  (make-win-attr-setter (set-window-attribute backing-store)))
(define set-window-backing-planes! 
  (make-win-attr-setter (set-window-attribute backing-planes)))
(define set-window-backing-pixel! 
  (make-win-attr-setter (set-window-attribute backing-pixel)))
(define set-window-save-under! 
  (make-win-attr-setter (set-window-attribute save-under)))
(define set-window-event-mask! 
  (make-win-attr-setter (set-window-attribute event-mask)))
(define set-window-do-not-propagate-mask! 
  (make-win-attr-setter (set-window-attribute do-not-propagate-mask)))
(define set-window-override-redirect! 
  (make-win-attr-setter (set-window-attribute override-redirect)))
(define set-window-colormap! 
  (make-win-attr-setter (set-window-attribute colormap)))
(define set-window-cursor! 
  (make-win-attr-setter (set-window-attribute cursor)))

;; *** configure-window **********************************************
;; This set the window-attributes.

(define (configure-window window window-change-alist)
  (%configure-window (window-Xwindow window)
		     (display-Xdisplay (window-display window))
		     (window-change-alist->integer+vector
		      window-change-alist)))

(import-lambda-definition %configure-window (Xwindow Xdisplay changes)
  "scx_Configure_Window")

;; the following mutators are based on configure-window

(define (make-win-configurer change)
  (lambda (window value)
    (configure-window window (list (cons change value)))))

(define set-window-x! (make-win-configurer (window-change x)))
(define set-window-y! (make-win-configurer (window-change y)))
(define set-window-width! (make-win-configurer (window-change width)))
(define set-window-height! (make-win-configurer (window-change height)))
(define set-window-border-width! 
  (make-win-configurer (window-change border-width)))
(define set-window-sibling! (make-win-configurer (window-change sibling)))
(define set-window-stack-mode! 
  (make-win-configurer (window-change stack-mode)))

;; *** get-window-attributes *****************************************
;; get-window-attributes returns attributes of the specified window.

(define (get-window-attributes window)
  (let ((Xwindow (window-Xwindow window))
	(Xdisplay (display-Xdisplay (window-display window))))
    (let ((values (%get-window-attributes Xdisplay Xwindow)))
      (if (not values)
	  #f
	  ((integer+vector->window-attribute-alist (window-display window))
	   values)))))

(import-lambda-definition %get-window-attributes (Xdisplay Xwindow)
  "scx_Get_Window_Attributes")

(define (make-win-attr-getter attribute)
  (lambda (window)
    (let ((attribs (get-window-attributes window)))
      (and attribs (cdr (assq attribute attribs))))))

(define window-x (make-win-attr-getter (window-attribute x)))
(define window-y (make-win-attr-getter (window-attribute y)))
(define window-width (make-win-attr-getter (window-attribute width)))
(define window-height (make-win-attr-getter (window-attribute height)))
(define window-border-width 
  (make-win-attr-getter (window-attribute border-width)))
(define window-depth (make-win-attr-getter (window-attribute depth)))
(define window-visual (make-win-attr-getter (window-attribute visual)))
(define window-root (make-win-attr-getter (window-attribute root)))
(define window-window-class (make-win-attr-getter (window-attribute class)))
(define window-bit-gravity 
  (make-win-attr-getter (window-attribute bit-gravity)))
(define window-gravity
  (make-win-attr-getter (window-attribute gravity)))
(define window-backing-store 
  (make-win-attr-getter (window-attribute backing-store)))
(define window-backing-planes 
  (make-win-attr-getter (window-attribute backing-planes)))
(define window-backing-pixel 
  (make-win-attr-getter (window-attribute backing-pixel)))
(define window-save-under (make-win-attr-getter (window-attribute save-under)))
(define window-colormap (make-win-attr-getter (window-attribute colormap)))
(define window-map-installed 
  (make-win-attr-getter (window-attribute map-installed)))
(define window-map-state (make-win-attr-getter (window-attribute map-state)))
(define window-all-event-masks 
  (make-win-attr-getter (window-attribute all-event-masks)))
(define window-your-event-mask 
  (make-win-attr-getter (window-attribute your-event-mask)))
(define window-do-not-propagate-mask 
  (make-win-attr-getter (window-attribute do-not-propagate-mask)))
(define window-override-redirect 
  (make-win-attr-getter (window-attribute override-redirect)))

;; some functions for easier access to the attributes

(define (window-mapped? window)
  (not (eq? (map-state is-unmapped) (window-map-state window))))
(define (window-viewable? window)
  (eq? (map-state is-viewable) (window-map-state window)))
(define (window-unviewable? window)
  (eq? (map-state is-unviewable) (window-map-state window)))

;; The map-window function maps the window and all of its subwindows
;; that have had map requests. See XMapWindow.

(define (map-window window)
  (%map-window (window-Xwindow window) 
	       (display-Xdisplay (window-display window))))

(import-lambda-definition %map-window (Xwindow Xdisplay)
  "scx_Map_Window")

;; The unmap-window function unmaps the specified window and causes
;; the X server to generate an unmap-notify event. See XUnmapWindow.

(define (unmap-window window)
  (%unmap-window (window-Xwindow window)
		 (display-Xdisplay (window-display window))))

(import-lambda-definition %unmap-window (Xwindow Xdisplay)
  "scx_Unmap_Window")

;; The destroy-subwindows function destroys all inferior windows of
;; the specified window, in bottom-to-top stacking order. See
;; XDestroySubWindows.

(define (destroy-subwindows window)
  (%destroy-subwindows (window-Xwindow window)
		       (display-Xdisplay (window-display window))))

(import-lambda-definition %destroy-subwindows (Xwindow Xdisplay)
  "scx_Destroy_Subwindows")

;; The map-subwindows function maps all subwindows for a specified
;; window in top-to-bottom stacking order. See XMapSubwindows

(define (map-subwindows window)
  (%map-subwindows (window-Xwindow window)
		   (display-Xdisplay (window-display window))))

(import-lambda-definition %map-subwindows (Xwindow Xdisplay)
  "scx_Map_Subwindows")

;; The unmap-subwindows function unmaps all subwindows for each
;; subwindow and expose events on formerly obscured windows. See
;; XUnmapSubwindow.

(define (unmap-subwindows window)
  (%unmap-subwindows (window-Xwindow window)
		     (display-Xdisplay (window-display window))))

(import-lambda-definition %unmap-subwindows (Xwindow Xdisplay)
  "scx_Unmap_Subwindows")

;; See XCirculateSubwindows.

(define (circulate-subwindows window direction)
  (%destroy-subwindows (window-Xwindow window)
		       (display-Xdisplay (window-display window))
		       (eq? direction 'lower-highest)))
		       ; other is: 'raise-lower / exception??

(import-lambda-definition %circulate-subwindows (Xwindow Xdisplay dir)
  "scx_Circulate_Subwindows")

;; The clear-window function clears the entire area in the specified
;; window.  See XClearWindow.

(define (clear-window window)
  (clear-area window 0 0 0 0 #f))

;; The raise-window (lower-window) function raises (lowers) the
;; specified window to the top (button) of the stack so that no
;; sibling window obscures it (it does not obscure any sibling
;; windows). See XRaiseWindow.

(define (raise-window window)
  (set-window-stack-mode! window (stack-mode above)))

(define (lower-window window)
  (set-window-stack-mode! window (stack-mode below)))

;; The restack-windows function restacks the windows in the order
;; specified, from top to bottom. The stacking order of the first
;; window in the windows list is unaffected, but the other windows in
;; the array are stacked underneath the first window, in the order of
;; the list. See XRestackWindows.

(define (restack-windows window-list)
  (let loop ((w (car window-list))
	     (t (cdr window-list)))
    (if (not (null? t))
	(let ((n (car t)))
	  (set-window-sibling! n w)
	  (set-window-stack-mode! n 'below)
	  (loop n (cdr t))))))

;; query-tree returns a list of three elements: root window, parent
;; window and child windows of the given window. See XQueryTree.

(define (query-tree window)
  (let* ((display (window-display window))
	 (res (%query-tree (window-Xwindow window)
			   (display-Xdisplay display))))
    (if res
	(list
	 (make-window (vector-ref res 0) display #f)
	 (make-window (vector-ref res 1) display #f)
	 (vector->list (vector-map! (lambda (Xwindow)
				      (make-window Xwindow display #f))
				    (vector-ref res 2))))
	res)))

(import-lambda-definition %query-tree (Xwindow Xdisplay)
  "scx_Query_Tree")

(define (window-root window)
  (let ((t (query-tree window)))
    (and t (car t))))

(define (window-parent window)
  (let ((t (query-tree window)))
    (and t (cadr t))))

(define (window-children window)
  (let ((t (query-tree window)))
    (and t (caddr t))))

;; translate-coordinates takes the x and y coordinates relative to the
;; source window's origin and returns a list of three elements: the x
;; and y coordinates relative to the destination window's origin. If
;; the source window and the destination window are on different
;; screens the result is #f. See XTranslateCoordinates.

(define (translate-coordinates src-window x y dst-window)
  (let* ((display (window-display src-window))
	 (res (%translate-coordinates 
	       (display-Xdisplay display)
	       (window-Xwindow src-window)
	       x y
	       (window-Xwindow dst-window))))
    (if res
	(begin
	  (vector-set! res 2 (make-window (vector-ref res 2) display #f))
	  (vector->list res))
	#f)))

(import-lambda-definition %translate-coordinates (Xdisplay srcXwindow x y 
							   dstXwindow)
  "scx_Translate_Coordinates")


;; query-pointer returns a list of eight elements: x and y
;; coordinates, a boolean indicating whether the pointer is on the
;; same screen as the specified window, the root window, the root
;; window's x and y coordinates, the child window and a list of
;; modifier names (see grab-button). See XQueryPointer.

(define (query-pointer window)
  (let* ((display (window-display window))
	 (res (%query-pointer (display-Xdisplay display)
			      (window-Xwindow window))))
    (vector-set! res 3 (make-window (vector-ref res 3) display #f))
    (vector-set! res 6 (make-window (vector-ref res 6) display #f))
    (vector-set! res 7 (integer->state-set (vector-ref res 7)))
    (vector->list res)))

(import-lambda-definition %query-pointer (Xdisplay Xwindow)
  "scx_Query_Pointer")