;;; -*- Mode:Common-Lisp; Package:X11; Base:10; Fonts:(MEDFNB HL12B HL12BI) -*-

;;;			      RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;			TEXAS INSTRUMENTS INCORPORATED.
;;;				 P.O. BOX 2909
;;;			      AUSTIN, TEXAS 78769
;;;				    MS 2151
;;;
;;; Copyright (C) 1988 Texas Instruments Incorporated. All rights reserved.

#|

This file contains all of the code for requests which deal with graphics primitives.
The idea is that all graphics requests have some code which is common, particularly
with regard to clipping, tiling, etc.

|#

;;; Change history:
;;;
;;;  Date      Author	Description
;;; -------------------------------------------------------------------------------------
;;; 04/03/89	WJB	Patch 1.68; Fix FILL-RECTANGLE to use proper window coordinates when translating the rectangle.
;;; 03/21/89	WJB	Patch 1.52; Fix DRAWING-PROLOG to obtain the correct destination array for drawing.
;;; 03/15/89	WJB	Patch 1.46; Fix OBTAIN-X-ALU to examine only the FG pixel, ignoring the BG.
;;; 03/14/89	WJB	Patch 1.41; Change DRAWING-EPILOG to fix tiling problems caused by patch 1.40
;;; 03/13/89	WJB	Patch 1.40; In DRAWING-EPILOG; ignore backgound pixel when tiling.
;;; 03/04/89	WJB	Patch 1.31; Fix DRAWING-PROLOG for case where using backing store
;;;			and drawable has children.
;;; 02/24/89	WJB	Patch 1.23; Change DRAWING-PROLOG to set x/y origin back to 0/0 when
;;;			drawing on backing-store.
;;; 02/23/89    DAN     Patch 1.20; Change ADD-REFRESH-REGION to use UNION instead of
;;;			NINTERSECT. This was causing windows to be refreshed incorrectly.
;;; 01/27/89    WJB	Fixed REDUCE-RASTER-OPS -- was always returning NIL.
;;; 01/13/89    DAN     Fixed LOCATE-FIRST-CHILD, LOCATE-LAST-CHILD, LOCATE-NEXT-SIBLING,
;;;			DRAWING-PROLOG, DRAWING-EPILOGUE, FILL-RECTANGLE, and
;;;			REFRESH-FROM-BACKING-STORE to check for INPUT-ONLY windows. 
;;; 01/05/89	LGO	Add the :overlap keyword parameter to WITH-DRAWABLE, which
;;;			forces use of a temporary array when drawing overlaps and the alu is xor.
;;; 12/16/88	LGO	When a window has backing store, do all graphics to it, 
;;;			and copy the backing store to the screen in drawing-epilog.
;;;			(it used to work the other way around...)
;;; 12/16/88	1LGO*	1Combine DRAWING-PROLOG and OBTAIN-DRAWABLE.*
;;; 12/16/88	WJB	OBTAIN-DRAWABLE was treating occlusion stack of length 1 the same as T.
;;; 12/114*/88    LGO     1Don't barf on large tile/stipple origins*
;;; 12/12/88    LGO     Add :BOXER parameter to WITH-DRAWABLE, which allows any drawing function
;;;			to1 *specify which part of the drawable is being drawn into.
;;; 12/12/88    LGO     Hack drawing-prolog to not use a gx-copy alu when drawing to a 
;;;			temporary array when the drawing alu is XOR.
;;; 12/08/88    LGO     Make gcontext clipping rectangles work again
;;; 12/07/88    LGO     Put back the hack of munging the clipping rectangle
;;;			when there's a single occluding child on the edge1.*
;;; 112*/107*/88    LGO     1re-write drawing-epilog, to fix a bug, eliminate duplicate code, and make understandable.*
;;; 112*/106*/88    LGO     1Nuke determine-clipping-rectangle*
;;; 112*/106*/88    LGO     1Ensure graphics is clipped by window children when gcontext says clip-by-children.*
;;; 112*/106*/88    LGO     1Fix drawing-prolog to account for window borders on all graphics requests.*
;;; 11/28/88    LGO     Make FILL-RECTANGLE correctly handle 1the occlusion stack and *unmapped children
;;; 11/23/88    LGO     Eliminate use of WINDOW.CHILD-CLIP-MASK, and clear bits
;;;			over children in TEMPORARY-BITMAP-ARRAY instead.
;;; 11/23/88    LGO     Nuke CREATE-TEMPORARY-BITMAP
;;; 11/23/88    LGO     1Use pixmap resources in* FILL-RECTANGLE
;;; 11/23/88    LGO     Change FILL-RECTANGLE to not use BITBLT-UNDER-MASK
;;; 11/23/88    LGO     Re-write COPY-TO-BACKING-STORE to not use BITBLT-UNDER-MASK
;;; 11/22/88    LGO     Re-write PERFORM-OPAQUE-STIPPLING to simply call PERFORM-TILING
;;; 11/22/88    LGO     Re-write PERFORM-TILING to not use BITBLT-UNDER-MASK
;;; 11/08/88    LGO     Re-write DETERMINE-CLIPPING-RECTANGLE to utilize the occlusion stack
;;; 11/07/88    LGO     Fixed FILL-RECTANGLE to work on occluded windows.
;;; 11/07/88    LGO     Fix DRAWING-EPILOGUE to use bitblt instead of bitblt-under-mask
;;;			when there's no tile or stipple.
;;; 11/07/88    LGO     Wrote WITH-DRAWABLE, which simplifies the drawing requests. 
;;; 10/21/88    DAN     Added REDUCE-RASTER-OPS. 
;;; 10/13/88	WJB	Changed OBTAIN-DRAWABLE to use a resource for temporary pixmaps
;;;			and changed DRAWING-EPILOG to deallocate it.
;;;  6/15/88    TWE	Fixed HAVE-DRAWING-TO-DO to also check the mapped status of the
;;;			window's parents.
;;;  5/31/88    TWE	Wrote OBTAIN-X-ALU.
;;;  5/27/88    TWE	Added OBTAIN-EXPLORER-ALU to handle wierd pixels.
;;;  4/26/88    TWE	Implemented VALIDATE-BACKING-STORE and called it in the epilogue.
;;;  3/30/88    TWE	Fixed the DRAWING-EPILOGUE to save the backing store when all
;;;			drawing went directly to the final destination.
;;;  3/17/88    TWE	Fixed LOCATE-NEXT-SIBLING so that it would check for the last
;;;			sibling correctly.
;;;  2/19/88    TWE	Changed trace code to call the server-trace function instead.
;;;  2/11/88    TWE	Removed the hack which created a temporary clip-mask for a
;;;			window's and put it into a new window slot CHILD-CLIP-MASK.
;;;  1/28/88    TWE	Fixed the epilogue code to do simple and opaque tiling correctly.
;;;			The original code was not clearing the image first which resulted
;;;			in the zero pixels of the tile being ignored.
;;;  1/25/88    TWE	Fixed an argument error to make-box in FILL-RECTANGLE.
;;;  1/22/88    TWE	Fixed up fill-rectangle to handle the clip-mask and to only
;;;			update the backing store if the window isn't mapped.  Hopefully I
;;;			have covered all of the cases related to backing store now.  The
;;;			new change was to handle the case of an unmapped window with a
;;;			backing store.  In that case, it is just as if we were trying to
;;;			do graphics directly to the backing store (a pixmap).  Changed
;;;			HAVE-DRAWING-TO-DO to allow graphics to occur for that case.
;;;			Previously we didn't allow graphics to be done on an unmapped
;;;			window.  Changed OBTAIN-DRAWABLE to substitute the window's
;;;			backing store if the window was unmapped and it had a backing
;;;			store.  Changed the epilogue code to do the same kind of
;;;			substitution.
;;;  1/21/88    TWE	Fixed epilogue to test for a temporary clip-mask correctly.
;;;  1/19/88    TWE	Changed the epilogue and obtain-drawable to use the backing store
;;;			differently than before.  The backing store is a pixmap, not a
;;;			bitmap, so it can't be used as a temporary drawing array.  The
;;;			epilogue code was changed to capture the image after all
;;;			rendering but before child clipping and put that into the backing
;;;			store.
;;;  1/13/88    TWE	Fixed up fill-rectangle to handle the backing store.  Fixed
;;;			HAVE-DRAWING-TO-DO in the case of a completely obscured window
;;;			with a backing store.  Fixed OBTAIN-DRAWABLE to pass back another
;;;			value indicating that drawing isn't being done on the screen, but
;;;			is being drawn to a pixmap.  This pixmap can be either one which
;;;			is created or the backing store.  Changed DRAWING-EPILOGUE to
;;;			accept this drawing indicator as an argument, and changed its
;;;			callers to use OBTAIN-DRAWABLE and DRAWING-EPILOGUE with this
;;;			new indicator.
;;;  1/06/88    TWE	Updated DRAWING-EPILOGUE to have the `all done' cases also test
;;;			for an occlusion stack.  Fixed up fill-rectangle to handle the
;;;			occlusion stack.
;;;  1/05/88    TWE	Changed OBTAIN-DRAWABLE to handle the occlusion stack.
;;; 12/22/87    TWE	Updated to handle the occlusion stack.
;;; 12/21/87    TWE	Changed references to a window's children to take into account
;;;			that if a child is unmapped then it doesn't affect drawing.  Also
;;;			changed HAVE-DRAWING-TO-DO by checking to see if the drawable
;;;			is a mapped window.  Moved SUBTRACT-BOX and INTERSECT-BOXES to
;;;			their own file (BOXES).
;;; 12/07/87    TWE	Added SUBTRACT-BOX and FILL-RECTANGLE to handle image-text requests.
;;; 12/01/87    TWE	Initial creation.  Moved from font-requests.

(DEFUN FILL-STYLE-SOLID-P (GCONTEXT)
  (LET ((FILL-STYLE (GCONTEXT.FILL-STYLE GCONTEXT))
        (TILE (GCONTEXT.TILE    GCONTEXT)))
    ;; What we have here is a real a solid fill style, or it is one
    ;; of the other types, and the element it depends upon is such that
    ;; drawing wouldn't be effected.
    (OR (= FILL-STYLE FILL-STYLE-SOLID)
        (AND (= FILL-STYLE FILL-STYLE-STIPPLED)
             (NULL (GCONTEXT.STIPPLE GCONTEXT)))
        (AND (= FILL-STYLE FILL-STYLE-OPAQUE-STIPPLED)
             (NULL (GCONTEXT.STIPPLE GCONTEXT)))
        (AND (= FILL-STYLE FILL-STYLE-TILED)
             (= (ARRAY-TOTAL-SIZE TILE) 1)     ; Only 1 pixel.
             (= (AREF TILE 0 0) (GCONTEXT.FOREGROUND-PIXEL GCONTEXT))))))

(DEFUN LOCATE-FIRST-CHILD (PARENT)
  "Returns the object for parent's first child.  If no child found
then this returns NIL."
  ;; The idea here is that children of the parent which are not mapped
  ;; do not participate in graphics.  According to the protocol spec,
  ;; "unmapped windows and their inferiors are never viewable or visible".
  (LET* ((CHILD (WINDOW.FIRST-CHILD PARENT))
         (LAST-CHILD (WINDOW.LAST-CHILD PARENT)))
    (LOOP
      (WHEN (AND CHILD (WINDOW.MAPPED-P CHILD)
                 (NOT (EQL (window.class child) INPUT-ONLY)))
	(RETURN CHILD))
      (WHEN (EQ CHILD LAST-CHILD)
	(RETURN NIL))
      (SETQ CHILD (WINDOW.NEXT-SIB CHILD)))))

(DEFUN LOCATE-LAST-CHILD (PARENT)
  "Returns the object for parent's last child.  If no child found
then this returns NIL."
  ;; The idea here is that children of the parent which are not mapped
  ;; do not participate in graphics.  According to the protocol spec,
  ;; "unmapped windows and their inferiors are never viewable or visible".
  (LET* ((CHILD (WINDOW.LAST-CHILD PARENT))
         (FIRST-CHILD (WINDOW.FIRST-CHILD PARENT)))
    (LOOP
      (WHEN (AND CHILD (WINDOW.MAPPED-P CHILD)
                 (NOT (EQL (window.class child) input-only)))
	(RETURN CHILD))
      (WHEN (EQ CHILD FIRST-CHILD)
	(RETURN NIL))
      (SETQ CHILD (WINDOW.PREV-SIB CHILD)))))

(DEFUN LOCATE-NEXT-SIBLING (WINDOW)
  "Returns the next mapped sibling of WINDOW."
  (LET ((LAST-CHILD (WINDOW.LAST-CHILD (WINDOW.PARENT WINDOW)))
        (NEXT-SIBLING (WINDOW.NEXT-SIB WINDOW)))
    (IF (EQ WINDOW LAST-CHILD)
        ;; We are already on the last sibling.
        NIL
        ;;1ELSE*
        (LOOP
          (WHEN (AND (WINDOW.MAPPED-P NEXT-SIBLING)
                     (NOT (EQL (window.class next-sibling) input-only)))
            (RETURN NEXT-SIBLING))
          ;; We have reached the last sibling, and it wasn't mapped.
          (WHEN (EQ NEXT-SIBLING LAST-CHILD)
            (RETURN NIL))
          (SETQ NEXT-SIBLING (WINDOW.NEXT-SIB NEXT-SIBLING))))))

(DEFUN OBTAIN-X-ALU (GCONTEXT)
  (DECLARE (TYPE GCONTEXT GCONTEXT)
           (VALUES X-ALU))
  (LET ((X-ALU (GCONTEXT.ALU GCONTEXT))
        (FOREGROUND-PIXEL (GCONTEXT.FOREGROUND-PIXEL GCONTEXT)))
    ;; The following only works for a monochrome server, not for color.  The
    ;; idea here is that the Explorer draws by writing 1 pixels onto the
    ;; drawable.  What can happen with X is to reverse this by drawing 0
    ;; pixels onto a window with 1's as the background.  We can handle this
    ;; with the Explorer by simply mashing the ALU to trick the Explorer into
    ;; writing 1's but have them combine with the existing pixels on the
    ;; screen as if they were 0's.
    (WHEN (eql FOREGROUND-PIXEL 0) 
      (SETQ X-ALU (INVERTED-ALU X-ALU)))
    X-ALU))
  
(DEFUN OBTAIN-EXPLORER-ALU (GCONTEXT)
  (DECLARE (TYPE GCONTEXT GCONTEXT)
           (VALUES EXPLORER-ALU))
  (AREF X-ALU-TO-EXPLORER-ALU (OBTAIN-X-ALU GCONTEXT)))

(DEFUN INVERTED-ALU (X-ALU)
  "Change the ALU so that it works with inverted background/foreground pixels."
  ;; Take the top two bits of the ALU and interchange them with the low two bits.
  (LOGIOR (LSH (LOGAND X-ALU #b0011) 2) (LSH (LOGAND X-ALU #b1100) -2)))

(DEFUN reduce-raster-ops (alu src)
  "2Set reduced raster ops.*"
  (LET ((rop gx-noop))
    (COND ((= src 0)				;1src is black*
	   (SETQ rop (cond
		       ((= alu GX-CLEAR) gx-clear)
		       ((= alu gx-and)   gx-clear)
		       ((= alu gx-and-reverse) gx-clear)
		       ((= alu GX-COPY) GX-CLEAR)
		       ((= alu GX-AND-INVERTED) GX-NOOP)
		       ((= alu GX-NOOP) GX-NOOP)
		       ((= alu GX-XOR) GX-NOOP)
		       ((= alu GX-OR) GX-NOOP)
		       ((= alu GX-NOR) GX-INVERT)
		       ((= alu GX-EQUIV) GX-INVERT)
		       ((= alu GX-INVERT) GX-INVERT)
		       ((= alu GX-OR-REVERSE) GX-INVERT)
		       ((= alu GX-COPY-INVERTED) GX-SET)
		       ((= alu GX-OR-INVERTED) GX-SET)
		       ((= alu GX-NAND) GX-SET)
		       ((= alu GX-SET) GX-SET)
		       (:else GX-NOOP))))
	  (t					;1src is white*
	   (SETQ rop (cond
		       ((= alu GX-CLEAR) GX-CLEAR)
		       ((= alu Gx-AND) GX-NOOP)
		       ((= alu GX-AND-REVERSE) GX-INVERT)
		       ((= alu GX-COPY) GX-SET)
		       ((= alu GX-AND-INVERTED) GX-CLEAR)
		       ((= alu GX-NOOP) GX-NOOP)
		       ((= alu GX-XOR) GX-INVERT)
		       ((= alu GX-OR) GX-SET)
		       ((= alu GX-NOR) GX-CLEAR)
		       ((= alu GX-EQUIV) GX-NOOP)
		       ((= alu GX-INVERT) GX-INVERT)
		       ((= alu GX-OR-REVERSE) GX-SET)
		       ((= alu GX-COPY-INVERTED) GX-CLEAR)
		       ((= alu GX-OR-INVERTED) GX-NOOP)
		       ((= alu GX-NAND) GX-INVERT)
		       ((= alu GX-SET) GX-SET)
		       (:else GX-NOOP)))))
    rop))

(defsubst alu-no-overlap (alu)
  ;1; Returns T when alu interacts with the destination, so pixels drawn with it can't overlap*
  (not (member alu '#.(list gx-copy gx-copy-inverted gx-clear gx-set) :test #'eq)))

(DEFUN window-intersects-box-p (window box)
  "1Returns T if WINDOW intersects BOX*."
  (NOT (OR (<= (box.right box) (WINDOW.X WINDOW))
	   (<= (+ (WINDOW.OUTSIDE-WIDTH  WINDOW) (WINDOW.X WINDOW)) (box.left BOX))
	   (<= (box.bottom box) (WINDOW.Y WINDOW))
	   (<= (+ (WINDOW.OUTSIDE-HEIGHT WINDOW) (WINDOW.Y WINDOW)) (box.top BOX)))))

(defvar *drawing-overlaps-p* nil)

(defmacro with-drawable ((drawable gcontext &key clipping-rectangle boxer overlap)
			 (destination x y alu &optional bounding-box)
			 &body body)
  "2Execute BODY with bindings for DESTINATION, ALU AND BOUNDING-BOX
 when drawing is possible on drawable using gcontext.
 DESTINATION will be a pixel array,
 X and Y will be the coordinates of the graphics origin within DESTINATION.
 ALU will be an X-alu,
 BOUNDING-BOX will be a clipping rectangle.*"
  (let ((box (or bounding-box 'drawing-bounding-box)))
    `(when (HAVE-DRAWING-TO-DO ,DRAWABLE ,GCONTEXT)
       (block nil ;1; make it easy to return, skipping the epilogue*
	 (multiple-value-bind (,destination ,x ,y ,alu ,box %drawable-has-children
			       %drawn-on-temporary %destination-pixmap)
	     (,@(if overlap `(let ((*drawing-overlaps-p* ,overlap))) '(progn))
	      (drawing-prolog ,drawable ,gcontext ,@boxer))
	   (when ,box ;1; When clipping rectangle is NIL, no drawing to do*
	     (,@(if clipping-rectangle
		    `(w:with-clipping-rectangle ((box.left ,box) (box.top ,box)
						 (box.right ,box) (box.bottom ,box)))
		  '(progn))
	      ,@body)
	     (drawing-epilogue %destination-pixmap ,drawable ,box
			       ,gcontext %drawable-has-children %drawn-on-temporary)))))))

