;;; -*- 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
;;; ---------------------------------------------------------------------------
;;; 03/30/89	WJB	In X-SELECT-AND-ENABLE, create X window if none exists.
;;; 03/29/89	WJB	Patch 1.60; Add (:METHOD X-SERVER-WINDOW-FLAVOR :AFTER :CHANGE-OF-SIZE-OR-MARGINS)
;;; 03/21/89	WJB	Patch 1.53; Add wholine support
;;; 03/14/89	WJB	Patch 1.42; Defined own version of DRAW-CHAR-INTERNAL-FIT -- see comments.
;;; 03/09/89	WJB	Patch 1.38; Fix DRAW-STRING to return if Y position is negative.
;;; 01/04/89	LGO	Reset X on warm-boot1.*
;;; 12/15/88	LGO	Make X-BITBLT-CLIPPED handle negative dest-x/y
;;; 12/06/88	WJB	New function X-BITBLT-CLIPPED which checks destination boundries.
;;; 112*/10*6/88	DLS	Removed the SYS:KBD-HARDWARE-CHAR-AVAILABLE function since
;;;			it is unchanged from the system version.
;;; 112*/105*/88	1LGO*	1Return lexical closures instead of forms to eval from *FONT-HOST-LOGIN1.*
;;; 11/123*/88	1LGO*	1Move unused functions pixmap-depth and clear-temp-array to the bone-yard*
;;; 11/121*/88	1LGO*	1Move network stuff to here from the SERVER file.  Add CLX open-x-stream patch*
;;; 11/09/88	WJB	Moved X I/O hooks to daemon methods on :select and :deselect
;;;			Fixed mouse position saving (real-moose-hack) to work correctly.
;;;  9/21/88	LGO	1Disable X on warm-boot*
;;;  9/21/88	LGO	Text was being drawn 1 pixel too low, fix it.
;;;  19*/115*/88	1LGO*	Added draw-string
;;;  8/17/88	WJB	Added check for type SCREEN in DEVICE-PRIVATE-ARRAY.
;;;  8/09/88	WJB	Removed code from X-SHUTDOWN which sent an :EXPOSE to all sheets.
;;;  7/11/88    DAN     Added call to :activate in MAKE-SERVER-WINDOW.
;;;  7/01/88    DAN	Hacked up the mouse handling in the expose/deexpose
;;;			methods to remember where it was and put it back.
;;;  6/16/88    WJB	Moved all data, macro, and flavor definitions from this 
;;;			file to SYSDEPENDENT-DEFS.
;;;  6/13/88 1   * DAN	Removed :EXPOSE and :BURY from FIND-FREE-X-SERVER-WINDOW
;;;			and MAKE-SERVER-WINDOW.
;;;  5/31/88    TWE	Changed DEVICE-PRIVATE-DRAWABLE to check for
;;;			W:MINIMUM-WINDOW instead of X-SERVER-WINDOW-FLAVOR.
;;;  5/13/88    TWE	Moved all of the I/O buffer dependent code into here.
;;;  5/10/88    TWE	Fixed X-COPY-TO-WINDOW  to clip to the parent's inside
;;;			(x,y).
;;;  5/03/88    TWE	Write CLEAR-EVENT-QUEUE.
;;;  4/26/88 1   * DAN	Changed the constant X-SCREEN-HEIGHT to account for
;;;			who/status lines.
;;;  4/26/88    TWE	Added the macros ARRAY-WIDTH and ARRAY-HEIGHT.
;;;  4/07/88    TWE	Moved all of the object printing code out of here and
;;;			moved it to sysdependent-mods because the window and
;;;			screen printing code don't work if those objects haven't
;;;			been defined yet.  The box code was moved anyway so that
;;;			all of those kind of functions would remain together.
;;;  3/31/88    TWE	Wrote a function to make SCREEN objects print out nicer.
;;;  3/30/88    TWE	Removed the :AFTER :EXPOSE method for
;;;			X-SERVER-WINDOW-FLAVOR.
;;;  3/29/88    TWE	Changed the window print function to display absolute
;;;			(X,Y) coordinates instead of parent-relative coordinates.
;;;  3/17/88    TWE	Changed DRAW-CHAR to have the argument THE-COLOR instead
;;;			of the special variable COLOR (removed compiler warning).
;;;  3/17/88    TWE	Wrote a function to make WINDOW objects print out nicer.
;;;  2/10/88    TWE	Fixed up the X-ENABLED flag so that its meaning and its
;;;			name correspond.
;;;  1/27/88    TWE	Added an ALU argument to COPY-ARRAY-CLIPPED.
;;;  1/26/88    TWE	Added code to make the box object print nicer.
;;;  1/25/88    TWE	Added a function to automatically login for fonts.
;;;  1/22/88    TWE	Changed DEVICE-PRIVATE-DRAWABLE to handle a pixmap too.
;;;			Put inhibit-fdefine-warnings around the low-level
;;;			keyboard functions we are redefining.  Added a new
;;;			function DEVICE-PRIVATE-ARRAY which returns the real
;;;			destination array for either a window or a pixmap.
;;;  1/11/88    TWE	Added a function to get the frame buffer when given an
;;;			X window.
;;; 12/21/87    TWE	Fixed draw-rectangle to get the frame buffer properly.
;;; 12/18/87    TWE	Added copy-to-window.
;;; 11/13/87    TWE	Updated copy-array-clipped to handle a clipping rectangle.
;;; 10/29/87    TWE	Added more support for bitmaps.
;;; 10/28/87    TWE	Added character output code.
;;;  7/17/87    TWE	Added the screen creation code.
;;;  7/15/87    TWE	Initial creation.  Put in the time code.




(DEFMETHOD (X-SERVER-WINDOW-FLAVOR :AFTER :INIT) (&REST IGNORE)
  "2Sets up the initializations for the X server.*"
  (SETQ screen-array-pixmap (make-pixmap :width tv:width :height tv:height :array tv:screen-array))
  (PUSH SELF ALL-X-SCREENS))

