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

;;;			      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.

;;;
;;; Change history:
;;;
;;;  Date      Author	Description
;;; -------------------------------------------------------------------------------------
;;; 10/112*/88    LGO	1Add a printer for the other-client and property structures*
;;; 10/11/88    LGO	1When printing widows, print covered when not visible, and occluded when partially visible.*
;;;  9/27/88    LGO	Include the ID-BASE when printing a state structure.
;;;  9/27/88    LGO	When printing a window structure, print the name property if there is one.
;;;  19*/07/88    1LGO*	1Add printer for state, gcontext and font-record*
;;;  19*/07/88    1LGO*	1Ensure *PRINT-WINDOW-STRUCTURE1 prints to correct stream*
;;;  4/07/88    TWE	Copied code from sysdependent to here.
;;;  7/07/88	WJB  	Print functions were all modified to work with the  defstruct
;;;			:print-function option. Original versions are commented out
;;;			and should be deleted later if the New Way works out ok.

;;; Make the box object print out nicer.
(DEFUN PRINT-BOX-STRUCTURE (SELF &OPTIONAL STREAM DEPTH)
  (declare (ignore depth))
  (SYS:PRINTING-RANDOM-OBJECT (SELF STREAM :TYPEP)
    ;; 1Print out the *BOX1 name and its dimensions.*
    (PRINC "at (" STREAM)
    (PRINC (BOX.LEFT SELF)                   STREAM)
    (PRINC ","                              STREAM)
    (PRINC (BOX.TOP SELF)                    STREAM)
    (PRINC "), "                            STREAM)
    (PRINC (BOX.WIDTH SELF)                  STREAM)
    (PRINC " by "                           STREAM)
    (PRINC (BOX.HEIGHT SELF)                 STREAM)
    (PRINC ". "                             STREAM)))


