;; Author: David Frese

; ... 

(define (create-window . args)
  (let ((alist (named-args->alist args)))
    (receive (x y width height border-width parent change-win-attr-list)
	     (alist-split alist '((x . 0) (y . 0) (width . #f) (height . #f)
				  (border-width . 2) (parent . #f)))
      (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 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 ((v (%get-window-attributes Xdisplay Xwindow)))
      (if (not v)
	  (error "cannot get window attributes." window)
	  (let*
	      (;; ... modify as a vector not as a list... ??

	       (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 not supported
			   )
			   (vector->list v)))
	       (mod-alist (map (lambda (name-val)
				 (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)
  "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))
		       (eq? direction 'lower-highest)))
		       ; other is: 'raise-lower / 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))))))

;; ...

(define (query-tree window)
  (let* ((display (window-display window))
	 (res (%query-tree (window-Xwindow window)
			   (display-Xdisplay display))))
    (list (make-window (first res) display)
	  (make-window (second res) display)
	  (vector-map! (lambda (Xwindow)
			 (make-window Xwindow display))
		       (third res)))))

(import-lambda-definition %query-tree (Xwindow Xdisplay)
  "Query_Tree")

;; ...

(define (translate-coordinates scr-window x y dst-window)
  (let* ((display (window-display src-window))
	 (res (%translate-coordinates 
	       (display-Xdisplay display)
	       (window-Xwindow src-window)
	       x y
	       (window-Xwindow dst-window))))
    (list (first res)
	  (second res)
	  (make-window (third res) display))))

(import-lambda-definition %translate-coordinates (Xdisplay srcXwindow x y 
							   srcXwindow)
  "Translate_Coordinates")


;;

(define (query-pointer window)
  (let* ((display (window-display window))
	 (res (%query-pointer (display-Xdisplay display)
			      (window-Xwindow window))))
    (list (first res)
	  (second res)
	  (third res)
	  (make-window (fourth res) display)
	  (fifth res)
	  (sixth res)
	  (make-window (seventh res) display)
	  (eighth res))))

(import-lambda-definition %query-pointer (Xdisplay Xwindow)
  "Query_Pointer")