scx/scheme/xlib/wm.scm

;; If the specified window is mapped, reparent-window automatically
;; performs an UnmapWindow request on it, removes it from its current
;; position in the hierarchy, and inserts it as the child of the
;; specified parent. See XReparentWindow.

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

;; install-colormap function installs the specified colormap for
;; its associated screen. See XInstallColormap.

(define (install-colormap colormap)
  (%install-colormap (display-Xdisplay (colormap-display colormap))
		     (colormap-Xcolormap colormap)))

(import-lambda-definition %install-colormap (Xdisplay Xcolormap)
  "scx_Install_Colormap")

;; uninstall-colormap removes the specified colormap from the required
;; list for its screen. See XUninstallColormap.

(define (uninstall-colormap colormap)
  (%uninstall-colormap (display-Xdisplay (colormap-display colormap))
		       (colormap-Xcolormap colormap)))

(import-lambda-definition %uninstall-colormap (Xdisplay Xcolormap)
  "scx_Uninstall_Colormap")

;; list-installed-colormaps function returns a list of the currently
;; installed colormaps for the screen of the specified window. See
;; XListInstalledColormaps.

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

;; set-input-focus function changes the input focus and the
;; last-focus-change time. See XSetInputFocus.

(define (set-input-focus display window revert-to time)
  (%set-input-focus (display-Xdisplay display)
		    (window-Xwindow window)
		    (revert-to->integer revert-to)
		    time))

(import-lambda-definition %set-input-focus (Xdisplay Xwindow revert-to time)
  "scx_Set_Input_Focus")

(define-enumerated-type revert-to :revert-to
  revert-to? revert-tos revert-to-name revert-to-index
  (none pointer-root parent))

(define (integer->revert-to i)
  (vector-ref revert-tos i))

(define (revert-to->integer v)
  (revert-to-index v))

;; input-focus returns the current focus window and the current focus
;; state as a pair. See XGetInputFocus.

(define (input-focus display)
  (let ((ret (%input-focus (display-Xdisplay display))))
    (cons (make-window (car ret) display #f)
	  (integer->revert-to (cdr ret)))))

(import-lambda-definition %input-focus (Xdisplay)
  "scx_Input_Focus")

;; general-warp-pointer moves the pointer in the specified way. See
;; XWarpPointer for a detailed description.

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

;; warp-pointer calls general-warp-pointer with using
;; (special-window:none dpy) as the src-win and 0 for the src-*
;; coordinates. The display is taken from dst-window.

(define (warp-pointer dst-window dst-x dst-y)
  (general-warp-pointer (window-display dst-window)
			dst-window dst-x dst-y
			(special-window:none (window-display dst-window))
			0 0 0 0))

;; warp-pointer-relative uses general-warp-pointer to move the pointer
;; by x-offset and y-offset away from it's current position.

(define (warp-pointer-relative display x-offset y-offset)
  (general-warp-pointer display
			(special-window:none display)
			x-offset y-offset
			(special-window:none display)
			0 0 0 0))

;; bell rings the bell on the keyboard on the specified display, if
;; possible. The optional percent argument specifies the volume in a
;; range from -100 to 100. 0 is the default value. See XBell.

(define (bell display . percent)
  (%bell (display-Xdisplay display)
	 (if (null? percent)
	     0
	     (car percent))))

(import-lambda-definition %bell (Xdisplay percent)
  "scx_Bell")

;; set-access-control either enables or disables the use of the access
;; control list at each connection setup. See XSetAccessControl.

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

;; Depending on the specified mode, change-save-set either inserts or
;; deletes the specified window from the client's save-set. The
;; specified window must have been created by some other client, or a
;; BadMatch error results. mode is one of 'insert or 'delete. See
;; XChangeSaveSet.

(define (change-save-set window mode)
  (%change-save-set (display-Xdisplay (window-display window))
		    (window-Xwindow window)
		    (save-set-mode->integer mode)))

(define-enumerated-type save-set :save-set
  save-set? save-sets save-set-name save-set-index
  (insert delete))

(define (save-set-mode->integer v)
  (save-set-index v))

(import-lambda-definition %change-save-set (Xdisplay Xwindow mode)
  "scx_Change_Save_Set")

;; set-close-down-mode defines what will happen to the client's
;; resources at connection close. mode is one of 'destroy-all,
;; 'retain-permanent or 'retain-temporary. See XSetCloseDownMode.

(define (set-close-down-mode display mode)
  (%set-close-down-mode (display-Xdisplay display)
			(close-down-mode->integer mode)))

(define-enumerated-type close-down-mode :close-down-mode
  close-down-mode? close-down-modes close-down-mode-name close-down-mode-index
  (destroy-all retain-permanent retain-temporary))

(define (close-down-mode->integer v)
  (close-down-mode-index v))

(import-lambda-definition %set-close-down-mode (Xdisplay mode)
  "scx_Set_Close_Down_Mode")

;; get-pointer-mapping returns a vector, that specifies in the i-th
;; element the logical button number for the physical button i+1. See
;; XGetPointerMapping.

(define (get-pointer-mapping display)
  (%get-pointer-mapping (display-Xdisplay display)))

(import-lambda-definition %get-pointer-mapping (Xdisplay)
  "scx_Get_Pointer_Mapping")

;; set-pointer-mapping sets the mapping of the pointer. mapping must
;; be a vector of the same length that get-pointer-mapping would
;; return. If any of the buttons to be altered are logically in the
;; down state, then #f is returned. #t otherwise. See
;; XSetPointerMapping.

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

;; WM_STATE property

(define (get-wm-state window)
  (let* ((dpy (window-display window))
	 (a (intern-atom dpy "WM_STATE"))
	 (v.t.f (get-property window a #f)))
    (if (and v.t.f
	     (eq? (cadr v.t.f) a)
	     (>= (vector-length (car v.t.f)) 2))
	(let ((v (car v.t.f)))
	  (list (integer->wm-state (vector-ref v 0))
		(make-window (vector-ref v 1) dpy #f)))
	#f)))

(define (set-wm-state window wm-state icon-window)
  (let* ((dpy (window-display window))
	 (a (intern-atom dpy "WM_STATE")))
    (change-property window a a 32
		     (list->vector (list (wm-state->integer wm-state)
					 (window-Xwindow icon-window))))))

(define-enumerated-type wm-state :wm-state
  wm-state? wm-states wm-state-name wm-state-index
  (withdrawn normal wm-state-2 iconic))

(define (integer->wm-state i)
  (vector-ref wm-states i))

(define (wm-state->integer s)
  (wm-state-index s))