scsh-conservatory
/
scx
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

changed get-window-attributes to use vectors instead of lists 

internally. fixed some typos. added comments.
This commit is contained in:
frese 2001-07-16 13:36:53 +00:00
parent 144ecc85c6
commit 2cab5071f3
1 changed files with 60 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

107
scheme/xlib/window.scm
View File

@ -1,6 +1,10 @@
;; Author: David Frese ;; Author: David Frese
; ... ;; create-window takes an alist of names and values - see
;; change-window-attributes and configure-window. Mandatory arguments for
;; create-window are 'parent, 'width and 'height. Example:
;; (create-window 'parent root 'width 500 'height 300 '((border-width . 4)))
;; Returns the new window or raises an exception if something went wrong.
(define (create-window . args) (define (create-window . args)
(let ((alist (named-args->alist args))) (let ((alist (named-args->alist args)))
@ -20,8 +24,6 @@
border-width attrAlist) border-width attrAlist)
"Create_Window") "Create_Window")
;; change-window-attributes takes an alist of names and values... ;; change-window-attributes takes an alist of names and values...
;; names can be: background-pixmap, background-pixel, border-pixmap, ;; names can be: background-pixmap, background-pixel, border-pixmap,
;; border-pixel, bit-gravity, gravity, backing-store, backing-planes, ;; border-pixel, bit-gravity, gravity, backing-store, backing-planes,
@ -39,7 +41,7 @@
((pixmap? value) (pixmap-Xpixmap value)) ((pixmap? value) (pixmap-Xpixmap value))
((pixel? value) (pixel-Xpixel value)) ((pixel? value) (pixel-Xpixel value))
((colormap? value) (colormap-Xcolormap value)) ((colormap? value) (colormap-Xcolormap value))
((cursor? value) (cursor-Xcursor value)) ;... ((cursor? value) (cursor-Xcursor value))
(else value))) (else value)))
(map cdr alist))))) (map cdr alist)))))
(%change-window-attributes (window-Xwindow window) (%change-window-attributes (window-Xwindow window)
@ -49,11 +51,12 @@
(import-lambda-definition %change-window-attributes (Xwindow Xdisplay alist) (import-lambda-definition %change-window-attributes (Xwindow Xdisplay alist)
"Change_Window_Attributes") "Change_Window_Attributes")
;; single functions that use 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 name) (define (make-win-attr-setter name)
(lambda (window value) (lambda (window value)
(change-window-attributes window (cons name value)))) (change-window-attributes window (list (cons name value)))))
(define set-window-background-pixmap! (make-win-attr-setter 'background-pixmap)) (define set-window-background-pixmap! (make-win-attr-setter 'background-pixmap))
(define set-window-background-pixel! (make-win-attr-setter 'background-pixel)) (define set-window-background-pixel! (make-win-attr-setter 'background-pixel))
@ -82,8 +85,14 @@
(if (not v) (if (not v)
(error "cannot get window attributes." window) (error "cannot get window attributes." window)
(let* (let*
(;; ... modify as a vector not as a list... ?? ((comp (lambda (i f) (vector-set! v i (f (vector-ref v i)))))
(mod-v (begin
(comp 13 make-pixel) ;; backing-pixel
(comp 7 (lambda (Xwin) ;; root
;; really this Display ??
(make-window Xwin (window-display window))))
;; font, visual ??
v))
(alist (map cons (alist (map cons
'(x y width height border-width depth visual root '(x y width height border-width depth visual root
class bit-gravity win-gravity backing-store class bit-gravity win-gravity backing-store
@ -93,21 +102,8 @@
override-redirect override-redirect
; screen not supported ; screen not supported
) )
(vector->list v))) (vector->list mod-v))))
(mod-alist (map (lambda (name-val) alist)))))
(case (car name-val)
;((...-mask))
;((font) ...)
((backing-pixel)
(cons 'backing-pixel
(make-pixel (cdr name-val))))
;((root)
; (cons 'root
; (make-window (cdr name-val) dpy??)))
;((visual) ??)
(else name-val)))
alist)))
mod-alist)))))
(import-lambda-definition %get-window-attributes (Xdisplay Xwindow) (import-lambda-definition %get-window-attributes (Xdisplay Xwindow)
"Get_Window_Attributes") "Get_Window_Attributes")
@ -139,7 +135,7 @@
(make-win-attr-getter 'do-not-propagate-mask)) (make-win-attr-getter 'do-not-propagate-mask))
(define window-override-redirect (make-win-attr-getter 'override-redirect)) (define window-override-redirect (make-win-attr-getter 'override-redirect))
;; ... ;; This sets the window-attributes listed below - call like create-window.
(define (configure-window window . args) (define (configure-window window . args)
(let* ((args (named-args->alist args)) (let* ((args (named-args->alist args))
@ -151,7 +147,7 @@
val)) val))
(map cdr args))))) (map cdr args)))))
(%configure-window (window-Xwindow window) (%configure-window (window-Xwindow window)
(display-Xdisplay (window-display)) (display-Xdisplay (window-display window))
prep-alist))) prep-alist)))
(import-lambda-definition %configure-window (Xwindow Xdisplay alist) (import-lambda-definition %configure-window (Xwindow Xdisplay alist)
@ -161,7 +157,7 @@
(define (make-win-configurer name) (define (make-win-configurer name)
(lambda (window value) (lambda (window value)
(configure-window window name value))) (configure-window window (list (cons name value)))))
(define set-window-x! (make-win-configurer 'x)) (define set-window-x! (make-win-configurer 'x))
(define set-window-y! (make-win-configurer 'y)) (define set-window-y! (make-win-configurer 'y))
@ -171,7 +167,8 @@
(define set-window-sibling! (make-win-configurer 'sibling)) (define set-window-sibling! (make-win-configurer 'sibling))
(define set-window-stack-mode! (make-win-configurer 'stack-mode)) (define set-window-stack-mode! (make-win-configurer 'stack-mode))
;; ... ;; The map-window function maps the window and all of its subwindows that have
;; had map requests. See XMapWindow.
(define (map-window window) (define (map-window window)
(%map-window (window-Xwindow window) (%map-window (window-Xwindow window)
@ -180,7 +177,8 @@
(import-lambda-definition %map-window (Xwindow Xdisplay) (import-lambda-definition %map-window (Xwindow Xdisplay)
"Map_Window") "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) (define (unmap-window window)
(%unmap-window (window-Xwindow window) (%unmap-window (window-Xwindow window)
@ -189,7 +187,8 @@
(import-lambda-definition %unmap-window (Xwindow Xdisplay) (import-lambda-definition %unmap-window (Xwindow Xdisplay)
"Unmap_Window") "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) (define (destroy-subwindows window)
(%destroy-subwindows (window-Xwindow window) (%destroy-subwindows (window-Xwindow window)
@ -198,7 +197,8 @@
(import-lambda-definition %destroy-subwindows (Xwindow Xdisplay) (import-lambda-definition %destroy-subwindows (Xwindow Xdisplay)
"Destroy_Subwindows") "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) (define (map-subwindows window)
(%map-subwindows (window-Xwindow window) (%map-subwindows (window-Xwindow window)
@ -207,7 +207,8 @@
(import-lambda-definition %map-subwindows (Xwindow Xdisplay) (import-lambda-definition %map-subwindows (Xwindow Xdisplay)
"Map_Subwindows") "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) (define (unmap-subwindows window)
(%unmap-subwindows (window-Xwindow window) (%unmap-subwindows (window-Xwindow window)
@ -216,7 +217,7 @@
(import-lambda-definition %unmap-subwindows (Xwindow Xdisplay) (import-lambda-definition %unmap-subwindows (Xwindow Xdisplay)
"Unmap_Subwindows") "Unmap_Subwindows")
;; ... ;; See XCirculateSubwindows.
(define (circulate-subwindows window direction) (define (circulate-subwindows window direction)
(%destroy-subwindows (window-Xwindow window) (%destroy-subwindows (window-Xwindow window)
@ -227,12 +228,15 @@
(import-lambda-definition %circulate-subwindows (Xwindow Xdisplay dir) (import-lambda-definition %circulate-subwindows (Xwindow Xdisplay dir)
"Circulate_Subwindows") "Circulate_Subwindows")
;; ... ;; The clear-window function clears the entire area in the specified window.
;; See XClearWindow.
(define (clear-window window) (define (clear-window window)
(clear-area window 0 0 0 0 #f)) (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) (define (raise-window window)
(set-window-stack-mode! window 'above)) (set-window-stack-mode! window 'above))
@ -240,7 +244,10 @@
(define (lower-window window) (define (lower-window window)
(set-window-stack-mode! window 'below)) (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) (define (restack-windows window-list)
(let loop ((w (car window-list)) (let loop ((w (car window-list))
@ -251,7 +258,8 @@
(set-window-stack-mode! n 'below) (set-window-stack-mode! n 'below)
(loop n (cdr t)))))) (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) (define (query-tree window)
(let* ((display (window-display window)) (let* ((display (window-display window))
@ -266,25 +274,34 @@
(import-lambda-definition %query-tree (Xwindow Xdisplay) (import-lambda-definition %query-tree (Xwindow Xdisplay)
"Query_Tree") "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 scr-window x y dst-window) (define (translate-coordinates src-window x y dst-window)
(let* ((display (window-display src-window)) (let* ((display (window-display src-window))
(res (%translate-coordinates (res (%translate-coordinates
(display-Xdisplay display) (display-Xdisplay display)
(window-Xwindow src-window) (window-Xwindow src-window)
x y x y
(window-Xwindow dst-window)))) (window-Xwindow dst-window))))
(list (first res) (if res
(second res) (list (first res)
(make-window (third res) display)))) (second res)
(make-window (third res) display))
#f)))
(import-lambda-definition %translate-coordinates (Xdisplay srcXwindow x y (import-lambda-definition %translate-coordinates (Xdisplay srcXwindow x y
srcXwindow) srcXwindow)
"Translate_Coordinates") "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) (define (query-pointer window)
(let* ((display (window-display window)) (let* ((display (window-display window))
@ -300,8 +317,4 @@
(eighth res)))) (eighth res))))
(import-lambda-definition %query-pointer (Xdisplay Xwindow) (import-lambda-definition %query-pointer (Xdisplay Xwindow)
"Query_Pointer") "Query_Pointer")