;;; -*- 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
;;; -------------------------------------------------------------------------------------
;;; 03/02/89    DAN     Patch 1.30; Fix SET-INTERSECT-BOXES to delete NIL's from the list.
;;; 03/02/89	WJB	Patch 1.27: Speed up NMERGE-BOXES
;;; 02/23/89	WJB	Patch 1.21: Fix NINTERSECT-BOXES to return NIL when no
;;;			intersection as advertised1.*
;;; 12/16/88	WJB	Wrote MERGE-BOXES to simplify a list of boxes.  Changed
;;;			SET-INTERSECT-BOXES,
;;;			SET-INTERSECT-BOX-SETS, SET-SUBTRACT-BOXES, and SUBTRACT-BOX to call it.
;;;  9/23/88	LGO	1MAKE-BOX is now a macro (gets rid of runtime keyword arg parsing)*
;;;  7/07/88	WJB	Modified BOX defstruct to use :print-function option.
;;;  4/26/88    TWE	Fixed a bug in SET-INTERSECT-BOXES where one of the
;;;			arguments is NIL.
;;;  4/15/88    TWE	Fixed SET-SUBTRACT-BOXES (again) by handling the case where the
;;;			boxes to subtract is nil.
;;;  4/07/88    TWE	Fixed SET-SUBTRACT-BOXES by removing the duplicate boxes, and
;;;			also to work properly.
;;;  3/29/88    TWE	Wrote TRANSLATE-BOXES.
;;;  3/22/88    TWE	Wrote BOXES-EXTENT.
;;;  1/29/88    TWE	Wrote the SET-INTERSECT-BOX-SETS function.
;;;  1/26/88    TWE	Fixed up the make-box function to allow more combinations of
;;;		        box dimensions.
;;;  1/22/88    TWE	Added more box functions.
;;; 12/21/87    TWE	Initial creation.  Moved some code from GRAPHICS-PRIMITIVES and
;;;			SERVER-DEFS.


#|

This file contains primitives that deal with the BOX data structure.
It is reasonably self-contained.

|#

;;; Creation and accessor functions.

(defstruct (BOX
	     (:callable-constructors nil)
	     (:CONSTRUCTOR CREATE-BOX)
	     (:CONC-NAME "BOX.")
	     (:PRINT-FUNCTION PRINT-BOX-STRUCTURE))
  (left   :unbound :type integer)
  (top    :unbound :type integer)
  (right  :unbound :type integer)
  (bottom :unbound :type integer)
  )

