256 lines
8.4 KiB
Scheme
256 lines
8.4 KiB
Scheme
|
;; Author: David Frese
|
||
|
|
|
||
|
|
; ...
|
||
|
|
|
||
|
|
(define (create-window . args)
|
||
|
|
(let ((alist (named-args->alist args)))
|
||
|
|
;; filter attributes
|
||
|
|
(let* ((x 0)
|
||
|
|
(y 0)
|
||
|
|
(width #f)
|
||
|
|
(height #f)
|
||
|
|
(border-width 2)
|
||
|
|
(parent #f)
|
||
|
|
(change-win-attr-list '()))
|
||
|
|
(for-each (lambda (name-val)
|
||
|
|
(let ((val (cdr name-val)))
|
||
|
|
(case (car name-val)
|
||
|
|
((x) (set! x val))
|
||
|
|
((y) (set! y val))
|
||
|
|
((width) (set! width val))
|
||
|
|
((height) (set! height val))
|
||
|
|
((parent) (set! parent val))
|
||
|
|
((border-width) (set! border-width val))
|
||
|
|
(else (set! change-win-attr-list
|
||
|
|
(cons name-val change-win-attr-list))))))
|
||
|
|
alist)
|
||
|
|
(let* ((display (window-display parent))
|
||
|
|
(Xwindow (%create-window (display-Xdisplay display)
|
||
|
|
(window-Xwindow parent)
|
||
|
|
x y width height border-width
|
||
|
|
change-win-attr-list)))
|
||
|
|
(if (= Xwindow 0)
|
||
|
|
(error "cannot create window")
|
||
|
|
(make-window #f Xwindow display))))))
|
||
|
|
|
||
|
|
(import-lambda-definition %create-window (Xdisplay Xparent x y width height
|
||
|
|
border-width attrAlist)
|
||
|
|
"Create_Window")
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
;; change-window-attributes takes an alist of names and values...
|
||
|
|
;; names can be: background-pixmap, background-pixel, border-pixmap,
|
||
|
|
;; border-pixel, bit-gravity, gravity, backing-store, backing-planes,
|
||
|
|
;; backing-pixel, save-under, event-mask, do-not-propagate-mask,
|
||
|
|
;; override-redirect, colormap, cursor.
|
||
|
|
|
||
|
|
(define (change-window-attributes window . attrs)
|
||
|
|
(let* ((alist (named-args->alist attrs))
|
||
|
|
(prep-alist
|
||
|
|
(map cons
|
||
|
|
(map car alist)
|
||
|
|
(map (lambda (value)
|
||
|
|
(cond
|
||
|
|
;; Abstractions ?? :
|
||
|
|
((pixmap? value) (pixmap-Xpixmap value))
|
||
|
|
((pixel? value) (pixel-Xpixel value))
|
||
|
|
((colormap? value) (colormap-Xcolormap value))
|
||
|
|
((cursor? value) (cursor-Xcursor value))
|
||
|
|
(else value)))
|
||
|
|
(map cdr alist)))))
|
||
|
|
(%change-window-attributes (window-Xwindow window)
|
||
|
|
(display-Xdisplay (window-display window))
|
||
|
|
prep-alist)))
|
||
|
|
|
||
|
|
(import-lambda-definition %change-window-attributes (Xwindow Xdisplay alist)
|
||
|
|
"Change_Window_Attributes")
|
||
|
|
|
||
|
|
;; single functions that use change-window-attributes:
|
||
|
|
|
||
|
|
(define (make-win-attr-setter name)
|
||
|
|
(lambda (window value)
|
||
|
|
(change-window-attributes window (cons name value))))
|
||
|
|
|
||
|
|
(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-border-pixmap! (make-win-attr-setter 'border-pixmap))
|
||
|
|
(define set-window-border-pixel! (make-win-attr-setter 'border-pixel))
|
||
|
|
(define set-window-bit-gravity! (make-win-attr-setter 'bit-gravity))
|
||
|
|
(define set-window-gravity! (make-win-attr-setter 'gravity))
|
||
|
|
(define set-window-backing-store! (make-win-attr-setter 'backing-store))
|
||
|
|
(define set-window-backing-planes! (make-win-attr-setter 'backing-planes))
|
||
|
|
(define set-window-backing-pixel! (make-win-attr-setter 'backing-pixel))
|
||
|
|
(define set-window-save-under! (make-win-attr-setter 'save-under))
|
||
|
|
(define set-window-event-mask! (make-win-attr-setter 'event-mask))
|
||
|
|
(define set-window-do-not-propagate-mask!
|
||
|
|
(make-win-attr-setter 'do-not-propagate-mask))
|
||
|
|
(define set-window-override-redirect! (make-win-attr-setter 'override-redirect))
|
||
|
|
(define set-window-colormap! (make-win-attr-setter 'colormap))
|
||
|
|
(define set-window-cursor! (make-win-attr-setter 'cursor))
|
||
|
|
|
||
|
|
;; get-window-attributes gives back the same attributes that
|
||
|
|
;; set-window-attributes sets and some more ...
|
||
|
|
|
||
|
|
(define (get-window-attributes window)
|
||
|
|
(let ((Xwindow (window-Xwindow window))
|
||
|
|
(Xdisplay (display-Xdisplay (window-display window))))
|
||
|
|
(let* ((lst (%get-window-attributes Xdisplay Xwindow))
|
||
|
|
(alist (map cons
|
||
|
|
'(x y width height border-width depth visual root class
|
||
|
|
bit-gravity win-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)
|
||
|
|
lst))
|
||
|
|
(mod-alist (map (lambda (name-val)
|
||
|
|
(case (car name-val)
|
||
|
|
;((root) (make-window ...
|
||
|
|
(else name-val)))
|
||
|
|
alist)))
|
||
|
|
mod-alist)))
|
||
|
|
|
||
|
|
(import-lambda-definition %get-window-attributes (Xdisplay Xwindow)
|
||
|
|
"Get_Window_Attributes")
|
||
|
|
|
||
|
|
(define (make-win-attr-getter name)
|
||
|
|
(lambda (window)
|
||
|
|
(cdr (assq name (get-window-attributes window)))))
|
||
|
|
|
||
|
|
(define window-x (make-win-attr-getter 'x))
|
||
|
|
(define window-y (make-win-attr-getter 'y))
|
||
|
|
(define window-width (make-win-attr-getter 'width))
|
||
|
|
(define window-height (make-win-attr-getter 'height))
|
||
|
|
(define window-border-width (make-win-attr-getter 'border-width))
|
||
|
|
(define window-depth (make-win-attr-getter 'depth))
|
||
|
|
(define window-visual (make-win-attr-getter 'visual))
|
||
|
|
(define window-root (make-win-attr-getter 'root))
|
||
|
|
(define window-class (make-win-attr-getter 'class))
|
||
|
|
(define window-bit-gravity (make-win-attr-getter 'bit-gravity))
|
||
|
|
(define window-backing-store (make-win-attr-getter 'backing-store))
|
||
|
|
(define window-backing-planes (make-win-attr-getter 'backing-planes))
|
||
|
|
(define window-backing-pixel (make-win-attr-getter 'backing-pixel))
|
||
|
|
(define window-save-under (make-win-attr-getter 'save-under))
|
||
|
|
(define window-colormap (make-win-attr-getter 'colormap))
|
||
|
|
(define window-map-installed (make-win-attr-getter 'map-installed))
|
||
|
|
(define window-map-state (make-win-attr-getter 'map-state))
|
||
|
|
(define window-all-event-masks (make-win-attr-getter 'all-event-masks))
|
||
|
|
(define window-your-event-mask (make-win-attr-getter 'your-event-mask))
|
||
|
|
(define window-do-not-propagate-mask
|
||
|
|
(make-win-attr-getter 'do-not-propagate-mask))
|
||
|
|
(define window-override-redirect (make-win-attr-getter 'override-redirect))
|
||
|
|
|
||
|
|
;; ...
|
||
|
|
|
||
|
|
(define (configure-window window . args)
|
||
|
|
(let* ((args (named-args->alist args))
|
||
|
|
(prep-alist (map cons
|
||
|
|
(map car args)
|
||
|
|
(map (lambda (val)
|
||
|
|
(if (window? val)
|
||
|
|
(window-Xwindow val)
|
||
|
|
val))
|
||
|
|
(map cdr args)))))
|
||
|
|
(%configure-window (window-Xwindow window)
|
||
|
|
(display-Xdisplay (window-display))
|
||
|
|
prep-alist)))
|
||
|
|
|
||
|
|
(import-lambda-definition %configure-window (Xwindow Xdisplay alist)
|
||
|
|
"Configure_Window")
|
||
|
|
|
||
|
|
;; the following mutators are based on configure-window
|
||
|
|
|
||
|
|
(define (make-win-configurer name)
|
||
|
|
(lambda (window value)
|
||
|
|
(configure-window window name value)))
|
||
|
|
|
||
|
|
(define set-window-x! (make-win-configurer 'x))
|
||
|
|
(define set-window-y! (make-win-configurer 'y))
|
||
|
|
(define set-window-width! (make-win-configurer 'width))
|
||
|
|
(define set-window-height! (make-win-configurer 'height))
|
||
|
|
(define set-window-border-width! (make-win-configurer 'border-width))
|
||
|
|
(define set-window-sibling! (make-win-configurer 'sibling))
|
||
|
|
(define set-window-stack-mode! (make-win-configurer 'stack-mode))
|
||
|
|
|
||
|
|
;; ...
|
||
|
|
|
||
|
|
(define (map-window window)
|
||
|
|
(%map-window (window-Xwindow window)
|
||
|
|
(display-Xdisplay (window-display window))))
|
||
|
|
|
||
|
|
(import-lambda-definition %map-window (Xwindow Xdisplay)
|
||
|
|
"Map_Window")
|
||
|
|
|
||
|
|
;; ...
|
||
|
|
|
||
|
|
(define (unmap-window window)
|
||
|
|
(%unmap-window (window-Xwindow window)
|
||
|
|
(display-Xdisplay (window-display window))))
|
||
|
|
|
||
|
|
(import-lambda-definition %unmap-window (Xwindow Xdisplay)
|
||
|
|
"Unmap_Window")
|
||
|
|
|
||
|
|
;; ...
|
||
|
|
|
||
|
|
(define (destroy-subwindows window)
|
||
|
|
(%destroy-subwindows (window-Xwindow window)
|
||
|
|
(display-Xdisplay (window-display window))))
|
||
|
|
|
||
|
|
(import-lambda-definition %destroy-subwindows (Xwindow Xdisplay)
|
||
|
|
"Destroy_Subwindows")
|
||
|
|
|
||
|
|
;; ...
|
||
|
|
|
||
|
|
(define (map-subwindows window)
|
||
|
|
(%map-subwindows (window-Xwindow window)
|
||
|
|
(display-Xdisplay (window-display window))))
|
||
|
|
|
||
|
|
(import-lambda-definition %map-subwindows (Xwindow Xdisplay)
|
||
|
|
"Map_Subwindows")
|
||
|
|
|
||
|
|
;; ...
|
||
|
|
|
||
|
|
(define (unmap-subwindows window)
|
||
|
|
(%unmap-subwindows (window-Xwindow window)
|
||
|
|
(display-Xdisplay (window-display window))))
|
||
|
|
|
||
|
|
(import-lambda-definition %unmap-subwindows (Xwindow Xdisplay)
|
||
|
|
"Unmap_Subwindows")
|
||
|
|
|
||
|
|
;; ...
|
||
|
|
|
||
|
|
(define (circulate-subwindows window direction)
|
||
|
|
(%destroy-subwindows (window-Xwindow window)
|
||
|
|
(display-Xdisplay (window-display window))
|
||
|
|
(case direction
|
||
|
|
((raise-lowest) 0)
|
||
|
|
((lower-highest) 1)))) ; else exception??
|
||
|
|
|
||
|
|
(import-lambda-definition %circulate-subwindows (Xwindow Xdisplay dir)
|
||
|
|
"Circulate_Subwindows")
|
||
|
|
|
||
|
|
;; ...
|
||
|
|
|
||
|
|
(define (clear-window window)
|
||
|
|
(clear-area window 0 0 0 0 #f))
|
||
|
|
|
||
|
|
;; ...
|
||
|
|
|
||
|
|
(define (raise-window window)
|
||
|
|
(set-window-stack-mode! window 'above))
|
||
|
|
|
||
|
|
(define (lower-window window)
|
||
|
|
(set-window-stack-mode! window 'below))
|
||
|
|
|
||
|
|
;; ...
|
||
|
|
|
||
|
|
(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))))))
|
||
|
|
|
||
|
|
;; ...
|