475 lines
17 KiB
Scheme
475 lines
17 KiB
Scheme
;; 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")
|