;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: XIT; Base: 10; -*-

  
(in-package :xit)

;;; 11/18/1991 (Hubertus) 
;;; The Openwindows 2 server has a bug concering the x,y arguments to the 
;;; COPY-AREA request. These arguments are (mis)interpreted relative to the 
;;; outside origin of the window-drawable. However X11 defines these arguments 
;;; to be relative to the inside origin.

;;; Workaround for OpenWindows Version 2
;;;

(let ((original-copy-area (symbol-function 'xlib:copy-area)))
  (defun redefine-copy-area-foo (display)
    (declare (special *x-server-type*)
	     (ignore display))
    (setf (symbol-function 'xlib:copy-area)
	(if (and (eq *x-server-type* :openwin)
		 (= 2000 *x-server-version*))
	    (compile nil
		     `(lambda (src gcontext src-x src-y width height
			       dst dst-x dst-y)
		       (let ((border-width
			      (typecase dst
				(basic-contact (contact-border-width dst))
				(window (drawable-border-width dst))
				(otherwise 0))))
			 (funcall ,original-copy-area
			          src gcontext src-x src-y width height
			          dst (+ dst-x border-width)
				  (+ dst-y border-width)))))
	  original-copy-area)))
  )
    
#||
(let ((original-with-clip-mask-internal (symbol-function 'with-clip-mask-internal)))
  (defun redefine-with-clip-mask-internal (display)
    (declare (special *x-server-type*)
	     (ignore display))
    (setf (symbol-function 'with-clip-mask-internal)
	(if (and (eq *x-server-type* :openwin)
		 (= 2000 *x-server-version*))
	    (compile nil
		     `(lambda (contact clip-x clip-y clip-w clip-h continuation)
			(with-slots (width height border-width) contact
			  (if (and clip-x clip-y)
			      (using-point-vector (clip-mask 4)
				 (point-push (+ border-width clip-x)
					     (+ border-width clip-y))
				 (point-push (or clip-w (- width clip-x))
					     (or clip-h (- height clip-y)))
				 (funcall continuation clip-mask))
			    (funcall continuation nil)))))
	  original-with-clip-mask-internal))))


(add-open-display-hook 'redefine-with-clip-mask-internal
		       :position '(:after init-x-server-type)
		       :if-needed t)

||#

(add-open-display-hook 'redefine-copy-area-foo
		       :position '(:after init-x-server-type)
		       :if-needed t) 


#|| nonsense stuff removed from macros.lisp

(defun patch-clip-mask-origin (display)
  (when (eq (display-type-and-version display) :openwin)
    (defun with-clip-mask-internal (contact clip-x clip-y clip-w clip-h continuation)
      (with-slots (width height) contact
	(if (and clip-x clip-y)
	    (let ((origin (if (eq (display-type-and-version (contact-display contact))
				  :openwin)
			      (contact-border-width contact)
			    0)))
	      (using-point-vector (clip-mask 4)
				  (point-push (+ origin clip-x) (+ origin  clip-y))
				  (point-push (+ origin (or clip-w (- width clip-x)))
					      (+ origin (or clip-h (- height clip-y))))
				  (funcall continuation clip-mask)))
	  (funcall continuation nil))))))

(add-open-display-hook 'patch-clip-mask-origin)
||#