;;; -*- 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 (b)(3)(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) 1987, Texas Instruments Incorporated. All rights reserved.

;;; Change history:
;;;
;;;  Date       Author	Description
;;; -------------------------------------------------------------------------------------
;;; 03/02/89	WJB	Patch 1.28; Fix change-window-attr to restore default root background 
;;;			when set to Universal-None
;;; 01/26/89	WJB	Remove cursor during change-window-attributes if necessary.
;;; 01/18/88    LGO	Return correct map-installed bit from Get-Window-Attributes.
;;; 01/18/88    LGO	When Change-Window-Attributes changes the border, redraw it.
;;; 12/212*/88    LGO	1When setting a new cursor, don't free the old one.*
;;; 12/21/88    LGO	1Don't call Create-Notify-Event from create-window when there are errors.*
;;; 12/21/88    LGO	1Use the root-cursor constant instead of make-root-cursor in change-window-attributes.*
;;; 12/16/88    DAN	Fix CREATE-WINDOW to call EVENT-SELECT-FOR-WINDOW when EVENT-MASK
;;;			is NOT specified rather than when it is specified.
;;; 12/07/88	WJB	1In Change-Window-Attributes, detect when window cursor is set to Universal-None.*
;;; 11/28/88	WJB	1In Change-Window-Attributes, propagate change in cursor to window.cursor slot.*
;;; 11/23/88    LGO	Don't barf on bad do-not-propigate masks in
;;;			change-window-attributes when *mit-compatability* is T
;;; 10/27/88    DAN/LGO Fixed change-window-attributes to not stop
;;;			when a background pixmap is specified
;;; 10/21/88    DAN     Fixed GET-WINDOW-ATTRIBUTES to send out colormap correctly.
;;; 10/118*/88    LGO     1Don't barf on *Override-Redirect1 for input-only windows in *change-window-attributes
;;; 10/10/88    LGO     Fix 1CREATE*-WINDOW to handle the only child case correctly.
;;;  9/30/88    LGO     1Ensure window-background tile and border are tiled pixmaps*
;;;  9/07/88    LGO	1Fixed CREATE-WINDOW-REQUEST to eliminate NIL values in window next/prev-sibling slots*
;;;  9/016*/88    LGO	1Fixed *Get-Window-Attributes1 to handle colormap copy-from-parent*
;;;  6/06/88    TWE	Fixed CHANGE-WINDOW-ATTRIBUTES to properly compare the visuals of
;;;			the colormap and the window.
;;;  5/23/88    DAN	Added padding to GET-GEOMETRY request.
;;;  5/10/88    TWE	Fixed Get-Window-Attributes to look at the colormap better.
;;;  4/26/88    TWE	Changed accessor to SCREEN-INFO.SCREENS SCREEN-INFO to use NTH.
;;;  4/04/88    TWE	Moved colormap-notify-event to the colormap file.
;;;  3/01/88    TWE	Added a call to EVENT-SELECT-FOR-WINDOW when a window gets
;;;			created or modified, just like the C code does.
;;;  2/19/88    TWE	Set up the client slot for the window structure.
;;;  2/19/881 *  1  *KDB	1Added  missing function to get id  of screen-root-window in *Get-Geometry1-Request.*
;;;  2/05/88    TWE	Updated to reflect the new fact that the window's event-masks
;;;			slot is a list of state/mask pairs.
;;;  1/25/88    TWE	Updated change-window-attributes to create a backing store when
;;;			Always is specified.
;;; 12/21/87    TWE	Fixed create-window to properly initialize the absolute (X,Y)
;;;			position of the window.  Fixed create-window to link the window
;;;			into the window hierarchy, as specified by the protocol spec.
;;; 12/18/87    TWE	Set up the default attributes for a window in create-window.
;;; 12/15/87    TWE	Moved requests from the REQUESTS file.

(defreq Change-Window-Attributes ((window WINDOW)
				  (value-mask (BITMASK All-Window-Attribute-Masks))
				  (:long))
  (with-cursor-locked (:server)
    (maybe-remove-cursor window)
    (with-window-locked (window)
      (change-window-attributes window state value-mask longs long-offset))))