(DEFUN get-screen-pixmap (inst)
  (SEND inst :screen-array-pixmap))

;1;; This papers over a compiler bug which does not allow us to*
;1;; change the w:mouse-x/y special variables inside of a method.*
(DEFUN real-moose-hack (new-moose-x NEW-moose-y)
  "2Move the mouse to a new position.*"
  (setq w:mouse-x new-moose-x
        w:mouse-y new-moose-y)
  ;; mouse-sheet is nil during a warm boot and causes an error.
  (when tv:mouse-sheet
    (w:mouse-set-blinker-cursorpos new-moose-x new-moose-y)))


(DEFMETHOD (X-SERVER-WINDOW-FLAVOR :AFTER :KILL) (&REST IGNORE)
  (SETQ ALL-X-SCREENS (REMOVE SELF ALL-X-SCREENS)))

(defmethod (X-SERVER-WINDOW-FLAVOR :AFTER :SELECT) (&REST IGNORE)
  (SETQ explorer-mouse-x w:mouse-x
        explorer-mouse-y w:mouse-y)
  (real-moose-hack x-mouse-x x-mouse-y)
  (x-enable)
  (stepper-select-hook))

(defmethod (X-SERVER-WINDOW-FLAVOR :BEFORE :DESELECT) (&REST IGNORE)
  (when (eq tv:selected-window self)
    ;; Deselect is often called twice -- only do this when we are really selected
    (SETQ x-mouse-x w:mouse-x
	  x-mouse-y w:mouse-y)
    (real-moose-hack explorer-mouse-x explorer-mouse-y))
  (x-disable))


(defmethod (X-SERVER-WINDOW-FLAVOR :USER-ACTIVITY-STRING) ()
  "String used for finger."
  "X Server")

(defmethod (X-SERVER-WINDOW-FLAVOR :AFTER 4:CHANGE-OF-SIZE-OR-MARGINS*) (&REST IGNORE)
  ;; Called by the explorer window system when someone changes the size of the
  ;; window that is displaying our X screen.  We don't really support changing 
  ;; screen sizes very well but this at least prevents bitblt errors and allows
  ;; a change in the number of mouse-documentation-lines.
  (loop
    ;; Find X screen that goes with this window
    for screen in (screen-info.screens screen-info)
    for root in (screen-info.windows screen-info)
    when (eq self (screen.dev-private screen))
    do
    (change-screen-size screen root (tv:sheet-width self) (tv:sheet-height self))
    (return)))