;;; The following is a more general box creation function since it allows.
(defmacro make-box (&key LEFT RIGHT TOP BOTTOM WIDTH HEIGHT)
  (cond ((and width height)
	 (when (or bottom right)
	   (error "Can't have width/height mixed with bottom/right"))
	 (once-only (left top)
	   `(create-box :left ,left :top ,top :right (+ ,left ,width) :bottom (+ ,top ,height))))
	((and right bottom)
	 (when (or width height)
	   (error "Can't have bottom/right mixed with width/height"))
	 `(create-box :left ,left :top ,top :right ,right :bottom ,bottom))
	(t (error "Missing parameter to make-box"))))

#+comment ;1; obsolete - see above*
(DEFUN MAKE-BOX (&KEY &OPTIONAL LEFT RIGHT TOP BOTTOM WIDTH HEIGHT)
  ;; Can't have both a width and a right edge.
  (WHEN (AND RIGHT LEFT WIDTH)
    (WHEN (NOT (= (+ LEFT WIDTH) RIGHT))
      (ERROR "Error creating box.  Left, right sides and width were specified.")))
  ;; Can't have a width without a left or right edge.
  (WHEN (AND WIDTH (NULL LEFT) (NULL RIGHT))
      (ERROR "Error creating box.  A width was specified without a left or right edge."))
  ;; Can't have both a height and a bottom edge.
  (WHEN (AND BOTTOM HEIGHT TOP)
    (WHEN (NOT (= (+ TOP HEIGHT) BOTTOM))
      (ERROR "Error creating box.  Top, bottom sides and height were specified.")))
  ;; Can't have a height without a top or bottom edge.
  (WHEN (AND HEIGHT (NULL TOP) (NULL BOTTOM))
      (ERROR "Error creating box.  A height was specified without a top or bottom edge."))
  (WHEN (AND WIDTH LEFT)
    (SETQ RIGHT (+ LEFT WIDTH)))
  (WHEN (AND WIDTH RIGHT)
    (SETQ LEFT (- RIGHT WIDTH)))
  (WHEN (AND HEIGHT TOP)
    (SETQ BOTTOM (+ TOP HEIGHT)))
  (WHEN (AND HEIGHT BOTTOM)
    (SETQ TOP (- BOTTOM HEIGHT)))
  (CREATE-BOX :LEFT LEFT :TOP TOP :RIGHT RIGHT :BOTTOM BOTTOM))

(DEFMACRO BOX.WIDTH (BOX)
  `(- (BOX.RIGHT ,BOX) (BOX.LEFT ,BOX)))

(DEFMACRO BOX.SET-WIDTH (BOX VALUE)
  `(SETF (BOX.RIGHT ,BOX) (+ (BOX.LEFT ,BOX) ,VALUE)))

(DEFSETF BOX.WIDTH BOX.SET-WIDTH "Treat the box width as if it were a slot.")

(DEFMACRO BOX.HEIGHT (BOX)
  `(- (BOX.BOTTOM ,BOX) (BOX.TOP ,BOX)))

(DEFMACRO BOX.SET-HEIGHT (BOX VALUE)
  `(SETF (BOX.BOTTOM ,BOX) (+ (BOX.TOP ,BOX) ,VALUE)))

(DEFSETF BOX.HEIGHT BOX.SET-HEIGHT "Treat the box height as if it were a slot.")

#|
;;; Test cases:

;;; All of these cases generate the same box: (10,10) 10 BY 20.

(MAKE-BOX :WIDTH 10 :HEIGHT 20 :TOP 10 :LEFT 10)

(MAKE-BOX :WIDTH 10 :HEIGHT 20 :TOP 10 :RIGHT 20)

(MAKE-BOX :WIDTH 10 :HEIGHT 20 :BOTTOM 30 :LEFT 10)

(MAKE-BOX :WIDTH 10 :HEIGHT 20 :BOTTOM 30 :RIGHT 20)

(MAKE-BOX :WIDTH 10 :HEIGHT 20 :TOP 10 :BOTTOM 30 :RIGHT 20)

(MAKE-BOX :WIDTH 10 :HEIGHT 20 :BOTTOM 30 :LEFT 10 :RIGHT 20)

(MAKE-BOX :WIDTH 10 :HEIGHT 20 :TOP 10 :BOTTOM 30 :LEFT 10 :RIGHT 20)
|#

(defsubst subbox-p (large small)
  "1Returns T if SMALL is within LARGE*."
  (AND (>= (box.left   small) (box.left   large))
       (>= (box.top    small) (box.top    large))
       (<= (box.right  small) (box.right  large))
       (<= (box.bottom small) (box.bottom large))))

(defsubst box-intersect-p (box1 box2)
  "1Returns T if BOX1 intersects BOX2*."
  (NOT (OR (<= (box.right  box2) (box.left box1))
	   (<= (box.right  box1) (box.left box2))
	   (<= (box.bottom box2) (box.top  box1))
	   (<= (box.bottom box1) (box.top  box2)))))


(DEFUN BOXES-EXTENT (&REST BOXES)
  "Return a box which is the extent of the list of boxes."
  (LET ((LEFT   MOST-POSITIVE-FIXNUM)
	(TOP    MOST-POSITIVE-FIXNUM)
	(RIGHT  MOST-NEGATIVE-FIXNUM)
	(BOTTOM MOST-NEGATIVE-FIXNUM))
    (DECLARE (TYPE INTEGER LEFT TOP RIGHT BOTTOM))
    (LOOP FOR BOX IN BOXES
          DO (SETQ LEFT   (MIN LEFT   (BOX.LEFT   BOX))
                   TOP    (MIN TOP    (BOX.TOP    BOX))
                   RIGHT  (MAX RIGHT  (BOX.RIGHT  BOX))
                   BOTTOM (MAX BOTTOM (BOX.BOTTOM BOX)))
          FINALLY (RETURN (MAKE-BOX :LEFT LEFT :TOP TOP :RIGHT RIGHT :BOTTOM BOTTOM)))))


;;; Translates in place.
(DEFUN TRANSLATE-BOX (BOX X Y)
  (DECLARE (TYPE box BOX)
           (TYPE fixnum X Y))
  (INCF (BOX.LEFT   BOX) X)
  (INCF (BOX.RIGHT  BOX) X)
  (INCF (BOX.TOP    BOX) Y)
  (INCF (BOX.BOTTOM BOX) Y)
  box)

(DEFUN TRANSLATE-BOXES (BOXES X Y)
  (DECLARE (TYPE LIST BOXES)
           (TYPE fixnum X Y))
  (LOOP FOR BOX IN BOXES
        DO (PROGN
             (INCF (BOX.LEFT   BOX) X)
             (INCF (BOX.RIGHT  BOX) X)
             (INCF (BOX.TOP    BOX) Y)
             (INCF (BOX.BOTTOM BOX) Y))))

(DEFUN NINTERSECT-BOXES (nbox &REST BOXES)
  "2Destructively modifies NBOX to be the intersection of NBOX and one or more BOXES.*"
  (LET ((LEFT   (box.left nbox))
	(TOP    (box.top nbox))
	(RIGHT  (box.right nbox))
	(BOTTOM (box.bottom nbox)))
    (LOOP FOR BOX IN BOXES
	  DO 
	  (SETQ LEFT   (MAX LEFT   (BOX.LEFT   BOX))
                TOP    (MAX TOP    (BOX.TOP    BOX))
                RIGHT  (MIN RIGHT  (BOX.RIGHT  BOX))
                BOTTOM (MIN BOTTOM (BOX.BOTTOM BOX)))
	  WHEN (OR (>= LEFT RIGHT)
		   (>= TOP BOTTOM))
	  DO (RETURN NIL)
	  finally
	  (setf (box.left nbox) left
		(box.top nbox) top
		(box.right nbox) right
		(box.bottom nbox) bottom)
	  (return nbox))))

(DEFUN INTERSECT-BOXES (&REST BOXES)
  "Returns a box which is the intersection of one or more BOXES.
Returns NIL if the intersection is empty.  If there are no boxes
given, return a very large box."
  (LET ((LEFT   MOST-NEGATIVE-FIXNUM)
	(TOP    MOST-NEGATIVE-FIXNUM)
	(RIGHT  MOST-POSITIVE-FIXNUM)
	(BOTTOM MOST-POSITIVE-FIXNUM))
    (LOOP FOR BOX IN BOXES
	  DO 
	  (SETQ LEFT   (MAX LEFT   (BOX.LEFT   BOX))
                TOP    (MAX TOP    (BOX.TOP    BOX))
                RIGHT  (MIN RIGHT  (BOX.RIGHT  BOX))
                BOTTOM (MIN BOTTOM (BOX.BOTTOM BOX)))
	  WHEN (OR (>= LEFT RIGHT)
		   (>= TOP BOTTOM))
	  DO (RETURN NIL)
	  FINALLY (RETURN (MAKE-BOX :LEFT LEFT :TOP TOP :RIGHT RIGHT :BOTTOM BOTTOM)))))

(DEFUN SET-INTERSECT-BOXES (BOXES BOX)
  "Returns a list of boxes which is the intersection of each box in BOXES
with BOX.  NILs are removed."
  (IF (AND BOX BOXES)
      (LOOP FOR A-BOX IN BOXES
            WHEN (BOX-INTERSECT-P A-BOX BOX)
            COLLECT (INTERSECT-BOXES A-BOX BOX) INTO RESULT
	    FINALLY (RETURN (DELETE 'nil (NMERGE-BOXES RESULT))))
      ;;ELSE
      NIL))

(DEFUN SET-INTERSECT-BOX-SETS (BOXES1 BOXES2)
  "Returns a list of boxes which is the intersection of each box in BOXES1
with each box in BOXES2.  NILs are removed."
  (LOOP WITH INTERSECTION = NIL
        FOR A-BOX1 IN BOXES1
        DO (LOOP FOR A-BOX2 IN BOXES2
                 DO (WHEN (BOX-INTERSECT-P A-BOX1 A-BOX2)
                      (SETQ INTERSECTION (CONS (INTERSECT-BOXES A-BOX1 A-BOX2) INTERSECTION))))
        FINALLY (RETURN (NMERGE-BOXES INTERSECTION))))

#|

;;; Test case:
(SETQ BOXES1 (LIST (MAKE-BOX :LEFT 100 :TOP 100 :WIDTH 200 :HEIGHT 200)
                   (MAKE-BOX :LEFT 300 :TOP 100 :WIDTH 200 :HEIGHT 200)
                   (MAKE-BOX :LEFT 200 :TOP 400 :WIDTH 200 :HEIGHT 200)
                   (MAKE-BOX :LEFT 550 :TOP 450 :WIDTH 100 :HEIGHT 100))
      BOXES2 (LIST (MAKE-BOX :LEFT 200 :TOP   0 :WIDTH 200 :HEIGHT 200)
                   (MAKE-BOX :LEFT 500 :TOP 400 :WIDTH 200 :HEIGHT 200)
                   (MAKE-BOX :LEFT 250 :TOP 450 :WIDTH 100 :HEIGHT 100)))

(SET-INTERSECT-BOX-SETS BOXES1 BOXES2)

|#

#|
;;; Obsolete: use NMERGE-BOXES instead.
(DEFUN REMOVE-DUPLICATE-BOXES (BOXES)
  "Return a list of BOXES with the duplicates removed."
  (LOOP WITH UNIQUE-BOXES = NIL
        FOR BOX IN BOXES
        DO (PUSHNEW BOX UNIQUE-BOXES :TEST #'(LAMBDA (X Y)
                                               (AND (= (BOX.LEFT   X) (BOX.LEFT   Y))
                                                    (= (BOX.TOP    X) (BOX.TOP    Y))
                                                    (= (BOX.RIGHT  X) (BOX.RIGHT  Y))
                                                    (= (BOX.BOTTOM X) (BOX.BOTTOM Y)))))
        FINALLY (RETURN UNIQUE-BOXES)))
|#


(DEFUN NMERGE-BOXES (BOXES)
  "Modify list of BOXES to merge adjacent boxes into larger ones where possible."
  (LOOP
    WITH REST-BOXES = BOXES
    FOR BOX = (POP REST-BOXES)
    UNTIL (OR (NULL BOX) (NULL REST-BOXES))
    DO
    (LOOP
      FOR ABOX IN REST-BOXES
      FOR CHANGED = NIL
      FOR TOP-BOTTOM-ALIGNED = (AND (= (BOX.TOP BOX) (BOX.TOP ABOX))
				    (= (BOX.BOTTOM BOX) (BOX.BOTTOM ABOX)))
      FOR LEFT-RIGHT-ALIGNED = (AND (= (BOX.RIGHT BOX) (BOX.RIGHT ABOX))
				    (= (BOX.LEFT BOX) (BOX.LEFT ABOX)))
      DO
      (COND ((AND TOP-BOTTOM-ALIGNED LEFT-RIGHT-ALIGNED)
	     ;; Boxes are the same - delete abox
	     (SETQ CHANGED T))
	    (TOP-BOTTOM-ALIGNED
	     ;; top and bottom aligned - check if left or right sides touch
	     (COND ((= (BOX.LEFT BOX) (BOX.RIGHT ABOX))
		    ;; abox is to the left of box - enlarge box to consume abox
		    (SETF (BOX.LEFT BOX) (BOX.LEFT ABOX))
		    (SETQ CHANGED T))
		   ((= (BOX.RIGHT BOX) (BOX.LEFT ABOX))
		    ;; abox is to the right of box - enlarge box to consume abox
		    (SETF (BOX.RIGHT BOX) (BOX.RIGHT ABOX))
		    (SETQ CHANGED T))))
	    (LEFT-RIGHT-ALIGNED
	     ;; left and right are aligned - check if top or bottom sides touch
	     (COND ((= (BOX.TOP BOX) (BOX.BOTTOM ABOX))
		    ;; abox is above box - enlarge box to consume abox
		    (SETF (BOX.TOP BOX) (BOX.TOP ABOX))
		    (SETQ CHANGED T))
		   ((= (BOX.BOTTOM BOX) (BOX.TOP ABOX))
		    ;; abox is below box - enlarge box to consume abox
		    (SETF (BOX.BOTTOM BOX) (BOX.BOTTOM ABOX))
		    (SETQ CHANGED T)))))
      (WHEN CHANGED
	;; Delete the "consumed" box from the list
	(SETF BOXES (DELETE ABOX (THE LIST BOXES) :TEST #'EQ)))))
  BOXES)



(DEFUN SET-SUBTRACT-BOXES (INPUT-BOXES BOXES-TO-SUBTRACT)
  "Returns a list of boxes which is the part of INPUT-BOXES which doesn't overlap
with any each box in BOXES-TO-SUBTRACT.  NILs are removed."
  (IF BOXES-TO-SUBTRACT
      (LOOP WITH RESULT-BOXES = NIL
	    FOR A-BOX IN BOXES-TO-SUBTRACT
	    FOR BOXES-REMAINING = (SUBTRACT-BOX INPUT-BOXES A-BOX)
	    WHEN BOXES-REMAINING
	    DO (SETQ RESULT-BOXES (IF RESULT-BOXES
				      (SET-INTERSECT-BOX-SETS BOXES-REMAINING
							      RESULT-BOXES)
				    ;;ELSE
				    BOXES-REMAINING))
	    FINALLY (RETURN (NMERGE-BOXES RESULT-BOXES)))
    ;;ELSE
    ;; anything - 0 --> anything.
    INPUT-BOXES))

(DEFUN union-boxes (&rest boxes)
  "Returns a box which is the union of a number of BOXES (i.e.  the
smallest box that can contain all the other boxes) Returns NIL if no
boxes are given."
  (WHEN boxes 
    (LOOP for box in (REST boxes)
	  with first-box = (FIRST boxes)
	  with left  = (box.left  first-box) AND  top    = (box.top    first-box)
	  AND  right = (box.right first-box) AND  bottom = (box.bottom first-box)
	  DO 
	  (SETQ LEFT   (MIN LEFT   (BOX.LEFT   BOX)))
	  (SETQ TOP    (MIN TOP    (BOX.TOP    BOX)))
	  (SETQ RIGHT  (MAX RIGHT  (BOX.RIGHT  BOX)))
	  (SETQ BOTTOM (MAX BOTTOM (BOX.BOTTOM BOX)))

	  finally (RETURN (make-box :left left :top top :right right :bottom bottom)))))


(DEFUN inside-p (box x y)
  "1Returns T if the point X Y is inside or on BOX*."
  (NOT (OR (< x (box.left   box))
	   (< y (box.top    box))
	   (> x (box.right  box))
	   (> y (box.bottom box)))))


(DEFUN subtract-box (input-boxes box-to-subtract)
  "Given a list of INPUT-BOXES, return the list of
boxes that doesn't include the space occupied by BOX-TO-SUBTRACT.
If INPUT-BOXES is not a list, a list is created with it as its sole entry."
  (WHEN (TYPEP INPUT-BOXES 'BOX)
    (SETQ INPUT-BOXES (LIST INPUT-BOXES)))
  (LOOP with stop     = (box.top    box-to-subtract)
	with sleft    = (box.left   box-to-subtract)
	with sbottom  = (box.bottom box-to-subtract)
	with sright   = (box.right  box-to-subtract)
	for box       in input-boxes
	for itop      = (box.top    box)
	for ileft     = (box.left   box)
	for ibottom   = (box.bottom box)
	for iright    = (box.right  box)
	for intersect = nil AND outside = nil
	with new-boxes DO
	(WHEN (NOT (OR (<= iright sleft)
		       (<= sright ileft)))
	  (WHEN (< itop stop ibottom)		;TOP
	    ;; The boxes in this case look like the following.
	    ;;         .-------------------.
	    ;;         |     intersect     |
	    ;;      .--+-------------------+--.
	    ;;      |  |                   |  |
	    ;;      |  |                   |  |
	    ;;      |  |                   |  |
	    ;;      |  `-------------------'  |
	    ;;      |                         |
	    ;;      |                         |
	    ;;      |        subtract         |
	    ;;      `-------------------------'
	    ;;
	    (SETQ intersect t)
	    (PUSH (make-box :left ileft :top itop :right iright :bottom stop) new-boxes))
	  (WHEN (< itop sbottom ibottom)	;BOTTOM
	    ;; The boxes in this case look like the following.
	    ;;      .-------------------------.
	    ;;      |        subtract         |
	    ;;      |                         |
	    ;;      |                         |
	    ;;      |  .___________________.  |
	    ;;      |  |                   |  |
	    ;;      |  |                   |  |
	    ;;      |  |                   |  |
	    ;;      `--+-------------------+--'
	    ;;         |     intersect     |
	    ;;         `-------------------'
	    ;;
	    (SETQ intersect t)
	    (PUSH (make-box :left ileft :top sbottom :right iright :bottom ibottom) new-boxes)))
	(WHEN (NOT (OR (<= ibottom stop)
		       (<= sbottom itop)))
	  (WHEN (< ileft sleft iright)		;LEFT
	    ;; The boxes in this case look like the following.
	    ;;                    .-----------------.
	    ;;                    |                 |
	    ;;      .-------------+----.            |
	    ;;      |             |    |            |
	    ;;      |             |    |            |
	    ;;      |  intersect  |    |  subtract  |
	    ;;      |             |    |            |
	    ;;      |             |    |            |
	    ;;      `-------------+----'            |
	    ;;                    |                 |
	    ;;                    `-----------------'
	    ;;
	    (SETQ intersect t)
	    (PUSH (make-box :left  ileft :top    (MAX itop    stop)
                            :right sleft :bottom (MIN ibottom sbottom))
                  new-boxes))
	  (WHEN (< ileft sright iright)		;RIGHT
	    ;; The boxes in this case look like the following.
	    ;;      .-----------------.
	    ;;      |                 |
	    ;;      |            .----+-------------.
	    ;;      |            |    |             |
	    ;;      |            |    |             |
	    ;;      |  subtract  |    |  intersect  |
	    ;;      |            |    |             |
	    ;;      |            |    |             |
	    ;;      |            `----+-------------'
	    ;;      |                 |
	    ;;      `-----------------'
	    ;;
	    (SETQ intersect t)
	    (PUSH (make-box :left  sright :top    (MAX itop    stop)
                            :right iright :bottom (MIN ibottom sbottom))
                  new-boxes)))
	(UNLESS (OR intersect			;Save boxes not split above
		    (AND			;Don't save boxes covered by box-to-subtract
		      (>= ileft   sleft)
		      (>= itop    stop)
		      (<= iright  sright)
		      (<= ibottom sbottom)))
	    ;; The boxes in this case do NOT look like the following.
	    ;;      .----------------------.
	    ;;      |      subtract        |
	    ;;      |                      |
	    ;;      |   .-------------.    |
	    ;;      |   |             |    |
	    ;;      |   |             |    |
	    ;;      |   |  intersect  |    |
	    ;;      |   |             |    |
	    ;;      |   |             |    |
	    ;;      |   `-------------'    |
	    ;;      |                      |
	    ;;      `----------------------'
	    ;;
		(PUSH box new-boxes))
	finally (RETURN (nmerge-boxes new-boxes))))