;;; -*- 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/09/89	WJB	Patch 1.35; remove reference to *state* in WINDOW-SUBSTRUCTURE-REDIRECT-MASK.
;;; 02/14/89    DAN     Patch 1.13; Change MEMBER to FIND in WINDOW-DONT-PROPAGATE. 
;;; 10/118*/88    1DLS*	1Fix *set-window-dont-propagate 1to not form dotted lists*
;;; 10/117*/88    LGO	1Remove the RESOURCE slot from the *OTHER-CLIENT 1structure*
;;; 10/12/88    LGO	Fix 1the setf for *window-dont-propagate 1to create correct event-mask structures*
;;; 10/12/88    LGO	Fix gross implementation of REMOVE-CLIENT
;;; 10/12/88    LGO	1Fix the setf for *WINDOW-EVENT-MASKS1 to avoid duplicate entries.*
;;; 10/12/88    LGO	Nuke DEFEVENT-MASKS, and everything it defines, because nobody uses it.
;;;  19*/07/88    1LGO*	1Use *Copy-From-Parent1 instead of* :parent1 for window-border and window-background*
;;;  6/07/88    DAN	Fixed event update functions to set and return the proper values.
;;;  3/28/88    TWE	Added accessor window.background.
;;;  3/04/88    TWE	Changed the accessors for WINDOW-EVENT-MASKS to be less dependent
;;;			on *STATE*.
;;;  2/19/88    TWE	Added a new slot to OTHER-CLIENT and some more comments.  Added
;;;			the function WINDOW-LEAST-COMMON-ANCESTOR (formerly WINDOW-LCA).
;;;			Also added the REMOVE-CLIENT function to delete a client from
;;;			the window.event-masks slot.  Added STORE-CLIENT-MASK to allow
;;;			one to update the MASK entry for a particular WINDOW's client.
;;;			Completely changed the meaning of the window.event-masks slot.
;;;			Instead of being a disembodied property list, it is now a list
;;;			of other-client structures.
;;;  2/16/88    TWE	Changed event mask accessors to use *STATE* instead of STATE.
;;;			Added more code to deal with other STATEs.
;;;  2/05/88    TWE	Fixed up the event-mask accessors to reflect the real content of
;;;			the event-masks slot.  Added new accessors for the event-masks
;;;			slot.
;;; 12/18/87    TWE	Fixed up the event-mask accessors.
;;; 12/16/87    TWE	Defined accessors for the event-masks slot in the window data
;;;			structure.  Added window attributes that were missing.

