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->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 1
		 'copy-from-parent 'copy-from-parent 'copy-from-parent
		 set-window-attribute-alist))

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

;; enumerated type for window attributes that can be changed in
;; create-window and with change-window-attributes.

(define-enumerated-type set-window-attribute :set-window-attribute
  set-window-attribute?
  set-window-attributes
  set-window-attribute-name
  set-window-attribute-index
  ;; don't change the order of the attributes!
  ;; special values: background-pixmap can be a pixmap,
  ;; 'parent-relative or 'none. border-pixmap can be a pixmap or
  ;; 'copy-from-parent.
  (background-pixmap background-pixel border-pixmap border-pixel
   bit-gravity gravity backing-store backing-planes backing-pixel
   override-redirect save-under event-mask do-not-propagate-mask colormap
   cursor))

(define-syntax make-set-window-attribute-alist
  (syntax-rules 
   ()
   ((make-set-window-attribute-alist (attr arg) rest ...)
    (cons (cons (set-window-attribute attr) arg)
	  (make-set-window-attribute-alist rest ...)))
   ((make-set-window-attribute-alist)
    '())))

(define set-window-attribute-alist->vector
  (make-enum-alist->vector 
   set-window-attributes set-window-attribute-index
   (lambda (i)
     (case i
       ((0) (lambda (background)
	      (cond
	       ((pixmap? background) (pixmap-Xpixmap background))
	       ((eq? background 'parent-relative) background)
	       ((none-resource? background) 0)
	       (else (error "invalid background pixmap" 
			    background)))))
       ((1) pixel-Xpixel)
       ((2) (lambda (border)
	      (cond
	       ((pixmap? border) (pixmap-Xpixmap border))
	       ((eq? border 'copy-from-parent) border)
	       (else (error "invalid border pixmap" 
			    border)))))
       ((3) pixel-Xpixel)
       ((8) pixel-Xpixel)
       ((9) (lambda (override-redirect)
	      (if override-redirect 1 0)))
       ((10) (lambda (save-under)
	       (if save-under 1 0)))
       ((13) colormap-Xcolormap)
       ((14) cursor-Xcursor)
       (else (lambda (x) x))))))

;; a macro for an easier creation of such an alist.

(define set-window-attribute-by-name
  (let* ((attributes (vector->list set-window-attributes))
	 (alist (map cons (map set-window-attribute-name
			       attributes)
		     attributes)))
    (lambda (name)
      (let ((r (assq name alist)))
	(if r 
	    (cdr r)
	    (error "attribute name not defined" name))))))

;(define-syntax make-set-window-attribute-alist
;  (syntax-rules ()
;    ((make-set-window-attribute-alist) '())
;    ((make-set-window-attribute-alist 'item)
;     `(cons (cons ,(set-window-attribute-by-name (car item))
;		  ,(cadr item))
;	    '()))
;    ((make-set-window-attribute-alist item1 item2 ...)
;     (cons (cons (set-window-attribute-by-name (car item1))
;		 (cadr item1))
;	   (make-set-window-attribute-alist item2 ...)))))

;; 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->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 **********************************************
;; an enumerated type for configure-window (see XConfigureWindow)

(define-enumerated-type window-change :window-change
  window-change?
  window-changes
  window-change-name
  window-change-index
  ; do not change this order
  ; sibling is a window, stack-mode can be one of 'above, 'below,
  ; 'top-if, 'buttom-if and 'opposite.
  (x y width height border-width sibling stack-mode))

(define-syntax make-window-change-alist
  (syntax-rules 
   ()
   ((make-window-change-alist (attr arg) rest ...)
    (cons (cons (window-change attr) arg)
	  (make-window-change-alist rest ...)))
   ((make-window-change-alist)
    '())))

(define window-change-alist->vector
  (make-enum-alist->vector 
   window-changes window-change-index
   (lambda (i)
     (case i
       ((5) window-Xwindow)
       (else (lambda (x) x))))))

;; This sets the window-attributes listed above

(define (configure-window window window-change-alist)
  (%configure-window (window-Xwindow window)
		     (display-Xdisplay (window-display window))
		     (window-change-alist->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-enumerated-type window-attribute :window-attribute
  window-attribute?
  window-attributes
  window-attribute-name
  window-attribute-index
  ;; don't change the order of the attributes!
  ;; screen is not supported yet - so it will be always #f
  (x y width height border-width depth visual root class bit-gravity
   gravity backing-store backing-planes backing-pixel save-under
   colormap map-installed map-state all-event-masks your-event-mask
   do-not-propagate-mask override-redirect screen))

(define-syntax make-window-attribute-alist
  (syntax-rules 
   ()
   ((make-window-attribute-alist (attr arg) rest ...)
    (cons (cons (window-attribute attr) arg)
	  (make-window-attribute-alist rest ...)))
   ((make-window-attribute-alist)
    '())))

(define vector->window-attribute-alist 
  (make-vector->enum-alist
   window-attributes
   (lambda (i display)
     (case i
       ((13) (lambda (Xpixel) ; backing-pixel
	       (make-pixel Xpixel #f #f)))
       ((7) (lambda (Xwindow) ; root
	      (make-window Xwindow display #f)))
       ((15) (lambda (Xcolormap)
	       (make-colormap Xcolormap display #f)))
       ((6) make-visual)
       (else (lambda (x) x))))))

(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)
	  (error "cannot get window attributes." window)
	  (vector->window-attribute-alist values (window-display window))))))

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

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

(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-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)))

;; 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 'above))

(define (lower-window window)
  (set-window-stack-mode! window '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))))
    (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))))))

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

;; 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 
							   srcXwindow)
  "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->list res)))

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