diff --git a/scheme/xlib/wm.scm b/scheme/xlib/wm.scm new file mode 100644 index 0000000..d1e5c59 --- /dev/null +++ b/scheme/xlib/wm.scm @@ -0,0 +1,119 @@ +(define (reparent-window window parent-window x y) + (%reparent-window (display-Xdisplay (window-display window)) + (window-Xwindow window) + (window-Xwindow parent-window) + x y)) + +(import-lambda-definition %reparent-window (Xdisplay Xwindow Xwindow_parent x y) + "scx_Reparent_Window") + +(define (install-colormap colormap) + (%install-colormap (display-Xdisplay (colormap-display colormap)) + (colormap-Xcolormap colormap))) + +(import-lambda-definition %install-colormap (Xdisplay Xcolormap) + "scx_Install_Colormap") + +(define (uninstall-colormap colormap) + (%uninstall-colormap (display-Xdisplay (colormap-display colormap)) + (colormap-Xcolormap colormap))) + +(import-lambda-definition %uninstall-colormap (Xdisplay Xcolormap) + "scx_Uninstall_Colormap") + +(define (list-installed-colormaps window) + (let* ((dpy (window-display window)) + (ret (%list-installed-colormaps + (display-Xdisplay dpy) + (window-Xwindow window)))) + (vector-map! (lambda (Xcolormap) + (make-colormap Xcolormap display #f)) + ret))) + +(import-lambda-definition %list-installed-colormaps (Xdisplay Xwindow) + "scx_List_Installed_Colormaps") + +(define (set-input-focus display window revert-to time) + (%set-input-focus (display-Xdisplay display) + (begin + (if (not (or (window? window) + (eq? window 'pointer-root))) + (error "expected argument of type window; given" + window)) + window) + time)) + +(import-lambda-definition %set-input-focus (Xdisplay Xwindow) + "scx_Set_Input_Focus") + +(define (input-focus display) + (let ((ret (%input-focus (display-Xdisplay display)))) + (cons (make-window (car ret) display #f) + (cdr ret)))) + +(define (general-warp-pointer display + dst-win dst-x dst-y + src-win src-x src-y src-width src-height) + (%general-warp-pointer (display-Xdisplay display) + (window-Xwindow dst-win) dst-x dst-y + (window-Xwindow src-win) + src-x src-y src-width src-height)) + +(import-lambda-definition %general-warp-pointer + (Xdisplay Xdst-win dst-x dst-y + Xsrc-win src-x src-y src-width src-height) + "scx_General_Warp_Pointer") + +(define (warp-pointer dst-window dst-x dst-y) + (general-warp-pointer (window-display dst-window) + dst-window dst-x dst-y + 'none 0 0 0 0)) + +(define (warp-pointer-relative display x-offset y-offset) + (general-warp-pointer display + 'none x-offset y-offset + 'none 0 0 0 0)) + +(define (bell display . percent) + (%bell (display-Xdisplay display) + (if (null? percent) + 0 + (car percent)))) + +(import-lambda-definition %bell (Xdisplay percent) + "scx_Bell") + +(define (set-access-control display enable?) + (%set-access-control (display-Xdisplay display) + enable?)) + +(import-lambda-definition %set-access-control (Xdisplay on) + "scx_Set_Access_Control") + +(define (change-save-set window mode) + (%change-save-set (display-Xdisplay (window-display window)) + (window-Xwindow window) + mode)) + +(import-lambda-definition %change-save-set (Xdisplay Xwindow mode) + "scx_Change_Save_Set") + +(define (set-close-down-mode display mode) + (%set-close-down-mode (display-Xdisplay display) + mode)) + +(import-lambda-definition %set-close-down-mode (Xdisplay mode) + "scx_Set_Close_Down_Mode") + +(define (get-pointer-mapping display) + (%get-pointer-mapping (display-Xdisplay display))) + +(import-lambda-definition %get-pointer-mapping (Xdisplay) + "scx_Get_Pointer_Mapping") + +(define (set-pointer-mapping display mapping) + (%set-pointer-mapping (display-Xdisplay display) + mapping)) + +(import-lambda-definition %set-pointer-mapping (Xdisplay map) + "scx_Set_Pointer_Mapping")