(defun drawing-prolog (drawable gcontext &optional boxer &rest args)
  "Returns a place to draw upon.
Returns three values: the place to draw, a box object with the boundaries of the drawable,
and a flag indicating the presence of children in the drawable."
  ;1; BOXER is a function that is passed a box (with origin 0,0 and width/height equal to the drawable) and args.*
  ;1; It modifies box to that portion of the drawable that will be drawn upon.*
  ;1; This is used to reduce the places where drawing to a temporary array is necessary, and*
  ;1; restrict the area where the temporary is copied.*
  (LET ((DESTINATION (DEVICE-PRIVATE-ARRAY DRAWABLE))
        (DRAWABLE-X-ORIGIN 0)
        (DRAWABLE-Y-ORIGIN 0)
        DRAWABLE-HEIGHT
        DRAWABLE-WIDTH
        (DRAWABLE-HAS-CHILDREN nil)
        (BACKING-STORE NIL)
        (DRAWN-ON-TEMPORARY NIL)
        (OCCLUSION-STACK T)
	(gc-clip-rectangle (and (gcontext.clip-p gcontext)
				(gcontext.clip-rectangle gcontext)))
	(alu (obtain-x-alu gcontext))
	drawable-boundaries)
    (IF (TYPEP DRAWABLE 'WINDOW)
        (PROGN
	  ;; Make sure that the backing store is of the right size.
	  (SETQ OCCLUSION-STACK   (WINDOW.OCCLUSION-STACK DRAWABLE)
		BACKING-STORE (and (window.backing-store-valid drawable)
				   (VALIDATE-BACKING-STORE DRAWABLE))
		DRAWABLE-WIDTH    (WINDOW.WIDTH  DRAWABLE)
		DRAWABLE-HEIGHT   (WINDOW.HEIGHT DRAWABLE)
		DRAWABLE-X-ORIGIN (WINDOW.ABSOLUTE-INSIDE-X DRAWABLE)
		DRAWABLE-Y-ORIGIN (WINDOW.ABSOLUTE-INSIDE-Y DRAWABLE)
		DRAWABLE-HAS-CHILDREN
		;1; Ignore children when subwindow-mode isn't clip-by-children*
		(and (= (GCONTEXT.SUBWINDOW-MODE GCONTEXT) SUBWINDOW-MODE-Clip-By-Children)
		     (LOCATE-FIRST-CHILD DRAWABLE) t)))
      ;;ELSE
      ;; Must be a pixmap instead.
      (PROGN
        (SETQ DRAWABLE-WIDTH  (PIXMAP.WIDTH  DRAWABLE)
              DRAWABLE-HEIGHT (PIXMAP.HEIGHT DRAWABLE)
              DESTINATION     (PIXMAP.ARRAY  DRAWABLE))))
    ;1;
      *;1; Construct the clipping rectangle*
    (setq drawable-boundaries 
	  (MAKE-BOX :LEFT DRAWABLE-X-ORIGIN :WIDTH  DRAWABLE-WIDTH
		    :TOP  DRAWABLE-Y-ORIGIN :HEIGHT DRAWABLE-HEIGHT))
    ;1;*
    ;1;  Check for children obscuring the drawing*
    (when drawable-has-children
      ;1; If only one child, and child is along one edge, we still have a simple clipping rectangle...*
      (setq drawable-has-children
	    (not (clip-for-single-child-on-edge drawable drawable-boundaries))))
    ;1; If the above didn't work, and there's a boxer function, there's still hope!*
    (when (and drawable-has-children boxer)
      (let ((box (make-box :left 0 :top 0 :width drawable-width :height drawable-height)))
	(apply boxer box args) ;1; Modify BOX to include only that part of drawable to be drawn on.*
	(translate-box box drawable-x-origin drawable-y-origin)
	(unless (nintersect-boxes drawable-boundaries box)
	  ;1; result will be NIL if there isn't an intersection*
	  (return-from drawing-prolog nil))
	(loop for child being the xwindow-children of drawable
	      when (AND (window.mapped-p child)
                        (NOT (EQL (window.class child) input-only))) do
	      (when (window-intersects-box-p child drawable-boundaries)
		(return nil))
	      finally (setq drawable-has-children nil))))  ;1 No children intersect our box*
    ;1;
      *;1; Decide if we have to draw on a temporary array*
    (IF (AND
	  ;1; The drawing doesn't overlap, or we have an ALU that doesn't interact with the destination.*
	  (or (not *drawing-overlaps-p*)
	      (and (not (alu-no-overlap alu))
		   (not (eq *drawing-overlaps-p* :always))))
          ;; A user-supplied clip-mask is a complex case.
          (NULL (GCONTEXT.CLIP-mask GCONTEXT))
          ;; Solid drawing is simple.  Tiled or stippled or opaque stippled cases are complex.
          (FILL-STYLE-SOLID-P GCONTEXT)
          ;; This window is fully visible.
          (or (EQ OCCLUSION-STACK T)
	      ;1; or there's only one clipping rectangle*
	      (null (cdr occlusion-stack))
	      backing-store)
	  ;1; Clipping to Children is complex*
	  (NULL DRAWABLE-HAS-CHILDREN))
	(progn
	  ;; We already set up the origin and destination.
	  ;; Check for single occlusion rectangle
	  (when (and (consp occlusion-stack) (null (cdr occlusion-stack)))
	    (nintersect-boxes drawable-boundaries (car occlusion-stack)))
	  (when backing-store
	    (if (and (window.realized-p drawable)
		     (or (eq occlusion-stack t)
			 (and (null (cdr occlusion-stack))
			      (subbox-p (car occlusion-stack) drawable-boundaries))))
		1;; The window is unoccluded* or drawing is entirely contained within visible area of window.
		;;1 So draw directly to the window and copy from the window to the backing store *if
		;;1 the window *later 1becomes occluded.*
		(setf (window.backing-store-valid drawable) nil)
	      ;; If the window has a backing store then we draw on the backing store just if it were a pixmap.
	      ;; Record areas of window that will need refreshing
	      (add-refresh-region drawable drawable-boundaries)
	      ;; Allow graphics routines to write anywhere within the window's backing store
	      (setq drawable-boundaries (make-box :left 0 :width  drawable-width
						  :top  0 :height drawable-height)
		    drawable backing-store
		    destination (pixmap.array backing-store)
		    drawable-x-origin 0
		    drawable-y-origin 0))))
      ;;ELSE
      (progn
	;; The drawing case is too complex.  We need to create a temporary bitmap
	;; (not a pixmap) where we can write the results, and then render the image
	;; from this temporary bitmap to the real destination.
	(translate-box drawable-boundaries (- drawable-x-origin) (- drawable-y-origin))
	(SETQ DRAWABLE-X-ORIGIN 0
	      DRAWABLE-Y-ORIGIN 0
	      DRAWN-ON-TEMPORARY T
	      DESTINATION (ALLOCATE-RESOURCE 'PIXMAP 
					     DRAWABLE DRAWABLE-WIDTH DRAWABLE-HEIGHT 1))))
    ;1; When there's a single gcontext clipping rectangle that's not the default, and the clip mask isn't used*
    (when gc-clip-rectangle
      (when (and (plusp drawable-x-origin) (plusp drawable-y-origin))
	(setq gc-clip-rectangle
	      (translate-box (copy-box gc-clip-rectangle)
			     DRAWABLE-X-ORIGIN  DRAWABLE-Y-ORIGIN)))
      ;1; *shrink the drawable-boundaries to fit inside the clip rectangle.
	(unless (nintersect-boxes drawable-boundaries gc-clip-rectangle)
	  ;1; result will be NIL if there isn't an intersection*
	  (return-from drawing-prolog nil)))

    (let ((x 0)
	  (y 0)
	  (destination-array destination))
      (when (typep destination 'pixmap)
	;; We really have a temporary pixmap, so we'll have to extract the array from it.
	(setq destination-array (pixmap.array destination)))
      (if drawn-on-temporary
	  (when (or (not (alu-no-overlap alu)) ;1; HACK ALERT!!!*
		    *drawing-overlaps-p*)
	    (setq alu gx-copy))
	(when (window-p drawable)
	  (setq x (WINDOW.Absolute-inside-X DRAWABLE)
		y (WINDOW.Absolute-inside-Y DRAWABLE))))
      (when drawn-on-temporary (server-trace " Drawing on Temporary "))
      (values destination-array x y alu drawable-boundaries drawable-has-children drawn-on-temporary destination))))

(defun clip-for-single-child-on-edge (window drawable-boundaries)
2  "Returns T if WINDOW has a child which covers one of its edges completely, and
adjusts drawable-boundaries to exclude the child."*
  (let ((child (locate-first-child window)))
    (when (and child ;; Only one child?
	       (eq child (window.last-child window)))
      (let ((child-x (window.x child))
	    (child-y (window.y child))
	    (child-width (window.outside-width child))
	    (child-height (window.outside-height child)))
	(cond 
	  ;; Top edge
	  ((and (zerop child-x)
		(zerop child-y)
		(= child-width (window.width window)))
	   (incf (box.top drawable-boundaries) child-height))
	  ;; Bottom edge
	  ((and (zerop child-x)
		(= (+ child-y child-height)
		   (window.height window))
		(= child-width (window.width window)))
	   (decf (box.bottom drawable-boundaries) child-height))
	  ;; Left edge
	  ((and (zerop child-x)
		(zerop child-y)
		(= child-height (window.height window)))
	   (incf (box.left drawable-boundaries) child-width))
	  ;; Right edge
	  ((and (= (+ child-x child-width)
		   (window.width window))
		(zerop child-y)
		(= child-height (window.height window)))
	   (decf (box.right drawable-boundaries) child-width))))
      t)))

(DEFUN HAVE-DRAWING-TO-DO (DRAWABLE GCONTEXT)
  "Returns non-NIL when it is possible to perform drawing."
  ;; This function checks for those cases where a drawing operation is
  ;; a bit noop and returns NIL, otherwise it returns non-NIL.
  (block exit
    ;; If we are saying to not draw on any plane, then don't draw at all.
    (WHEN (ZEROP (GCONTEXT.PLANE-MASK GCONTEXT))
      (return-from exit nil))
    ;; 1No* clipping rectangle says that everything is clipped.
    (when (and (gcontext.clip-p gcontext) (null (gcontext.clip-rectangle gcontext)))
      (return-from exit nil))
    (WHEN (TYPEP DRAWABLE 'WINDOW)
      (WHEN (AND (NOT (WINDOW.REALIZED-P DRAWABLE))
		 (not (window.backing-store-valid drawable)))
        ;; The window or one of its ancestors isn't mapped and this window has
        ;; no backing store.  This means that we have no place to put graphics,
        ;; even if we wanted to.  If the user wants to save graphics on this
        ;; window then the window needs to be created with a backing store, or
        ;; all of its ancestors need to be mapped.
	(return-from exit nil))
      (WHEN (AND (NULL (WINDOW.OCCLUSION-STACK DRAWABLE))
		 (not (window.backing-store-valid drawable)))
        ;; The occlusion stack indicates that this window isn't visible at all.
        ;; Check to see if we have a backing store.  If so, we will do our drawing
        ;; there so that if the window becomes partially visible we will be able
        ;; to see what was drawn.  If we don't have a backing store then we have
        ;; no place to put our graphics.
	(return-from exit nil)))
    t))

(DEFUN VALIDATE-BACKING-STORE (WINDOW &optional create-p background-p)
  "Make sure that the backing store is of the proper size.
2Returns the backing-store pixmap.*"
  ;; This function makes sure that the size of the backing matches
  ;; the size of WINDOW.  If one changes the size of a window, we wait
  ;; until graphics are done to the window before we update the backing
  ;; store.  In this way, we avoid creating unnecessary pixel arrays.
  (DECLARE (TYPE WINDOW WINDOW))
  (LET* ((backing-store (WINDOW.BACKING-STORE WINDOW))
	 (WINDOW-WIDTH  (WINDOW.WIDTH  WINDOW))
	 (WINDOW-HEIGHT (WINDOW.HEIGHT WINDOW))
	 (old-backing-store backing-store))
    (if backing-store
	(let ((BACKING-STORE-WIDTH (PIXMAP.WIDTH  BACKING-STORE))
	      (BACKING-STORE-HEIGHT (PIXMAP.HEIGHT BACKING-STORE)))
	  (WHEN (OR (NOT (= BACKING-STORE-WIDTH  WINDOW-WIDTH))
		    (NOT (= BACKING-STORE-HEIGHT WINDOW-HEIGHT)))
	    (SETQ BACKING-STORE (CREATE-PIXMAP WINDOW WINDOW-WIDTH WINDOW-HEIGHT
					       (DRAWABLE-DEPTH WINDOW)))
	    (X-BITBLT GX-COPY
		      (MIN BACKING-STORE-WIDTH  WINDOW-WIDTH)
		      (MIN BACKING-STORE-HEIGHT WINDOW-HEIGHT)
		      (PIXMAP.ARRAY old-backing-store) 0 0
		      (PIXMAP.ARRAY BACKING-STORE)     0 0)
	    (SETF (WINDOW.BACKING-STORE WINDOW) BACKING-STORE)))
      (when create-p
	(SETq backing-store (CREATE-PIXMAP
			      WINDOW
			      (WINDOW.WIDTH  WINDOW)
			      (WINDOW.HEIGHT WINDOW)
			      (DRAWABLE-DEPTH WINDOW)))
	(setf (window.backing-store-valid window) nil)
	(LET ((BACKGROUND-PIXMAP (WINDOW-BACKGROUND WINDOW)))
	  (when (and background-p
		     (not (eql BACKGROUND-PIXMAP universal-none)))
	    (X-BITBLT GX-COPY (WINDOW.WIDTH WINDOW) (WINDOW.HEIGHT WINDOW)
		      (PIXMAP.ARRAY BACKGROUND-PIXMAP) 0 0
		      (PIXMAP.ARRAY BACKING-STORE) 0 0)
	    (setf (window.backing-store-valid window) t)))
	(setf (WINDOW.BACKING-STORE WINDOW) backing-store)))
    backing-store))

;;; The following macro calls are here to make Zmacs indent the LABELS functions properly.
(DOLIST (SYMBOL '(STIPPLED-P TILED-P OPAQUE-STIPPLED-P PERFORM-TILING PERFORM-OPAQUE-STIPPLING
                             SIMPLE-DESTINATION-RENDER COPY-TO-BACKING-STORE))
  (SETF (GET SYMBOL 'ZWEI:LISP-INDENT-OFFSET) '(1 1)))

(DEFCONSTANT POLY-TEXT-GC-MAPPING-TABLE
             (LET ((ALU-MAPPER (MAKE-ARRAY 16 :ELEMENT-TYPE 'FIXNUM)))
               (LOOP FOR X-ALU FROM 0 BELOW (LENGTH ALU-MAPPER)
                     FOR MAPPED-ALU = (LOGIOR #b0100 (LOGAND #b0011 X-ALU))
                     DO (SETF (AREF ALU-MAPPER X-ALU) MAPPED-ALU))
               ALU-MAPPER)
  "This array maps an X alu for drawing text into an X alu such that a 0 pixel has no effect
and a 1 pixel does what is expected.  For text drawing the 0 pixels aren't really drawn, they
are just filler for the 1 pixels.  The 1 pixels are combined with the destination pixels to
form the image.")

(defun drawing-epilogue (temporary-bitmap drawable drawable-boundaries gcontext
                         drawable-has-children drawn-on-temporary)
  "Finish up a complex drawing operation by drawing from a temporary
array to the drawable."
  (if (null drawn-on-temporary)
      nil  ;(when (window-p drawable) (refresh-from-backing-store drawable)) ;1; ****** HACK ALERT *******
    
    (let* ((window-p (typep drawable 'window))
	   (occlusion-stack (if window-p
				(window.occlusion-stack drawable)
			      ;;ELSE
			      ;; T means that nothing is occluded.
			      t))
	   (backing-store (and window-p (window.backing-store-valid drawable)
			       (pixmap.array (window.backing-store drawable))))
	   (drawable-width  (box.width  drawable-boundaries))
	   (drawable-height (box.height drawable-boundaries))
	   (drawable-x      (box.left   drawable-boundaries))
	   (drawable-y      (box.top    drawable-boundaries))
	   (destination (device-private-array drawable))
	   )
      ;; We did all drawing to a temporary array because the real drawing operation
      ;; was too complex.  We'll need to finish up by drawing from the temporary
      ;; array through the stipple/tile/clip-mask onto the drawable.
      (when (and (typep drawable 'window)
		 (not (window.mapped-p drawable))
		 (window.backing-store drawable))
	;; This window isn't mapped but it has a backing store.  What really is supposed
	;; to happen is that the backing store gets updated and we leave the window alone.
	;; Note that this differs from the case of a mapped window with a backing store.
	;; In that case we need to both update the part of the window that is visible in
	;; addition to updating the backing store.
	(setq drawable (window.backing-store drawable))
	(setq window-p nil
	      backing-store nil))
      
      (let* ((destination-x drawable-x)
	     (destination-y drawable-y)
	     (temporary-bitmap-array (and (typep temporary-bitmap 'pixmap)
					  (pixmap.array temporary-bitmap)))
	     (fill-style  (gcontext.fill-style gcontext))
	     (tile        (gcontext.tile gcontext)))
	;1; Offset destination by window coordinates*
	(when window-p
	  (incf destination-x (window.absolute-inside-x drawable))
	  (incf destination-y (window.absolute-inside-y drawable)))
	
	(labels ((copy-to-backing-store ()
		   (cond ((tiled-p)
			  (perform-tiling backing-store drawable-x drawable-y))
			 ((opaque-stippled-p)
			  (perform-opaque-stippling backing-store drawable-x drawable-y))
			 (t
			  ;1; Note: This works for monochrome only*
			  (x-bitblt (aref poly-text-gc-mapping-table (obtain-x-alu gcontext))
				    drawable-width drawable-height
				    temporary-bitmap-array drawable-x drawable-y
				    backing-store drawable-x drawable-y))))
		 
		 (simple-destination-render ()
		   ;1; If foreground-tile is all ones, this is essentially a bitblt using alu-ior*
		   ;1; If foreground-tile is all zeros, this is essentially a bitblt using alu-andca*
		   ;1; Note: This works for monochrome only*
		   (let ((alu (aref poly-text-gc-mapping-table (obtain-x-alu gcontext))))
		     (x-bitblt-boxes alu drawable-width drawable-height
				     temporary-bitmap-array drawable-x drawable-y
				     destination destination-x destination-y
				     occlusion-stack)))
		 
		 (tiled-p ()
		   (= fill-style fill-style-tiled))
		 
		 (opaque-stippled-p ()
		   (= fill-style fill-style-opaque-stippled))
		 
		 (perform-tiling (destination destination-x destination-y &optional stipple-p)
		   (let ((tile-array (pixmap.array tile)))
		     (if (and (= (array-total-size tile-array) 1)	; Only 1 pixel.
			      (= (aref tile-array 0 0) (gcontext.foreground-pixel gcontext)))
			 ;; We really don't have much of a tile, since this is
			 ;; just like not having one at all.
			 (simple-destination-render)
		       ;;ELSE
		       ;1; tiling without bitblt-under-mask*
		       (let ((alu (aref poly-text-gc-mapping-table (if stipple-p (obtain-x-alu gcontext) gx-copy)))
			     (origin (gcontext.pattern-originp gcontext)))
			 ;1; Set bits in destination where drawing goes to background pixel*
			 (x-bitblt-boxes (if (or (not stipple-p)
						 (zerop (gcontext.background-pixel gcontext)))
					     gx-and-inverted gx-or)
					 drawable-width drawable-height
					 temporary-bitmap-array drawable-x drawable-y
					 destination destination-x destination-y
					 occlusion-stack)
			 ;1; Clear bits in drawing where tile isn't*
			 (x-bitblt gx-and
				   drawable-width drawable-height
				   tile-array
				   (mod (point.x origin) (pixmap.width tile))
				   (mod (point.y origin) (pixmap.height tile))
				   temporary-bitmap-array drawable-x drawable-y)
			 ;1; Move bits from drawing to destination*
			 (x-bitblt-boxes alu
					 drawable-width drawable-height
					 temporary-bitmap-array drawable-x drawable-y
					 destination destination-x destination-y
					 occlusion-stack)))))
		 
		 (perform-opaque-stippling (destination destination-x destination-y)
		   ;1; Monochrome *opaque sti1ppling is just tiling using the stipple*
		   (setq tile (gcontext.stipple gcontext))
		   (perform-tiling destination destination-x destination-y t)))
	  
	  ;; Function body starts here.
	  
	  ;1; Clip the temporary-bitmap with a gcontext clip-mask or clipping rectangle*
	  (when (and (gcontext.clip-p gcontext)	;1 Clip mask*
		     (gcontext.clip-mask gcontext))
	    (let ((origin    (gcontext.clip-origin gcontext))
		  (clipping-mask (gcontext.clip-mask   gcontext)))
	      (x-bitblt-clipped
		gx-and (pixmap.width clipping-mask) (pixmap.height clipping-mask)
		(pixmap.array clipping-mask) 0 0
		temporary-bitmap-array (point.x origin) (point.y origin))))
	  
	  ;; Next we need to check for a stipple so that we can combine
	  ;; it with the child clip-mask.
	  (when (and (= fill-style fill-style-stippled)
		     (gcontext.stipple gcontext))
	    (let* ((stipple (gcontext.stipple gcontext))
		   (origin (gcontext.pattern-originp gcontext)))
	      (x-bitblt gx-and drawable-width drawable-height
			(pixmap.array stipple)
			(mod (point.x origin) (pixmap.width stipple))
			(mod (point.y origin) (pixmap.height stipple))
			temporary-bitmap-array drawable-x drawable-y)))
	  
	  ;; We need to copy this part to the backing store (if there is one)
	  ;; because the backing store should not reflect any children.
	  (when backing-store
	    (copy-to-backing-store))
	  
	  ;1; Clip window by children*
	  (when (and (= (gcontext.subwindow-mode gcontext) subwindow-mode-clip-by-children)
		     drawable-has-children)
	    (loop for child being the xwindow-children of drawable
		  when (AND (window.mapped-p child)
                            (NOT (EQL (window.class child) input-only))) do
		  (draw-rectangle temporary-bitmap
				  (- (window.x child) 0)
				  (- (window.y child) 0)
				  (window.outside-width  child)
				  (window.outside-height child)
				  0)))
	  
	  ;; Now we have a completely rendered image.  What comes next is to
	  ;; combine this with the tile, if any is specified, and move it to
	  ;; the real destination.  Since we have 2 different kinds of tiles
	  ;; we need to handle both of them.
	  (cond ((fill-style-solid-p gcontext)
		 ;; Nothing special to do so we just tile with the1 *foreground tile.
		 (simple-destination-render))
		((tiled-p)
		 (perform-tiling destination destination-x destination-y))
		((opaque-stippled-p)
		 ;; The only thing left is fill-style of opaque-stippled.  
		 (perform-opaque-stippling
		   destination destination-x destination-y))
		(t ;1; just in case...*
		 (simple-destination-render)))))
      (when (typep temporary-bitmap 'pixmap)
	(deallocate-resource 'pixmap temporary-bitmap)))))

(defun x-bitblt-boxes (X-ALU WIDTH HEIGHT
		       SOURCE SOURCE-X SOURCE-Y
		       DEST DEST-X DEST-Y
		       &OPTIONAL (OCCLUSION-STACK T))
  (if (eq occlusion-stack t)
      (x-bitblt X-ALU WIDTH HEIGHT
		SOURCE SOURCE-X SOURCE-Y
		DEST DEST-X DEST-Y)
    (DOLIST (BOX OCCLUSION-STACK)
      (let ((X (BOX.LEFT BOX))
	    (Y (BOX.TOP  BOX))
	    (BOX-WIDTH  (BOX.WIDTH  BOX))
	    (BOX-HEIGHT (BOX.HEIGHT BOX)))
	;; Since the occlusion stack might be outside of the destination, make
	;; sure that it is inside.  This may happen since the occlusion stack
	;; relates to the entire window, including the borders, while graphics
	;; drawn on the destination only relate to the interior part of the
	;; window.
	;; Adjust when the occlusion stack includes the left border.
	(WHEN (< X DEST-X)
	  (DECF BOX-WIDTH (- DEST-X X))
	  (SETQ X DEST-X))
	;; Adjust when the occlusion stack includes the top border.
	(WHEN (< Y DEST-Y)
	  (DECF BOX-HEIGHT (- DEST-Y Y))
	  (SETQ Y DEST-Y))
	(WHEN (> (+ X BOX-WIDTH) (+ DEST-X WIDTH))
	  ;; This point is outside of the destination completely.
	  (SETQ BOX-WIDTH (- (+ DEST-X WIDTH) X)))
	(WHEN (> (+ Y BOX-HEIGHT) (+ DEST-Y HEIGHT))
	  ;; This point is outside of the destination completely.
	  (SETQ BOX-HEIGHT (- (+ DEST-Y HEIGHT) Y)))
	(WHEN (AND (PLUSP BOX-WIDTH) (PLUSP BOX-HEIGHT))
	  (x-BITBLT x-alu BOX-WIDTH BOX-HEIGHT
		    source (+ source-x (- X DEST-X)) (+ source-y (- Y DEST-Y))
		    DEST x y))))))

(ZWEI:DEFINE-INDENTATION DRAW-OCCLUDED-RECTANGLE (1 1))
(ZWEI:DEFINE-INDENTATION DRAW-WINDOW-RECTANGLE (1 1))

(DEFUN FILL-RECTANGLE (DRAWABLE GCONTEXT X Y WIDTH HEIGHT PIXEL)
  "Fill a rectangle, taking into account any children in the drawable."
  (LET ((OCCLUSION-STACK (AND (TYPEP DRAWABLE 'WINDOW) (WINDOW.OCCLUSION-STACK DRAWABLE))))
    (LABELS ((DRAW-WINDOW-RECTANGLE (DRAWABLE X Y WIDTH HEIGHT)
               "Draw a rectangle onto drawable taking into account the clip-mask of the gcontext."
	       (COND ((not (GCONTEXT.CLIP-P GCONTEXT))       ;1 Normal, simple case, no clip mask*
		      (DRAW-RECTANGLE DRAWABLE X Y WIDTH HEIGHT PIXEL))
		     ((gcontext.clip-mask gcontext)
		      ;; We have a clip-mask, which is the most general case.  We need to
		      ;; combine the clip-mask with the rectangle we are trying to draw
		      ;; to obtain the pixels on the drawable that are to be filled.
		      (using-resource (TEMP-RECTANGLE pixmap DRAWABLE WIDTH HEIGHT 1 0)
			;; Copy only those bits of the clip mask that are inside
			;; of the rectangle we are trying to draw.
			(COPY-ARRAY-CLIPPED WIDTH HEIGHT NIL
					    (GCONTEXT.CLIP-MASK GCONTEXT)
					    (- (POINT.X (GCONTEXT.CLIP-ORIGIN GCONTEXT)))
					    (- (POINT.Y (GCONTEXT.CLIP-ORIGIN GCONTEXT)))
					    TEMP-RECTANGLE 0 0)
			(x-BITBLT (if (zerop pixel) gx-and-inverted gx-or)
				  WIDTH HEIGHT
				  TEMP-RECTANGLE 0 0
				  (DEVICE-PRIVATE-DRAWABLE DRAWABLE) X Y)))
		     ;1; Clip to a single clipping rectangle*
		     ((GCONTEXT.clip-rectangle GCONTEXT)
		      (LET ((BOX-TO-DRAW
			      (nintersect-boxes
				(MAKE-BOX :LEFT X :TOP Y :WIDTH WIDTH :HEIGHT HEIGHT)
				(GCONTEXT.clip-rectangle GCONTEXT))))
			(DRAW-RECTANGLE DRAWABLE (BOX.LEFT BOX-TO-DRAW) (BOX.TOP BOX-TO-DRAW)
					(BOX.WIDTH BOX-TO-DRAW) (BOX.HEIGHT BOX-TO-DRAW)
					PIXEL)))
		     ;1; Else no clip-rectangle, nothing to draw*
		     ))

             (DRAW-OCCLUDED-RECTANGLE (X-OR-BOX &OPTIONAL Y WIDTH HEIGHT)
             "Draw a rectangle through the occlusion stack.  The argument X-OR-BOX
              is either an X coordinate, or is a box object."
             ;; This added complexity is trying to avoid creating a box object when
             ;; we already have one.
             (LET* ((BOX-P (TYPEP X-OR-BOX 'BOX))
                    (X X-OR-BOX))
               (WHEN BOX-P
                 ;; We have a box.  Initialize the other arguments from the parts of the box.
                 (SETQ X      (BOX.LEFT   X-OR-BOX)
                       Y      (BOX.TOP    X-OR-BOX)
                       WIDTH  (BOX.WIDTH  X-OR-BOX)
                       HEIGHT (BOX.HEIGHT X-OR-BOX)))
               (IF (EQ OCCLUSION-STACK T)
                   ;; Simple case.  The window is fully visible, so we just draw the rectangle.
                   (DRAW-WINDOW-RECTANGLE DRAWABLE X Y WIDTH HEIGHT)
                   ;;ELSE
                   (LET* ((window-x (window.absolute-inside-x drawable))
			  (window-y (window.absolute-inside-y drawable))
			  ;1; Translate the box to draw to absolute coordinates*
			  (RECTANGLE-BOX (MAKE-BOX :LEFT (+ X window-x) :TOP  (+ Y window-y)
						   :WIDTH WIDTH :HEIGHT HEIGHT)))
                     ;; Go through the occlusion stack to find a box which overlaps the rectangle
                     ;; we are trying to draw.
                     (DOLIST (BOX OCCLUSION-STACK)
                       (WHEN (BOX-INTERSECT-P BOX RECTANGLE-BOX)
                         ;; Draw part of our rectangle where the two boxes intersect.
                         (LET ((COMMON-BOX (INTERSECT-BOXES BOX RECTANGLE-BOX)))
			   (when common-box
			     (DRAW-WINDOW-RECTANGLE
			       DRAWABLE ;1; get window-relative x/y coordinates*
			       (- (BOX.LEFT COMMON-BOX) window-x)
			       (- (BOX.top COMMON-BOX) window-y)
			       (BOX.WIDTH COMMON-BOX) (BOX.HEIGHT COMMON-BOX)))))))))))
      (IF (TYPEP DRAWABLE 'WINDOW)
          (PROGN
            ;; If this window has a backing store, then we need to draw the rectangle there too.
	    (WHEN (window.backing-store-valid drawable)
	      (DRAW-WINDOW-RECTANGLE (window.backing-store drawable) X Y WIDTH HEIGHT))
            ;; If the window isn't mapped then all we needed to do is to update the backing
            ;; store.  If the window is mapped then we need to update the window too.
            (WHEN (AND (WINDOW.MAPPED-P DRAWABLE)
                       (NOT (EQL (window.class drawable) input-only)))
              (IF (OR (= (GCONTEXT.SUBWINDOW-MODE GCONTEXT) SUBWINDOW-MODE-INCLUDE-INFERIORS)
                      (TYPEP DRAWABLE 'PIXMAP)
                      (NULL (LOCATE-FIRST-CHILD DRAWABLE)))
                  ;; Simple case: include-inferiors subwindow mode, or there are no children.
                  (DRAW-OCCLUDED-RECTANGLE X Y WIDTH HEIGHT)
                  ;;1ELSE*
                  ;; The subwindow mode is clip-by-children and we have children.  Only
                  ;; fill the part of the window that is not in the children.
                  (LET ((CHILD-INTERSECTS-RECTANGLE NIL))
                    ;; First, see if we need to deal with the children at all.
		    (loop for child being the xwindow-children of drawable
			  when (AND (WINDOW.MAPPED-P child)
                                    (NOT (EQL (window.class child) input-only))) do
			  (unless (OR
				    ;; Window below the rectangle?
				    (> (WINDOW.Y CHILD) (+ Y HEIGHT -1))
				    ;; Window above the rectangle?
				    (< (+ (WINDOW.Y CHILD) (WINDOW.OUTSIDE-HEIGHT CHILD) -1)
				       Y)
				    ;; Window to the left of the rectangle?
				    (< (+ (WINDOW.X CHILD) (WINDOW.OUTSIDE-WIDTH  CHILD) -1)
				       X)
				    ;; Window to the right of the rectangle?
				    (> (WINDOW.X CHILD) (+ X WIDTH -1)))
                            (SETQ CHILD-INTERSECTS-RECTANGLE T)
                            (RETURN NIL)))
                    (IF CHILD-INTERSECTS-RECTANGLE
                          ;; Create boxes which are those parts of the rectangle which can be
                          ;; drawn.  Note that the (X,Y) coordinates are relative to the
                          ;; inside of the drawable.
                        (let ((RECTANGLE-BOX (INTERSECT-BOXES
					       ;; Box for the rectangle.
					       (MAKE-BOX :LEFT X :TOP Y
							 :WIDTH WIDTH :HEIGHT HEIGHT)
					       ;; Box for the drawable.
					       (MAKE-BOX :LEFT   0
							 :TOP    0
							 :WIDTH  (WINDOW.WIDTH    DRAWABLE)
							 :HEIGHT (WINDOW.HEIGHT   DRAWABLE)))))
                          (LOOP for child being the xwindow-children of drawable
				when (AND (WINDOW.MAPPED-P child)
                                          (NOT (EQL (window.class child) input-only))) do
				(SETQ RECTANGLE-BOX (SUBTRACT-BOX
						      RECTANGLE-BOX
						      (MAKE-BOX
							:LEFT   (WINDOW.X              CHILD)
							:TOP    (WINDOW.Y              CHILD)
							:WIDTH  (WINDOW.OUTSIDE-WIDTH  CHILD)
							:HEIGHT (WINDOW.OUTSIDE-HEIGHT CHILD)))))
                          (LOOP FOR RECTANGLE IN RECTANGLE-BOX
                                DO (DRAW-OCCLUDED-RECTANGLE RECTANGLE)))
                        ;;1ELSE*
                        ;; None of the children overlap this rectangle, so we can just draw
                        ;; it since there will be no interference.
                        (DRAW-OCCLUDED-RECTANGLE X Y WIDTH HEIGHT))))))
          ;;1ELSE*
          ;; Simple case: a pixmap, which can't have inferiors.
          (DRAW-RECTANGLE DRAWABLE X Y WIDTH HEIGHT PIXEL)))))


(defun add-refresh-region (window box)
  ;1; Grow the region in window needing refresh*
  (let ((invalid-box (window.invalid-box window)))
    (if (box-p invalid-box)
	(setf (window.invalid-box window) (union-boxes invalid-box box))
      (setf (window.invalid-box window) box)
      (pushnew window *windows-needing-refresh*))))


(defun refresh-from-backing-store (window &optional (box (window.invalid-box window)))
  ;1; Copy from backing store to the screen*
  (when (and box
	     (window.backing-store-valid window)
	     (window.mapped-p window)
             (NOT (EQL (window.class window) input-only)))
    (when (eq box t) (setq box (make-window-box-interior window)))
    (server-trace "~%Refreshing #x~x from backing store" (window.id window))
    (let* ((backing-store (pixmap.array (window.backing-store window)))
	   (occlusion-stack (window.occlusion-stack window))
	   (box (window.invalid-box window))
	   (drawable-width  (box.width  box))
	   (drawable-height (box.height box ))
	   (drawable-x      (box.left   box))
	   (drawable-y      (box.top    box))
	   (destination (device-private-array window)))
      
      ;1; Need to clip to mapped children when drawable-has-children*
      (x-bitblt-boxes gx-copy
		      drawable-width drawable-height
		      backing-store
		      (- drawable-x (window.absolute-inside-x window))
		      (- drawable-y (window.absolute-inside-y window))
		      destination drawable-x drawable-y
		      occlusion-stack)
      (setf (window.invalid-box window) nil))
    t))

(defun tile-pixmap (pixmap)
  ;1; The explorer requires the source array to bitblt to have a width that's a multiple of 32*
  ;1; This function ensures that the pixmap is tiled with its source out to a multiple of 32.*
  (if (pixmap.tiled-p pixmap)
      pixmap
    (let* ((width (pixmap.width pixmap))
	   (height (pixmap.height pixmap))
	   (array (pixmap.array pixmap))
	   (new-width (loop for i from 1 to width
			    when (ZEROP (REM (* 32 I) WIDTH))
			    return (* 32 i)))
	   (new-array (if (= new-width width) array
			(MAKE-ARRAY `(,HEIGHT ,new-width)      
				    :ELEMENT-TYPE (array-element-type array)))))
      (loop for x from 0 below new-width by width
	    do (bitblt tv:alu-seta width height array 0 0 new-array x 0))
      (setf (pixmap.array pixmap) new-array
	    (pixmap.tiled-p pixmap) t)
      pixmap)))