(defun X-SELECT-AND-ENABLE ()
  ;; Select window and enable X IO hooks
  (let ((xwin (or (tv:find-window-of-flavor 'x-server-window-flavor)
		  (tv:find-window 'x-server-window-flavor))))

    (when (null xwin)
      ;; Dunno about the wisdom of doing this within a kbd-sys-process, but what else to do?
      (initialize-monochrome-server)
      (setq xwin (or (tv:find-window-of-flavor 'x-server-window-flavor)
		     (tv:find-window 'x-server-window-flavor))))
    (if (null xwin)
	(beep)
      (cond ((and (eq tv:selected-window xwin)
		  (not x-enabled))
	     ;; correct window is already selected but x not enabled
	     (x-enable))
	    ((neq tv:selected-window xwin)
	     ;; select the x window -- selection will enable x hooks
	     (send xwin :mouse-select)))))
  nil)

(defun X-ENABLE ()
  ;; Disable ucode mouse tracking
  (without-interrupts
    (sys:%open-mouse-cursor)
    (setq tv:mouse-cursor-closed-state 1)
    (setf (tv:blinker-visibility tv:mouse-blinker) nil))
  (setq x-enabled t))

(tv:add-system-key #\X '(X-SELECT-AND-ENABLE) "X Server Window")

(defun X-DISABLE ()
  (when x-enabled
    (setq x-enabled nil)
    (setq si:escape-flag nil)
    ;1; Re-enable microcode mouse tracking.*
    (setf (tv:blinker-visibility tv:mouse-blinker) t)
    (when tv:mouse-blinker
      (send tv:mouse-blinker :track-mouse))))


(DEFUN FIND-FREE-X-SERVER-WINDOW ()
  (LOOP FOR SERVER IN ALL-X-SCREENS
        WHEN (SEND SERVER :AVAILABLE)
        DO (PROGN
             (SEND server :activate)
             (RETURN SERVER))
        FINALLY (RETURN NIL)))

(DEFUN MAKE-SERVER-WINDOW ()
  (LET ((WINDOW (MAKE-INSTANCE 'X-SERVER-WINDOW-FLAVOR)))
    (SEND WINDOW :ACTIVATE)
    WINDOW))

(DEFVAR *LAST-X-WHOLINE-PROCESS* NIL)

(DEFUN X-WHOLINE-PROCESS (PROCESS &OPTIONAL DEACTIVATE)
  
  (WHEN DEACTIVATE
    (IF (EQ PROCESS *LAST-X-WHOLINE-PROCESS*)
	(SETQ PROCESS DISPATCHER-PROCESS)
      ;; no need for action unless process is current
      (RETURN-FROM X-WHOLINE-PROCESS)))
  
  ;; No need for action if process is already current
  (UNLESS (EQ PROCESS *LAST-X-WHOLINE-PROCESS*)
    (LET* ((WINDOW (SCREEN.DEV-PRIVATE CURRENT-SCREEN))
	   (IO-BUFFER (AND WINDOW (SEND WINDOW :IO-BUFFER))))
      (WHEN IO-BUFFER
	(SETQ *LAST-X-WHOLINE-PROCESS* PROCESS)
	(SETF (TV:IO-BUFFER-LAST-OUTPUT-PROCESS IO-BUFFER) PROCESS)))))


(DEFUN DEVICE-PRIVATE-DRAWABLE (WINDOW)
  "Gets the screen array for an Explorer window."
  (COND ((TYPEP WINDOW 'W:MINIMUM-WINDOW)
         (W:SHEET-SCREEN-ARRAY WINDOW))
        ((TYPEP WINDOW 'PIXMAP)
         (PIXMAP.ARRAY WINDOW))
        (T
         ;; Not a window or pixmap.  Hopefully this is an array.
         WINDOW)))

(DEFUN DEVICE-PRIVATE-ARRAY (DRAWABLE)
  "Return the real destination array for DRAWABLE."
  (COND ((TYPEP DRAWABLE 'WINDOW)
         (DEVICE-PRIVATE-WINDOW-ARRAY DRAWABLE))
        ((TYPEP DRAWABLE 'PIXMAP)
         (PIXMAP.ARRAY DRAWABLE))
	((TYPEP DRAWABLE 'SCREEN)
	 (PIXMAP.ARRAY (GET-SCREEN-PIXMAP (SCREEN.DEV-PRIVATE DRAWABLE))))
        ((ARRAYP DRAWABLE)
         DRAWABLE)
	(t
	 (error "~S is not a DRAWABLE (an X WINDOW, PIXMAP, or ARRAY)" DRAWABLE))))

(DEFUN DEVICE-PRIVATE-WINDOW-ARRAY (WINDOW)
  "Gets the screen array for an X window."
  ;; The window has a visual, which is an atom.  We use this atom to obtain the
  ;; visual object.  The visual object has a screen, which is also an atom.  We
  ;; use this atom to obtain the screen object.  The screen has a dev-private
  ;; which is an Explorer window instance.
  (LET ((screen-array (W:SHEET-SCREEN-ARRAY (SCREEN.DEV-PRIVATE
                                              (GETHASH (VISUAL.SCREEN
                                                         (GETHASH (WINDOW.VISUAL WINDOW)
                                                                  *RESOURCES*))
                                                       *RESOURCES*)))))
    ;1; HACK ALERT!!  THIS WILL NOT WORK WITH CLOS!!!  If we have a color system and are using*
    ;1; the monochrome server (assumed) then we return the expansion mode buffer from the cold*
    ;1; load stream.  (TWE)*
    (IF (EQ (ARRAY-TYPE SCREEN-ARRAY) 'ART-8B)
        (SYMEVAL-IN-INSTANCE SI:COLD-LOAD-STREAM 'ARRAY)
        ;1;ELSE*
        SCREEN-ARRAY)))


(DEFUN X-SHUTDOWN ()
  ;; Turn off X
  (SETQ X-ENABLED NIL)
  ;; Bring up the Explorer window system.
  ;;; \/\/ - causes an error in the mouse handler when tv:mouse-sheet temporarily is set to nil.
  ;;(DOLIST (S TV:ALL-THE-SCREENS)
    ;;(SEND S :EXPOSE))
  )



;;; Redfined from SYS:WINDOW;TVDEFS.LISP.  The standard version claims to
;;; return NIL if character is not successfully drawn, but in truth it always 
;;; returns T.  We require that it work as advertized and the version below does.

(DEFUN DRAW-CHAR-INTERNAL-FIT (FONT CH X Y ALU WINDOW FIT)
  "2Draw character from font with font indexing table FIT.
 Returns t if the character is successfully drawn, else nil.*"
  (DO ((CH (AREF FIT CH) (1+ CH))
       (WIDTH (TV:FONT-RASTER-WIDTH FONT))
       (LIM (AREF FIT (1+ CH)))
       (BPP (IF (ARRAYP WINDOW)
		(TV:ARRAY-BITS-PER-PIXEL WINDOW)
	      (TV:SHEET-BITS-PER-PIXEL WINDOW)))
       (X X (+ X (TRUNCATE WIDTH BPP))))
      ((>= CH LIM) t)
    (OR 
      (SYS:%DRAW-CHARACTER FONT CH WIDTH X Y ALU WINDOW)
      (RETURN NIL))))


;;; Character output function.

;;; The idea behind this function is to be just like the TV:DRAW-CHAR function
;;; but work for X.  The X character drawing is done so that the Y position
;;; specifies the baseline and the X position specifies the character origin.
;;; The Explorer window system has the (X,Y) point be the upper left corner of
;;; the character box.  This makes it difficult to line up characters from
;;; different fonts, making the FONT-MAP, BASELINE and BASELINE-ADJ instance
;;; variables a necessity.
(DEFUN DRAW-CHAR (FONT CHAR X Y X-ALU ARRAY &OPTIONAL THE-COLOR)
  (DECLARE (IGNORE THE-COLOR))
  (LET ((CHAR-BASELINE (W:FONT-BASELINE FONT))
        (EXPLORER-ALU (AREF X-ALU-TO-EXPLORER-ALU X-ALU))
        (FIT (W:FONT-INDEXING-TABLE FONT)))
    (IF FIT
        (draw-char-internal-fit FONT CHAR X (- Y CHAR-BASELINE) EXPLORER-ALU ARRAY FIT)
      ;;1ELSE*
      (TV:%DRAW-CHAR FONT CHAR X (- Y CHAR-BASELINE) EXPLORER-ALU ARRAY))))


(DEFUN draw-string (window string index end xpos ypos font x-alu)
  "2Draw characters indexed in STRING from INDEX up to but not including END on WINDOW 
 at XPOS YPOS using FONT and ALU.  Returns the x-position for the next character to be 
 drawn.  A second value is returned if the end index is not reached.  It is the index of the
 first character not drawn, which can occur if the character overlaps xlim or is a non
 graphic character.*"
  (declare (inline graphic-char-p))
  (DECLARE (values new-xpos ending-index))
  
  (LET* ((char-baseline (w:font-baseline font))
	 (ypos (- ypos char-baseline))
	 (alu (aref x-alu-to-explorer-alu x-alu))
	 num)
    (if (minusp ypos)
	(values xpos index)
      ;;ELSE 
      (setq num (si:%draw-string font string index end xpos ypos alu window))
    (IF num
	;1; Microcoded draw-string worked...just return results*
	(VALUES (LDB (BYTE 12. 0) num)		;1 new xpos*
		(AND (< (INCF index (LDB (byte 12. 12.) num)) end)
		     index))
      ;1; ...else must do it in LISP*
      (LET ((fwt (tv:FONT-CHAR-WIDTH-TABLE font))
	    (lkt (tv:FONT-LEFT-KERN-TABLE font))
	    (fit (tv:FONT-INDEXING-TABLE font))
	    (wid (tv:FONT-CHAR-WIDTH font))
	    ch)
	(IF (OR fwt lkt fit)
	    ;1; ...then hard case of large, variable-width, or kerned font*
	    (loop
	      (OR (< index end)
		  (RETURN xpos))		;1 reached the end*
	      (OR (graphic-char-p
		    (SETQ ch (CHAR-CODE (AREF string index))))	;1 use char code for art-q strings.*
		  (RETURN xpos index))		;1 non printing char*
	      (OR (IF FIT
		      (draw-char-internal-fit
			font ch (if lkt (- xpos (aref lkt ch)) xpos) ypos alu window fit)
		    (tv:%draw-char font ch xpos ypos alu window))
		  (RETURN xpos index))		;1 clipped *
	      (INCF xpos (IF fwt (AREF fwt ch) wid))
	      (INCF index))
	  ;1; ...else easy case of small, fixed-width font.  Speed hack KED 2/25/87*
	  (DO ((w (tv:font-char-width font)))
	      (())					
	    (OR (< index end)
		(RETURN xpos))			;1 reached the end*
	    (OR (graphic-char-p (SETQ ch (CHAR-CODE (AREF string index)))) 	
		(RETURN xpos index))		;1 non printing char*
	    (OR (si:%draw-character font ch w xpos ypos alu window)
		(RETURN xpos index))		;1 clipped *
	    (INCF xpos wid)
	    (INCF index))))))))



(DEFUN X-BITBLT (X-ALU WIDTH HEIGHT SOURCE SOURCE-X SOURCE-Y DEST DEST-X DEST-Y)
  (BITBLT (AREF X-ALU-To-Explorer-ALU X-ALU) WIDTH HEIGHT
          SOURCE SOURCE-X SOURCE-Y DEST DEST-X DEST-Y))


(DEFUN X-BITBLT-CLIPPED (X-ALU WIDTH HEIGHT SOURCE SOURCE-X SOURCE-Y DEST DEST-X DEST-Y)
  "Clip the width and height to the destination array and perform a bitblt."
  
  (LET ((DEST-WIDTH  (ARRAY-WIDTH  DEST))
	(DEST-HEIGHT (ARRAY-HEIGHT DEST))
	(WIDTH-SIGN WIDTH)
	(HEIGHT-SIGN HEIGHT))
    (SETQ WIDTH (ABS WIDTH))
    (SETQ HEIGHT (ABS HEIGHT))
    (WHEN (AND (< DEST-X DEST-WIDTH) (< DEST-Y DEST-HEIGHT))
      (WHEN (> (+ DEST-X WIDTH) DEST-WIDTH)
	(SETQ WIDTH (- DEST-WIDTH DEST-X)))
      (WHEN (> (+ DEST-Y HEIGHT) DEST-HEIGHT)
	(SETQ HEIGHT (- DEST-HEIGHT DEST-Y)))
      (when (minusp dest-x)
	(setq width (+ width dest-x)
	      dest-x 0))
      (when (minusp dest-y)
	(setq height (+ height dest-y)
	      dest-y 0))
      (WHEN (MINUSP WIDTH-SIGN)
	(SETQ WIDTH (- WIDTH)))
      (WHEN (MINUSP HEIGHT-SIGN)
	(SETQ HEIGHT (- HEIGHT)))
      (X-BITBLT X-ALU WIDTH HEIGHT SOURCE SOURCE-X SOURCE-Y DEST DEST-X DEST-Y))))


;;; This is intended to be a safe function for copying one array to another.
;;; If all arguments are of the right types then there should be no errors.
(DEFUN COPY-ARRAY-CLIPPED (WIDTH HEIGHT CLIPPING-RECTANGLE
                           FROM-ARRAY FROM-X FROM-Y TO-ARRAY TO-X TO-Y
                           &OPTIONAL (X-ALU GX-COPY))
  "Copy those parts of FROM-ARRAY that will fit within TO-ARRAY.
WIDTH and HEIGHT indicate the maximum size of the rectangle being copied.
CLIPPING-RECTANGLE contains a BOX object, or NIL, for clipping on the TO-ARRAY.
FROM-X and FROM-Y are offsets within FROM-ARRAY where copying starts.
  If negative then they indicate a phantom point outside of FROM-ARRAY where
  copying would have started if it could.
TO-X and TO-Y are similar to FROM-X and FROM-Y except that they relate to TO-ARRAY."
  (DECLARE (INTEGER WIDTH HEIGHT FROM-X FROM-Y TO-X TO-Y))
  (LET* ((FROM-WIDTH  (ARRAY-DIMENSION FROM-ARRAY 1))
         (FROM-HEIGHT (ARRAY-DIMENSION FROM-ARRAY 0))
         ;; FROM-COPY-W/H represents the maximum amount that can be copied from the FROM array.
         (FROM-COPY-WIDTH  WIDTH)
         (FROM-COPY-HEIGHT HEIGHT)
         (TO-WIDTH    (ARRAY-DIMENSION TO-ARRAY   1))
         (TO-HEIGHT   (ARRAY-DIMENSION TO-ARRAY   0))
         ;; TO-COPY-W/H represents the maximum amount that can be copied to the TO array.
         (TO-COPY-WIDTH  WIDTH)
         (TO-COPY-HEIGHT HEIGHT)
         (EXPLORER-ALU (AREF X-ALU-TO-EXPLORER-ALU X-ALU))
         DELTA)
    ;; Clip the (X,Y)'s.
    (WHEN  (MINUSP FROM-X)
      (SETQ FROM-COPY-WIDTH (MAX 0 (+ FROM-COPY-WIDTH FROM-X)))
      (SETQ FROM-X 0))
    (WHEN  (MINUSP FROM-Y)
      (SETQ FROM-COPY-HEIGHT (MAX 0 (+ FROM-COPY-HEIGHT FROM-Y)))
      (SETQ FROM-Y 0))
    (WHEN  (MINUSP TO-X)
      (SETQ TO-COPY-WIDTH (MAX 0 (+ TO-COPY-WIDTH TO-X)))
      (SETQ TO-X 0))
    (WHEN  (MINUSP TO-Y)
      (SETQ TO-COPY-HEIGHT (MAX 0 (+ TO-COPY-HEIGHT TO-Y)))
      (SETQ TO-Y 0))
    (COND ((PLUSP (SETQ DELTA (- FROM-COPY-WIDTH TO-COPY-WIDTH)))
           ;; Not enough width in the destination.  Adjust the source-x and width
           ;; to copy less.
           (INCF FROM-X DELTA)
           (SETQ WIDTH TO-COPY-WIDTH))
          ((PLUSP (SETQ DELTA (- TO-COPY-WIDTH FROM-COPY-WIDTH)))
           ;; Not enough width in the source.  Adjust the dest-x and width
           ;; to copy less.
           (INCF TO-X DELTA)
           (SETQ WIDTH FROM-COPY-WIDTH))
          (T
           ;; The two widths are the same.
           (SETQ WIDTH FROM-COPY-WIDTH)))
    (COND ((PLUSP (SETQ DELTA (- FROM-COPY-HEIGHT TO-COPY-HEIGHT)))
           ;; Not enough height in the destination.  Adjust the source-y and height
           ;; to copy less.
           (INCF FROM-Y DELTA)
           (SETQ HEIGHT TO-COPY-HEIGHT))
          ((PLUSP (SETQ DELTA (- TO-COPY-HEIGHT FROM-COPY-HEIGHT)))
           ;; Not enough height in the source.  Adjust the dest-y and height
           ;; to copy less.
           (INCF TO-Y DELTA)
           (SETQ HEIGHT FROM-COPY-HEIGHT))
          (T
           ;; The two heights are the same.
           (SETQ HEIGHT FROM-COPY-HEIGHT)))
    ;; Clip the width based upon the smallest of the source and destinations.
    (WHEN (> (+ WIDTH FROM-X) FROM-WIDTH)
      (SETQ WIDTH (MAX 0 (- FROM-WIDTH FROM-X))))
    (WHEN (> (+ WIDTH TO-X) TO-WIDTH)
      (SETQ WIDTH (MAX 0 (- TO-WIDTH TO-X))))
    ;; Clip the height the same way.
    (WHEN (> (+ HEIGHT FROM-Y) FROM-HEIGHT)
      (SETQ HEIGHT (MAX 0 (- FROM-HEIGHT FROM-Y))))
    (WHEN (> (+ HEIGHT TO-Y) TO-HEIGHT)
      (SETQ HEIGHT (MAX 0 (- TO-HEIGHT TO-Y))))
    (WHEN (AND (PLUSP WIDTH) (PLUSP HEIGHT))
      ;; Now perform clipping of the TO-ARRAY based upon the clipping rectangle.
      (WHEN CLIPPING-RECTANGLE
        (LET ((CLIP-X      (BOX.LEFT   CLIPPING-RECTANGLE))
              (CLIP-Y      (BOX.TOP    CLIPPING-RECTANGLE))
              (CLIP-RIGHT  (BOX.RIGHT  CLIPPING-RECTANGLE))
              (CLIP-BOTTOM (BOX.BOTTOM CLIPPING-RECTANGLE)))
          (WHEN (> CLIP-X TO-X)
            (DECF WIDTH  (- CLIP-X TO-X))
            (INCF FROM-X (- CLIP-X TO-X))
            (SETQ TO-X CLIP-X))
          (WHEN (> CLIP-Y TO-Y)
            (DECF HEIGHT (- CLIP-Y TO-Y))
            (INCF FROM-Y (- CLIP-Y TO-Y))
            (SETQ TO-Y CLIP-Y))
          (WHEN (> (+ TO-X WIDTH) CLIP-RIGHT)
            (SETQ WIDTH (- CLIP-RIGHT TO-X)))
          (WHEN (> (+ TO-Y HEIGHT) CLIP-BOTTOM)
            (SETQ HEIGHT (- CLIP-BOTTOM TO-Y)))))
      (WHEN (AND (PLUSP WIDTH) (PLUSP HEIGHT))
        (BITBLT EXPLORER-ALU WIDTH HEIGHT FROM-ARRAY FROM-X FROM-Y TO-ARRAY TO-X TO-Y)))))

(DEFUN DRAW-RECTANGLE (DRAWABLE X Y WIDTH HEIGHT PIXEL)
  "Draws a rectangle of PIXEL starting at (X,Y) for a rectangle with dimensions WIDTH by HEIGHT.
Drawable can be either a pixmap or a window."
  ;; Implementation note: This only works for monochrome displays.
  ;; Note that for windows, the (X,Y) refers to the interior part of the window.
  (WHEN (MINUSP X)
    (INCF WIDTH X)
    (SETQ X 0))
  (WHEN (MINUSP Y)
    (INCF HEIGHT Y)
    (SETQ Y 0))
  (LET ((ALU (IF (ZEROP PIXEL) W:ALU-SETZ W:ALU-SETA))
        ARRAY)
    (IF (TYPEP DRAWABLE 'PIXMAP)
        (PROGN
          ;; Do some simple clipping.
          (WHEN (> (+ X WIDTH) (PIXMAP.WIDTH DRAWABLE))
            (SETQ WIDTH (- (PIXMAP.WIDTH DRAWABLE) X)))
          (WHEN (> (+ Y HEIGHT) (PIXMAP.HEIGHT DRAWABLE))
            (SETQ HEIGHT (- (PIXMAP.HEIGHT DRAWABLE) Y)))
          (SETQ ARRAY (PIXMAP.ARRAY DRAWABLE)))
        ;;1ELSE*
        (PROGN
          ;; Do some simple clipping.
          (WHEN (> (+ X WIDTH) (WINDOW.WIDTH DRAWABLE))
            (SETQ WIDTH (- (WINDOW.WIDTH DRAWABLE) X)))
          (WHEN (> (+ Y HEIGHT) (WINDOW.HEIGHT DRAWABLE))
            (SETQ HEIGHT (- (WINDOW.HEIGHT DRAWABLE) Y)))
          ;; The window has a visual which contains a screen slot.  The screen contains
          ;; a device-private slot contains an Explorer window instance which contains
          ;; a screen array where we want to draw.
          (SETQ ARRAY (DEVICE-PRIVATE-WINDOW-ARRAY DRAWABLE))
          (INCF X (WINDOW.ABSOLUTE-INSIDE-X DRAWABLE))
          (INCF Y (WINDOW.ABSOLUTE-INSIDE-Y DRAWABLE))))
    (WHEN (NOT (= (DRAWABLE-DEPTH DRAWABLE) 1))
      (ERROR "Attempting to draw a monochrome rectangle onto a color drawable."))
    ;; We use the ALU to draw either a 0 or a 1 onto the drawable.
    (SI:%DRAW-RECTANGLE WIDTH HEIGHT X Y ALU ARRAY)))

;;; The following is test code which was used to checkout the COPY-ARRAY-CLIPPED function.
;;; It turns out that there are a large number of cases to verify, which makes the task
;;; of unit testing very time-consuming.  The following code was used to allow one to
;;; interactively specify points in the FROM and TO rectangles and to visually and
;;; numerically verify the resultant copy.
;;;(DEFPARAMETER A (tv:make-array '(60 50) :element-type 'bit))
;;;(DEFPARAMETER b (tv:make-array '(80 70) :element-type 'bit))
;;;(DEFPARAMETER OLD-MOUSE-SOURCE-X 0)
;;;(DEFPARAMETER OLD-MOUSE-SOURCE-Y 0)
;;;(DEFPARAMETER OLD-MOUSE-DEST-X 0)
;;;(DEFPARAMETER OLD-MOUSE-DEST-Y 0)

;;;(DEFUN TEST ()
;;;  (LOOP WITH WIDTH  = 70
;;;        WITH HEIGHT = 30
;;;        WITH SOURCE = A
;;;        WITH SOURCE-WIDTH  = (ARRAY-DIMENSION SOURCE 1)
;;;        WITH SOURCE-HEIGHT = (ARRAY-DIMENSION SOURCE 0)
;;;        WITH SOURCE-X-OFFSET = 200
;;;        WITH SOURCE-Y-OFFSET = 200
;;;        WITH DEST = B
;;;        WITH DEST-WIDTH  = (ARRAY-DIMENSION DEST 1)
;;;        WITH DEST-HEIGHT = (ARRAY-DIMENSION DEST 0)
;;;        WITH DEST-X-OFFSET = 200
;;;        WITH DEST-Y-OFFSET = 500
;;;        WITH WINDOW = W:SELECTED-WINDOW
;;;        INITIALLY (PROGN
;;;                    (SEND WINDOW :SET-CURSORPOS 0 0)
;;;                    (SEND WINDOW :CLEAR-EOF)
;;;                    (DRAW-RECTANGLE WINDOW SOURCE-X-OFFSET SOURCE-Y-OFFSET
;;;                                    SOURCE-WIDTH SOURCE-HEIGHT)
;;;                    (DRAW-RECTANGLE WINDOW DEST-X-OFFSET DEST-Y-OFFSET DEST-WIDTH DEST-HEIGHT))
;;;        FOR (IGNORE1 IGNORE2 IGNORE3 SOURCE-X SOURCE-Y) = (PROGN
;;;                                                            (W:MOUSE-WARP OLD-MOUSE-SOURCE-X
;;;                                                                          OLD-MOUSE-SOURCE-Y)
;;;                                                            (W:READ-ANY))
;;;        FOR JUNK = (PROGN
;;;                     (SEND WINDOW :SET-CURSORPOS 0 0)
;;;                     (SEND WINDOW :CLEAR-EOF)
;;;                     (DRAW-RECTANGLE WINDOW SOURCE-X-OFFSET SOURCE-Y-OFFSET
;;;                                     SOURCE-WIDTH SOURCE-HEIGHT)
;;;                     (DRAW-RECTANGLE WINDOW DEST-X-OFFSET DEST-Y-OFFSET DEST-WIDTH DEST-HEIGHT))
;;;        FOR (IGNORE4 IGNORE5 IGNORE6 DEST-X DEST-Y) = (PROGN
;;;                                                        ;; Identify the source point
;;;                                                        ;; selected by the user.
;;;                                                        (SETQ OLD-MOUSE-SOURCE-X SOURCE-X
;;;                                                              OLD-MOUSE-SOURCE-Y SOURCE-Y)
;;;                                                        (send window
;;;                                                              :draw-filled-circle
;;;                                                              SOURCE-X SOURCE-Y 3)
;;;                                                        (DRAW-DASHED-RECTANGLE WINDOW
;;;                                                                               SOURCE-X SOURCE-Y
;;;                                                                               WIDTH HEIGHT)
;;;                                                        (W:MOUSE-WARP OLD-MOUSE-DEST-X
;;;                                                                      OLD-MOUSE-DEST-Y)
;;;                                                        (W:READ-ANY))
;;;        DO (PROGN
;;;             ;; Identify the dest point selected by the user.
;;;             (SETQ OLD-MOUSE-DEST-X DEST-X
;;;                   OLD-MOUSE-DEST-Y DEST-Y)
;;;             (SEND WINDOW :DRAW-FILLED-CIRCLE DEST-X DEST-Y 3)
;;;             (DRAW-DASHED-RECTANGLE WINDOW DEST-X DEST-Y WIDTH HEIGHT)
;;;             (DRAW-RECTANGLE WINDOW SOURCE-X-OFFSET SOURCE-Y-OFFSET SOURCE-WIDTH SOURCE-HEIGHT)
;;;             (DRAW-RECTANGLE WINDOW DEST-X-OFFSET DEST-Y-OFFSET DEST-WIDTH DEST-HEIGHT)
;;;             (FORMAT WINDOW "Width=~D, Height=~D, FROM-X=~D, FROM-Y=~D, TO-X=~D, TO-Y=~D"
;;;                     WIDTH HEIGHT
;;;                     (- SOURCE-X SOURCE-X-OFFSET) (- SOURCE-Y SOURCE-Y-OFFSET)
;;;                     (- DEST-X DEST-X-OFFSET) (- DEST-Y DEST-Y-OFFSET))

;;;             (LET* ((RESULT (COPY-ARRAY-CLIPPED
;;;                              WIDTH HEIGHT
;;;                              SOURCE (- SOURCE-X SOURCE-X-OFFSET) (- SOURCE-Y SOURCE-Y-OFFSET)
;;;                              DEST (- DEST-X DEST-X-OFFSET) (- DEST-Y DEST-Y-OFFSET)))
;;;                    (WIDTH (FIRST RESULT))
;;;                    (HEIGHT (SECOND RESULT))
;;;                    (FX (THIRD RESULT))
;;;                    (FY (FOURTH RESULT))
;;;                    (TX (FIFTH RESULT))
;;;                    (TY (SIXTH RESULT)))
;;;               (FORMAT WINDOW "~%Width=~D, Height=~D, FROM-X=~D, FROM-Y=~D, TO-X=~D, TO-Y=~D"
;;;                       WIDTH HEIGHT FX FY TX TY)
;;;               (DRAW-RECTANGLE WINDOW (+ FX SOURCE-X-OFFSET) (+ FY SOURCE-Y-OFFSET) WIDTH HEIGHT)
;;;               (DRAW-RECTANGLE WINDOW (+ TX DEST-X-OFFSET) (+ TY DEST-Y-OFFSET) WIDTH HEIGHT)
;;;               ))))

;;;(DEFUN DRAW-RECTANGLE (WINDOW X Y WIDTH HEIGHT)
;;;  (SEND WINDOW :DRAW-LINE X Y (+ X WIDTH) Y)
;;;  (SEND WINDOW :DRAW-LINE X Y X (+ Y HEIGHT))
;;;  (SEND WINDOW :DRAW-LINE (+ X WIDTH) Y (+ X WIDTH) (+ Y HEIGHT))
;;;  (SEND WINDOW :DRAW-LINE X (+ Y HEIGHT) (+ X WIDTH) (+ Y HEIGHT)))

;;;(DEFUN DRAW-DASHED-RECTANGLE (WINDOW X Y WIDTH HEIGHT)
;;;  (SEND WINDOW :DRAW-DASHED-LINE X Y (+ X WIDTH) Y)
;;;  (SEND WINDOW :DRAW-DASHED-LINE X Y X (+ Y HEIGHT))
;;;  (SEND WINDOW :DRAW-DASHED-LINE (+ X WIDTH) Y (+ X WIDTH) (+ Y HEIGHT))
;;;  (SEND WINDOW :DRAW-DASHED-LINE X (+ Y HEIGHT) (+ X WIDTH) (+ Y HEIGHT)))

(DEFUN X-COPY-TO-WINDOW (WIDTH HEIGHT PIXMAP PIXMAP-X PIXMAP-Y WINDOW WINDOW-X WINDOW-Y)
  "Copy the contents of PIXMAP to WINDOW."
  (LET* ((FRAME-BUFFER        (DEVICE-PRIVATE-WINDOW-ARRAY WINDOW))
         (FRAME-BUFFER-WIDTH  (ARRAY-DIMENSION FRAME-BUFFER 1))
         (FRAME-BUFFER-HEIGHT (ARRAY-DIMENSION FRAME-BUFFER 0))
         (PARENT (WINDOW.PARENT WINDOW))
         (PARENT-X (WINDOW.ABSOLUTE-INSIDE-X PARENT))
         (PARENT-Y (WINDOW.ABSOLUTE-INSIDE-Y PARENT)))
    (SETQ WINDOW-X (+ WINDOW-X (WINDOW.ABSOLUTE-INSIDE-X WINDOW)))
    (SETQ WINDOW-Y (+ WINDOW-Y (WINDOW.ABSOLUTE-INSIDE-Y WINDOW)))

    (WHEN (< WINDOW-X PARENT-X)
      (SETQ WIDTH  (+ WIDTH  (- WINDOW-X PARENT-X))
            WINDOW-X PARENT-X))
    (WHEN (< WINDOW-Y PARENT-Y)
      (SETQ HEIGHT (+ HEIGHT (- WINDOW-Y PARENT-Y))
            WINDOW-Y PARENT-Y))

    (WHEN (> (+ WINDOW-X WIDTH) FRAME-BUFFER-WIDTH)
      (SETQ WIDTH (MAX 0 (- FRAME-BUFFER-WIDTH WINDOW-X))))
    (WHEN (> (+ WINDOW-Y HEIGHT) FRAME-BUFFER-HEIGHT)
      (SETQ HEIGHT (MAX 0 (- FRAME-BUFFER-HEIGHT WINDOW-Y))))
    (WHEN (AND (PLUSP WIDTH) (PLUSP HEIGHT))
      (X-BITBLT GX-COPY WIDTH HEIGHT 
                (PIXMAP.ARRAY PIXMAP) PIXMAP-X PIXMAP-Y
                FRAME-BUFFER          WINDOW-X WINDOW-Y))))

(DEFUN X-COPY-FROM-WINDOW (WIDTH HEIGHT WINDOW WINDOW-X WINDOW-Y PIXMAP PIXMAP-X PIXMAP-Y)
  "Copy the contents of WINDOW to PIXMAP."
  (DECLARE (TYPE INTEGER WIDTH HEIGHT WINDOW-X WINDOW-Y PIXMAP-X PIXMAP-Y))
  (LET* ((FRAME-BUFFER        (DEVICE-PRIVATE-WINDOW-ARRAY WINDOW))
         (FRAME-BUFFER-WIDTH  (ARRAY-DIMENSION FRAME-BUFFER 1))
         (FRAME-BUFFER-HEIGHT (ARRAY-DIMENSION FRAME-BUFFER 0))
         (PIXMAP-WIDTH        (PIXMAP.WIDTH  PIXMAP))
         (PIXMAP-HEIGHT       (PIXMAP.HEIGHT PIXMAP)))
    (SETQ WINDOW-X (+ WINDOW-X (WINDOW.ABSOLUTE-INSIDE-X WINDOW)))
    (SETQ WINDOW-Y (+ WINDOW-Y (WINDOW.ABSOLUTE-INSIDE-Y WINDOW)))
    (WHEN (> (+ WINDOW-X WIDTH) FRAME-BUFFER-WIDTH)
      (SETQ WIDTH (MAX 0 (- FRAME-BUFFER-WIDTH WINDOW-X))))
    (WHEN (> (+ WINDOW-Y HEIGHT) FRAME-BUFFER-HEIGHT)
      (SETQ HEIGHT (MAX 0 (- FRAME-BUFFER-HEIGHT WINDOW-Y))))
    (WHEN (> (+ PIXMAP-X WIDTH) PIXMAP-WIDTH)
      (SETQ WIDTH (MAX 0 (- PIXMAP-WIDTH PIXMAP-X))))
    (WHEN (> (+ PIXMAP-Y HEIGHT) PIXMAP-HEIGHT)
      (SETQ HEIGHT (MAX 0 (- PIXMAP-HEIGHT PIXMAP-Y))))
    (WHEN (AND (PLUSP WIDTH) (PLUSP HEIGHT))
      (X-BITBLT GX-COPY WIDTH HEIGHT 
                FRAME-BUFFER          WINDOW-X WINDOW-Y
                (PIXMAP.ARRAY PIXMAP) PIXMAP-X PIXMAP-Y))))

;;; The following function was modified from SYS:MAYBE-SYS-LOGIN.  The idea here is
;;; to log into the place where fonts are located without having the user intervene.

(DEFUN FONT-HOST-LOGIN (INITIAL-HOST)
  "Make sure it is possible to read font files, by logging in if necessary.
The site configuration file specifies the user-name and password to use,
as well as what the system file host is.
The value returned by this function is a form to evaluate to perform a logout."
  (LET (
        ;; Make sure that this is the real host and not just a logical host.
        (HOST (FUNCALL (FS:GET-PATHNAME-HOST INITIAL-HOST) :HOST))
        (USER-NAME (GET-SITE-OPTION :SYS-LOGIN-NAME))
        PASSWORD)
    (UNLESS (ASSOC `(,USER-NAME ,(FUNCALL HOST :NAME)) FS:USER-HOST-PASSWORD-ALIST :TEST #'EQUAL)
      (SETQ PASSWORD `((,USER-NAME ,(FUNCALL HOST :NAME)) ,(GET-SITE-OPTION :SYS-LOGIN-PASSWORD)))
      (PUSH PASSWORD FS:USER-HOST-PASSWORD-ALIST))
    (COND
      ((MEMBER USER-ID '(NIL "") :TEST #'EQUAL)
       (LOGIN USER-NAME HOST T)
       #'(lambda ()
          (LOGOUT)
          (SETQ FS:USER-HOST-PASSWORD-ALIST (DELETE PASSWORD FS:USER-HOST-PASSWORD-ALIST))))
      ((NULL (ASSOC HOST FS:USER-UNAMES :TEST #'EQ))
       (PUSH (CONS HOST (GET-SITE-OPTION :SYS-LOGIN-NAME)) FS:USER-UNAMES)
       #'(lambda ()
          (SYS:FLUSH-UNAME HOST)
          (SETQ FS:USER-HOST-PASSWORD-ALIST (DELETE PASSWORD FS:USER-HOST-PASSWORD-ALIST))))
      (T
       #'(lambda () (SETQ FS:USER-HOST-PASSWORD-ALIST (DELETE PASSWORD FS:USER-HOST-PASSWORD-ALIST)))))))
;1;;*
;1;; Setup network protocol*
;1;;*
(net:define-logical-contact-name
  "X11"
  `((:local "X11")
    (:chaos "X11")
    (:tcp ,(x-tcp-port-number))))

(net:define-service :X11 () () "X Window System, Version 11")

(net:add-server-for-medium :byte-stream
			   "X11"
			   '(SI:PROCESS-RUN-FUNCTION "X Server" 'SERVER-TOP-LEVEL))

(si:add-initialization
  "2Disable X*"
  '(setq X-ENABLED nil)
  :head-of-list)

(si:add-initialization
  "2Reset X*"
  '(x11:reset t))

;; Load clx-patch which allows CLX to use local or chaos connections to the server
(when (find-package 'xlib)
  (si:load-if "X11M:SERVER;CLX-PATCH"))