[Scsh-checkins] CVS: scx/scheme/xlib wm.scm,NONE,1.1

[David Frese <frese@users.sourceforge.net>]

Update of /cvsroot/scsh/scx/scheme/xlib
In directory usw-pr-cvs1:/tmp/cvs-serv21591

Added Files:
        wm.scm 
Log Message:
added windowmanager functions.


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