(defun change-window-attributes (window state value-mask longs index)
  (server-trace-value-mask value-mask longs index
    '#( Back-Pixmap Back-Pixel Border-Pixmap Border-Pixel
       Bit-Gravity Win-Gravity Backing-Store Backing-Planes Backing-Pixel
       Override-Redirect Save-Under Event-Mask Dont-Propagate Colormap Cursor))
  (if (and (eql (window.class window) Input-Only)
	   (logtest value-mask (lognot (logior CW-Win-Gravity CW-Event-Mask
					       CW-Override-Redirect
					       CW-Dont-Propagate CW-Cursor))))
      (Bad-Match)
      ;;1ELSE*
    (process-values
      (value-mask longs index)
      (val)
      (((CW-Back-Pixmap (ONEOF PIXMAP Universal-None Parent-Relative) val :errors)
	(cond ((and (eql val Parent-Relative)
		    (window.parent window)
		    (not (eq (drawable.trait window)
			     (drawable.trait (window.parent window)))))
	       (Bad-Match))
	      ((and (not (member val '(#,Universal-None #,Parent-Relative)))
		    (not (eq (drawable.trait window) (drawable.trait val))))
	       (Bad-Match))
	      ((pixmap-p val)
	       (setf (window-background window) (tile-pixmap val))
               nil)
	      ((and (null (window.parent window))
			  (member val '(#,universal-none #,parent-relative)))
	       ;; Restore the default root background
	       (setf (window-background window) root-background-pixmap))
	      (t
	       (setf (window-background window) val)
               nil)))
       ((CW-Back-Pixel CARD32)
	;; We have a background pixel.  Create a pixmap
	;; that just contains that pixel.
	(setf (window-background window) (create-pixmap window 1 1 (drawable-depth window) val))
	;; Save the pixel value away too, just in case we need it.
	(setf (window.background-pixel window) val))
       ((CW-Border-Pixmap (ONEOF PIXMAP Copy-From-Parent) val :errors)
	(cond ((and (eql val Copy-From-Parent)
		    (window.parent window)
		    (not (eq (drawable.trait window)
			     (drawable.trait (window.parent window)))))
	       (Bad-Match))
	      ((and (not (eql val Copy-From-Parent))
		    (not (eq (drawable.trait window) (drawable.trait val))))
	       (Bad-Match))
	      ((pixmap-p val)
	       (setf (window-border window) (tile-pixmap val))
	       (draw-borders window) 
               nil)
	      (t
	       (setf (window-border window) val)
	       (draw-borders window) 
               nil)))
       ((CW-Border-Pixel CARD32 val)
	;; We have a border pixel.  Create a pixmap that just contains that pixel.
	(setf (window-border window) (create-pixmap window 1 1
						    (drawable-depth window)
						    val))
	;; Save the pixel value away too, just in case we need it.
	(setf (window.border-pixel window) val)
	(draw-borders window))
       ((CW-Bit-Gravity (CARD8 Forget-Gravity North-West-Gravity North-Gravity
			       North-East-Gravity West-Gravity Center-Gravity
			       East-Gravity South-West-Gravity South-Gravity
			       South-East-Gravity Static-Gravity))
	(setf (window.bit-gravity window) val))
       ((CW-Win-Gravity (CARD8 Unmap-Gravity North-West-Gravity North-Gravity
			       North-East-Gravity West-Gravity Center-Gravity
			       East-Gravity South-West-Gravity South-Gravity
			       South-East-Gravity Static-Gravity))
	(setf (window.win-gravity window) val))
       ((CW-Backing-Store (CARD8 Store-Not-Useful Store-When-Mapped Store-Always))
	(setf (window.backing-store-support window) val))
       ((CW-Backing-Planes CARD32)
	(setf (window.backing-planes window) val))
       ((CW-Backing-Pixel CARD32)
	(setf (window.backing-pixel window) val))
       ((CW-Override-Redirect BOOL)
	(setf (window.override-redirect window) val))
       ((CW-Save-Under BOOL)
	(setf (window.save-under-support window) val))
       ((CW-Event-Mask (MASKBITS All-Event-Masks
				 ;; The progn says to evaluate the
				 ;; Event-Mask-Length-Type to read
				 ;; in the proper number of bits.
				 (progn Event-Mask-Length-Type)))
	;; I commented the following line out after seeing that the C code only calls
	;; EVENT-SELECT-FOR-WINDOW.  (twe)
	;;(setf (window-event-masks window) val)
	;;(server-trace "~%$$IN CHANGE-WINDOW-ATTRIBUTES-EVENT-MASK: value= ~s"
                      ;;(xlib:make-event-keys val))
	(EVENT-SELECT-FOR-WINDOW WINDOW STATE VAL)
	)
       ((CW-Dont-Propagate (MASKBITS (if *mit-compatibility* All-Event-Masks
				       All-Device-Event-Masks)
				     ;; The progn says to evaluate the
				     ;; Device-Event-Masks-Length-Type to
				     ;; read in the proper number of bits.
				     (progn Event-Mask-Length-Type)))
	(setf (window-dont-propagate window) (logand  All-Device-Event-Masks val)))
       ;1;This needs to check for visual and generate a ColorMapNotify Event.*
       ((CW-Colormap (ONEOF COLORMAP Copy-From-Parent) val :errors)
	(LET ((cmap val))
	  (WHEN (EQL cmap Copy-From-Parent)
            (IF (AND (window.parent window)
                     (EQ (window.visual window)
                         (window.visual (window.parent window))))
                (SETQ cmap (window.colormap (window.parent window)))
                ;1;ELSE*
                (SETQ cmap nil)))
          (COND ((NOT cmap)
                 (bad-match))
                ((NOT (EQ (window.visual (colormap.window cmap)) (window.visual window)))
                 (bad-match))
                ((NOT (EQ cmap (window.colormap window)))
                 (Colormap-Notify-Event window cmap T
                                        (if (member (window.colormap window)
                                                    *installed-colormaps*)
                                            colormap-installed
                                            ;;ELSE
                                            colormap-uninstalled))
                 nil))))
       ((CW-Cursor (ONEOF CURSOR Universal-None))
	(COND ((EQL val Universal-None)
	       ;1;install the new*
	       #+comment ;1; reference count is not maintained*
	       (when (window.cursor window)
		 (Free-Cursor (window.cursor window)))
	       (IF (null (window.parent window)) ;1; if the root*
		   (progn
		     (SETF (window.cursor window) root-cursor)
		     #+comment ;; reference count is not maintained
		     (INCF (cursor-record.ref-count root-cursor)))
		 ;1;ELSE*
		 (SETF (window.cursor window) nil)))
	      (t
	       (when val
		 #+comment ;1; reference count is not maintained*
		 (when (window.cursor window)
		   (Free-Cursor (window.cursor window)))
		 (SETF (window.cursor window) val))))
	(Window-Has-New-Cursor window))))))

(DEFUN ancestors-mapped (window)
  "2Returns t if the windows ancestors are all mapped*"
  (LOOP for ancestor first (window.parent window) then (window.parent ancestor)
        until (NULL ancestor)
        when (NOT (window.mapped-p ancestor))
        return nil
        finally (return t)))

(defreq Get-Window-Attributes ((window WINDOW))
  (with-window-locked (window)
    (MULTIPLE-VALUE-BIND (your-mask all-masks)
        (Event-Mask-for-Client window state)
      (let ((colormap 
	      (loop for win first window then (window.parent win)
		    for colormap = (window.colormap win)
		    unless (OR (eql colormap Copy-From-Parent)
			       (eql colormap Universal-None))
		    do (return (colormap.id colormap)))))
	(format-reply (state)
	  :byte (window.backing-store-support window)
	  :long (window.visual window)
	  :word (window.class window)
	  :byte (window.bit-gravity window)
	  :byte (window.win-gravity window)
	  :long (window.backing-planes window)
	  :long (window.backing-pixel window)
	  :byte (window.save-under-support window)
	  :byte (if (member colormap *installed-colormaps*)
		    True
		  False)
	  :byte (COND ((NOT (window.mapped-p window))
		       Window-Is-Unmapped)
		      ((ancestors-mapped window)
		       Window-Is-Viewable)
		      (t Window-Is-Unviewable))
	  :byte (window.override-redirect window)
	  :long colormap
	  :long all-masks
	  :long your-mask
	  :word (window-dont-propagate window))))
    (server-push state)))

(defreq Create-Window ((depth CARD8)
		       (window NEWID)
		       (parent WINDOW)
		       (x INT16)
		       (y INT16)
		       (width (CARD16 0))
		       (height (CARD16 0))
		       (border-width CARD16)
		       (class (CARD16 Inherit-From-Parent Input-Output Input-Only))
		       (visual CARD32)
		       (value-mask (BITMASK All-Window-Attribute-Masks))
		       (:long))
  (when (eql visual Inherit-From-Parent)
    (setq visual (window.visual parent)))
  (when (eql class Inherit-From-Parent)
    (setq class (window.class parent)))
  (when (and (zerop depth) (eql class Input-Output))
    (setq depth (drawable-depth parent)))
  (let* ((trait (find depth (screen.traits (drawable-screen parent))
		      :key #'drawable-trait.depth))
         (window-instance nil))
    (cond ((and (plusp depth) (null trait))
	   (Bad-Value depth))
	  ((AND trait (not (member visual (drawable-trait.visuals trait))))
	   (Bad-Value visual))
	  ((AND (eql class Input-Output)
                (eql (window.class parent) Input-Only))
           (Bad-Match))
          ((AND (EQL class Input-Only)
                (or (plusp border-width) (plusp depth)))
           (bad-match))
;	  ((if (eql class Input-Output)
;	       (eql (window.class parent) Input-Only)
;	       (or (plusp border-width) (plusp depth)))
;	   (Bad-Match))
	  (t
           (SETQ WINDOW-INSTANCE (MAKE-WINDOW
                                   :ID WINDOW
                                   :TYPE Draw-Window-Resource-Type
                                   :TRAIT (WINDOW.TRAIT PARENT)
                                   :CLIP-MASK NIL
                                   :VISUAL VISUAL
                                   ;; What is this?  For now, let's
                                   ;; just copy the parent's trait.
                                   :CLASS CLASS
                                   :PARENT PARENT
                                   :ABSOLUTE-X-CORNER (+ (WINDOW.ABSOLUTE-INSIDE-X PARENT) X)
                                   :ABSOLUTE-Y-CORNER (+ (WINDOW.ABSOLUTE-INSIDE-Y PARENT) Y)
                                   :X X
                                   :Y Y
                                   :WIDTH WIDTH
                                   :HEIGHT HEIGHT
                                   :BWIDTH BORDER-WIDTH
                                   :CLIENT STATE))
           (WITH-TREE-LOCKED (PARENT)
             ;; Shuffle the first child down to the sibbling for this window and
             ;; make this window the parent's first child.  The idea is to make
             ;; this window be at the top of the occlusion stack which is defined
             ;; by the sibbling ordering.  Use the following figure to aid in
             ;; understanding how this is being updated.  Assume the worst case of
             ;; a parent with three children: W1, W2 and W3.  We are inserting W
             ;; into this structure.  There are only four components of interest
             ;; here, with the initial value of a component appearing on the left
             ;; and if a component changes, the new value appears to the right of
             ;; the -->.  It is left up to the reader to verify that the cases of
             ;; a parent with no children and 1 child work too.
             ;;                                                                W
             ;;       	       	       	       	       	                 .-------------.
             ;;                                              first child |             |
             ;;                                                          |-------------|
             ;;                                               last child |             |
             ;;                                                          |-------------|
             ;;                                                next sib  | NIL --> W1  |
             ;;                                                          |-------------|
             ;;                                                prev sib  | NIL --> W3  |
             ;;                                                          `-------------'
             ;;
             ;;                     .-------------.
             ;;         first child | W1 --> W    |	                        W1
             ;;                     |-------------|                      .-------------.
             ;;          last child | W3          |          first child |             |
             ;; Parent              |-------------|                      |-------------|
             ;;           next sib  |             |           last child |             |
             ;;                     |-------------|                      |-------------|
             ;;           prev sib  |             |            next sib  | W2          |
             ;;                     `-------------'                      |-------------|
             ;;                                                prev sib  | W3 --> W    |
             ;;                                                          `-------------'
             ;;
             ;;
             ;;                                                                W2
             ;;                                                          .-------------.
             ;;                                              first child |             |
             ;;                                                          |-------------|
             ;;                                               last child |             |
             ;;                                                          |-------------|
             ;;                                                next sib  | W3          |
             ;;                                                          |-------------|
             ;;                                                prev sib  | W1          |
             ;;                                                          `-------------'
             ;;
             ;;
             ;;                                                                W3
             ;; 					                  .-------------.
             ;;                                              first child |             |
             ;;                                                          |-------------|
             ;;                                               last child |             |
             ;;                                                          |-------------|
             ;;                                                next sib  | W1 --> W    |
             ;;                                                          |-------------|
             ;;                                                prev sib  | W2          |
             ;;                                                          `-------------'
	     (let ((first-child (or (window.first-child parent) window-instance))
		   (last-child (or (window.last-child  parent) window-instance)))
	       (setf (window.next-sib window-instance) first-child)
	       (setf (window.prev-sib window-instance) last-child)
	       (setf (window.prev-sib first-child) window-instance)
	       (setf (window.next-sib last-child) window-instance)
	       (when (null (window.first-child parent))
		 ;; The parent previously had no children.  This window becomes both
		 ;; the first and last child.
		 (setf (window.last-child parent) window-instance)
		 ;1; the window is its own next and previous sibling*
		 (setf (window.prev-sib window-instance) window-instance)
		 (setf (window.next-sib window-instance) window-instance))
	       (setf (window.first-child parent) window-instance)))
           (STORE-RESOURCE WINDOW WINDOW-INSTANCE)
           ;; Set up the default attributes.
           (SETF (WINDOW-BACKGROUND            WINDOW-INSTANCE) UNIVERSAL-NONE)
           (SETF (WINDOW-BORDER                WINDOW-INSTANCE) COPY-FROM-PARENT)
           (SETF (WINDOW.BIT-GRAVITY           WINDOW-INSTANCE) FORGET-GRAVITY)
           (SETF (WINDOW.WIN-GRAVITY           WINDOW-INSTANCE) NORTH-WEST-GRAVITY)
           (SETF (WINDOW.BACKING-STORE-SUPPORT WINDOW-INSTANCE) STORE-NOT-USEFUL)
           (SETF (WINDOW.BACKING-PLANES        WINDOW-INSTANCE) -1)
           (SETF (WINDOW.BACKING-PIXEL         WINDOW-INSTANCE) 0)
           (SETF (WINDOW.SAVE-UNDER-SUPPORT    WINDOW-INSTANCE) FALSE)
           (SETF (WINDOW-EVENT-MASKS           WINDOW-INSTANCE) 0)
           (SETF (WINDOW.DO-NOT-PROPAGATE-MASK WINDOW-INSTANCE) NIL)
           (SETF (WINDOW.OVERRIDE-REDIRECT     WINDOW-INSTANCE) FALSE)
           (IF (OR (EQL class Input-Only)
                   (NOT (EQL visual (window.visual window-instance))))
               (SETF (window.colormap window-instance) UNIVERSAL-NONE)
               (SETF (window.colormap window-instance) COPY-FROM-PARENT))
           (SETF (WINDOW.CURSOR WINDOW-INSTANCE) nil)
           ;;(server-trace "~%IN CREATE-WINDOW: value-mask= ~s cw-event-mask= ~s"
                         ;;(xlib:make-event-keys value-mask) (xlib:make-event-keys cw-event-mask))
           (WHEN (NOT (LOGTEST VALUE-MASK CW-EVENT-MASK))
             ;; The user didn't1 *specify an event mask, we need to initialize this guy to 0.
             (EVENT-SELECT-FOR-WINDOW WINDOW-INSTANCE STATE 0))
           ;; Process the value-mask in change-window-attributes.
 	   (CHANGE-WINDOW-ATTRIBUTES WINDOW-INSTANCE STATE VALUE-MASK LONGS LONG-OFFSET)
;1???*	  (Window-Has-New-Cursor window-instance)
	   (Create-Notify-Event window-instance parent x y width height border-width
				(window.override-redirect window-instance))))
    window-instance))

(defreq Get-Geometry ((drawable PIXWIN))
  (let ((x 0)
	(y 0)
	(bwidth 0)
	width
	height)
    (if (pixmap-p drawable)
	(setq width (pixmap.width drawable)
	      height (pixmap.height drawable))
	(with-window-locked (drawable)
	  (setq x (window.x drawable)
		y (window.y drawable)
		width (window.width drawable)
		height (window.height drawable)
		bwidth (window.bwidth drawable))))
    (format-reply (state)
		  :byte (drawable-depth drawable)
		  :long (WINDOW.ID (screen-root-WINDOW (drawable-screen drawable)))
		  :word x
		  :word y
		  :word width
		  :word height
		  :word bwidth)
    (server-push state)))

;1;;------------------------------------------------------------------------*
;1;;EVENTS*
;1;;------------------------------------------------------------------------*
(DEFUN Create-Notify-Event (window parent x y width height border-width override-redirect)
  (DECLARE (type window window parent)
           (type integer x y width height border-width)
           (type boolean override-redirect))
  (LET ((event (make-event-create-notify :type Create-Notify-Event
                                         :window window
                                         :parent parent
                                         :x x
                                         :y y
                                         :width width
                                         :height height
                                         :border-width border-width
                                         :override override-redirect)))
    (deliver-events window event 1 nil)))