;;; Make the window object print out nicer.
(DEFUN PRINT-WINDOW-STRUCTURE (SELF &OPTIONAL STREAM DEPTH)
  (DECLARE (IGNORE DEPTH)) 
  (SYS:PRINTING-RANDOM-OBJECT (SELF STREAM :TYPEP)
    ;; 1Print out the WINDOW name and its dimensions.*
    (PRINC (WINDOW.ID SELF)                  STREAM)
    (PRINC " (#x"                           STREAM)
    (LET ((*PRINT-BASE* 16.))
      (PRINC (WINDOW.ID SELF)                STREAM))
    (PRINC ") "                             STREAM)
    (PRINC "at ("                           STREAM)
    (PRINC (WINDOW.ABSOLUTE-X-CORNER SELF)   STREAM)
    (PRINC ","                              STREAM)
    (PRINC (WINDOW.ABSOLUTE-Y-CORNER SELF)   STREAM)
    (PRINC "), "                            STREAM)
    (PRINC (WINDOW.WIDTH SELF)               STREAM)
    (PRINC " by "                           STREAM)
    (PRINC (WINDOW.HEIGHT SELF)              STREAM)
    (PRINC ", "                             STREAM)
    (WHEN (NOT (WINDOW.MAPPED-P SELF))
      (PRINC "un"                           STREAM))
    (PRINC "mapped"                         STREAM)
    (when (WINDOW.MAPPED-P SELF)
      (let ((os (window.occlusion-stack self)))
	(cond ((null os) (princ ", Covered"   STREAM))
	      ((eq os t) nil)
	      ((null (cdr os)) (princ ", Edge-Occluded" STREAM))
	      (t (princ ", Occluded"	    STREAM)))))
    (COND ((NULL (WINDOW.FIRST-CHILD SELF))
	   (PRINC ", no children"            STREAM))
	  ((EQ (WINDOW.FIRST-CHILD SELF) (WINDOW.LAST-CHILD SELF))
	   (PRINC ", 1 child"                STREAM))
	  (T
	   (PRINC ", "                       STREAM)
	   (PRINC (1+ (LOOP WITH LAST-CHILD = (WINDOW.LAST-CHILD SELF)
			    FOR CHILD FIRST (WINDOW.FIRST-CHILD SELF) THEN
			    (WINDOW.NEXT-SIB CHILD)
			    UNTIL (EQ CHILD LAST-CHILD)
			    COUNTING T))    STREAM)
	   (PRINC " children"		    STREAM)))
    ;1; If window has a name property, print it.*
    (let ((name (find predefined-atom-wm-name (window.properties self)
		      :key #'property.name)))
      (when name
	(princ ", Name " 		    stream)
	(princ (coerce (property.data name) 'string) stream)))
    (PRINC ". "                             STREAM)))


(DEFUN PRINT-SCREEN-STRUCTURE (SELF &OPTIONAL STREAM DEPTH)
  (DECLARE (IGNORE DEPTH))
  (SYS:PRINTING-RANDOM-OBJECT (SELF STREAM :TYPEP)
    ;; 1Print out the SCREEN name and its dimensions.*
    (PRINC (SCREEN.ID SELF)                  STREAM)
    (PRINC " (#x"                           STREAM)
    (LET ((*PRINT-BASE* 16.))
      (PRINC (SCREEN.ID SELF)                STREAM))
    (PRINC ") "                             STREAM)
    (PRINC (SCREEN.WIDTH SELF)               STREAM)
    (PRINC " by "                           STREAM)
    (PRINC (SCREEN.HEIGHT SELF)              STREAM)
    (PRINC ". "                             STREAM )))

(DEFUN print-state-structure (self stream &optional depth)
  (declare (ignore depth))
  (SYS:PRINTING-RANDOM-OBJECT (self stream :TYPEP)
    (princ (state.description self) stream)
    (princ " ID-Base #x" stream)
    (let ((*print-base* 16.))
      (princ (state.id-base self) stream))
    (when (STATE.SERVER-STATE self)
      (princ " " stream)
      (prin1 (STATE.SERVER-STATE self) stream))))

(DEFUN (:PROPERTY gcontext NAMED-STRUCTURE-INVOKE) (OP &OPTIONAL SeLF stream &REST IGNORE)
  (CASE OP
    (:WHICH-OPERATIONS '(:PRINT-SELF))
    ((:PRINT-SELF) (SYS:PRINTING-RANDOM-OBJECT (SeLF stream :TYPEP)
		     (princ "id="			     STREAM)
		     (PRINC (GCONTEXT.ID SELF)               STREAM)
		     (PRINC " (#x"                           STREAM)
		     (LET ((*PRINT-BASE* 16.))
		       (PRINC (WINDOW.ID SELF)               STREAM))
		     (PRINC ") Alu "                         STREAM)
		     (princ (aref #( Clear And And-Reverse Copy
				    And-Inverted Noop Xor Or
				    Nor Equiv Invert Or-Reverse
				    Copy-Inverted Or-Inverted Nand Set)
				  (gcontext.alu self))	     STREAM)
		     (princ ", FG " stream) (princ (gcontext.foreground-pixel self) stream)
		     (princ ", BG " stream) (princ (gcontext.background-pixel self) stream)
		     (when (> (gcontext.line-width self) 1)
		       (princ ", LW " stream) (princ (gcontext.line-width self) stream))
		     (when (gcontext.font self)
		       (princ ", Font "			     STREAM)
		       (PRINC (w:font-name (font-record.device-private
					     (gcontext.font self))) STREAM))
		     (when (plusp (gcontext.fill-style self))
		       (princ ", Fill: "		     STREAM)
		       (princ (aref #(Solid Tiled Stippled Opaque-Stippled)
				    (gcontext.fill-style self)) STREAM))
		     ))
    (OTHERWISE (FERROR () "~S unknown message to ~S" OP SeLF))))

(DEFUN (:PROPERTY font-record NAMED-STRUCTURE-INVOKE) (OP &OPTIONAL SeLF stream &REST IGNORE)
  (CASE OP
    (:WHICH-OPERATIONS '(:PRINT-SELF))
    ((:PRINT-SELF) (SYS:PRINTING-RANDOM-OBJECT (SeLF stream :TYPEP)
		     (PRINC (w:font-name (font-record.device-private SELF)) STREAM)
		     ))
    (OTHERWISE (FERROR () "~S unknown message to ~S" OP SeLF))))

(defun print-other-client (self &optional stream depth)
  (declare (ignore depth))
  (sys:printing-random-object (self stream :typep)
    ;; 1Print out the *BOX1 name and its dimensions.*
    (let ((client (other-client.client self))
	  (mask (other-client.mask self)))
      (princ "Client " stream)
      (princ client stream)
      (princ ", Mask " stream)
      (princ (if (numberp mask) (make-event-keys mask) mask) stream))))

(defun print-property (property &optional stream depth)
  (declare (ignore depth))
  (sys:printing-random-object (property stream :typep)
    ;; 1Print out the *BOX1 name and its dimensions.*
    (let ((name (property.name property))
	  (type (property.type property))
	  (format (property.format property))
	  (data (property.data property)))
      (princ "Name " stream)
      (princ (get-atom-name name) stream)
      (if (and (eql type predefined-atom-string)
	       (eql format 8))
	  (progn (princ ", " stream)
		 (prin1 (coerce data 'string) stream))
	(unless (zerop type)
	  (princ ", type " stream)
	  (princ (get-atom-name type) stream))
	(princ ", format " stream)
	(princ format stream)
	(princ ", Data " stream)
	(princ data stream)))))