;;; From /server/include/inputstr.h
(DEFSTRUCT (OTHER-CLIENT (:CONC-NAME "OTHER-CLIENT.") (:print-function print-other-client))
  ;; Which client is selecting on this window.
1   *;; Implementation note: the `dont-propagate' event mask is indicated by a state of NIL.
  (CLIENT   :UNBOUND :TYPE (or null STATE))
  (MASK     :UNBOUND :TYPE INTEGER))

(DEFUN WINDOW-SUBSTRUCTURE-REDIRECT-MASK (WINDOW STATE)
  (LOOP FOR OTHER-CLIENT IN (WINDOW.EVENT-MASKS WINDOW)
        WHEN (LOGTEST SUBSTRUCTURE-REDIRECT-MASK (OTHER-CLIENT.MASK OTHER-CLIENT))
        DO (RETURN (IF (NEQ (OTHER-CLIENT.CLIENT OTHER-CLIENT) STATE)
                       OTHER-CLIENT
                       ;1;ELSE*
                       ;1; The idea here is that we have found a SUBSTRUCTURE-REDIRECT-MASK, but*
                       ;1; we were the ones who set it (we can't redirect to ourselves), so we pretend*
                       ;1; that the mask was not there.*
                       NIL))
        FINALLY (RETURN NIL)))

;;; Implementation note: The next two define ways to setf and access the event
;;; masks for a particular client.  Ordinarily, the *STATE* variable will indicate
;;; the client, but for events, this is unknown (i.e. unbound) then we will use
;;; the client that created the window.  This saves writing code to set up *STATE*
;;; just to call one of these guys.
(DEFSETF WINDOW-EVENT-MASKS set-window-event-masks)

(defun set-window-event-masks (window new-mask)
  (LET* ((state (IF (BOUNDP '*STATE*)
		    *STATE*
		  (WINDOW.CLIENT WINDOW)))
	 (MATCHING-CLIENT (find state (WINDOW.EVENT-MASKS WINDOW)
				:KEY #'OTHER-CLIENT.CLIENT)))
    (IF MATCHING-CLIENT
	(if (zerop new-mask)
	    (remove-client state window)
	  (SETF (OTHER-CLIENT.MASK MATCHING-CLIENT) NEW-MASK))
      ;1;ELSE*
      (unless (zerop new-mask)
	(PUSH (MAKE-OTHER-CLIENT :CLIENT (OR *STATE* (WINDOW.CLIENT WINDOW))
				 :MASK NEW-MASK)
	      (WINDOW.EVENT-MASKS WINDOW)))))
  NEW-MASK)

(defun WINDOW-EVENT-MASKS (WINDOW)
  (LET* ((state (IF (BOUNDP '*STATE*)
		    *STATE*
		  (WINDOW.CLIENT WINDOW)))
	 (MATCHING-CLIENT (find state (WINDOW.EVENT-MASKS WINDOW)
				:KEY #'OTHER-CLIENT.CLIENT)))
    (IF MATCHING-CLIENT
	(OTHER-CLIENT.MASK MATCHING-CLIENT)
      ;;ELSE
      0)))

(DEFUN OTHER-CLIENTS (WINDOW)
  "Return a list of the other clients for this window"
  (DECLARE (TYPE WINDOW WINDOW)
           (VALUES LIST))
  ;; Loop through the event-masks and collect other clients.
  (LOOP FOR CLIENT IN (WINDOW.EVENT-MASKS WINDOW)
	with state = (IF (BOUNDP '*STATE*)
			 *STATE*
		       ;;ELSE
		       (WINDOW.CLIENT WINDOW))
        WHEN (NEQ (OTHER-CLIENT.CLIENT CLIENT) state)
        COLLECT CLIENT))

(DEFUN REMOVE-CLIENT (CLIENT WINDOW)
  (DECLARE (TYPE STATE CLIENT)
           (TYPE WINDOW WINDOW))
  (setf (window.event-masks window)
	(delete client (window.event-masks window) :key #'OTHER-CLIENT.CLIENT)))

;;; Implementation note: the `dont-propagate' event mask is indicated by a state of NIL.
(defmacro window-dont-propagate (window)
  `(let ((client (find nil (window.event-masks ,window) :KEY #'other-client.client)))
     (if client
         (other-client.mask client)
         0)))

;;; the dont-propagate mask must be last in the list
(defsetf window-dont-propagate set-window-dont-propagate)

(defun set-window-dont-propagate (window mask)
  (cond ((zerop mask)
	 (remove-client nil window))
	(t
	 (loop for tail in (window.event-masks window)
	       unless (other-client.client tail)
	       return (setf (other-client.mask tail) mask)
	       finally (setf (window.event-masks window)
			     (nconc (window.event-masks window)
				    (LIST (make-other-client :mask mask
                                                             :client nil)))))))
  mask)

(defun window-background (window)
  (loop for back = (window.background-pixmap window)
	while (eql back Copy-From-Parent)
	do (unless (setq window (window.parent window))
	     (return universal-none))
	finally (return back)))

(defsetf window-background (window) (back)
  `(setf (window.background-pixmap ,window) ,back))

(defun window-border (window)
  (loop for border = (window.border-pixmap window)
	while (eql border Copy-From-Parent)
	do (unless (setq window (window.parent window))
	     (return universal-none))
	finally (return border)))

(defsetf window-border (window) (border)
  `(setf (window.border-pixmap ,window) ,border))

(DEFUN WINDOW-LEAST-COMMON-ANCESTOR (A-WINDOW B-WINDOW)
  "Return lowest common ancestor between these two windows."
  (DECLARE (TYPE WINDOW A-WINDOW B-WINDOW)
           (VALUES WINDOW))
  (LOOP NAMED OUTER
        FOR A-PARENT FIRST A-WINDOW THEN (WINDOW.PARENT A-PARENT)
        WHILE A-PARENT
        DO (LOOP FOR B-PARENT FIRST B-WINDOW THEN (WINDOW.PARENT B-PARENT)
                 WHILE B-PARENT
                 DO (WHEN (EQ A-PARENT B-PARENT)
                      (RETURN-FROM OUTER A-PARENT)))))