;;; -*- Mode:Common-Lisp; Package:X11; Fonts:(MEDFNB HL12BI HL12B); Base:10 -*-
 
;;;                           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
;;; -------------------------------------------------------------------------------------
;;; 11/22/88    LGO     Make fill-poly work with negative coordinates.
;;; 11/08/88    DAN     Removed error-causing trace statement from FILL-POLY.
;;; 11/08/88	LGO	Use WITH-DRAWABLE in 1fill-polygon*
;;;  9/30/88	LGO	1Adjust origin* to work on temporary arrays1 in* 1fill-poly*
;;;  9/27/88	LGO	When drawing on temporary, use correct ALU in fill-poly
;;;  9/12/88    LGO	Use short-float's instead of rationals for slope in fill-polygon
;;;  5/27/88    TWE	Fixed to use the ALU correctly.
;;;  5/26/88    DAN	Commented out the second definition of fill-poly.
;;;  3/05/88    KDB	Reimplemented to use clipping.
;;; 10/12/87    KDB	Fixed bug in code that removes extraneous point pairs.
;;;  9/17/87    KDB	Modified routines to work with array data for Xv11 server.
;;;  9/15/87    KSK	Inititial algorithm development.

;;; Given an array of point pairs, create a list of vertices. Then fill the
;;; area using draw-shaded-raster-line.

(PROCLAIM '(OPTIMIZE SPEED))

(DEFSTRUCT EDGE  MIN-X MIN-Y MAX-Y SLOPE)

(DEFPARAMETER *ACTIVE-EDGES* (MAKE-ARRAY 1 
				   :ELEMENT-TYPE 'EDGE
				   :ADJUSTABLE T
				   :FILL-POINTER 0))

(DEFPARAMETER VERTEX-ARRAY (MAKE-ARRAY 1    :ELEMENT-TYPE 'INTEGER
				   :ADJUSTABLE T
				   :FILL-POINTER 0))

(DEFUN RETURN-OFFSET-POINTS (POINTS LENGTH OFFSET ORIGIN-X ORIGIN-Y  COORD-MODE)
  "Return an array of adjusted X Y positions.  Depending of the coord-mode,  the X Y
   positions are offset relative to the origin (coord-mode-origin) or  relative to the
   previous X Y position (coord-mode-previous)."
  (LET* ((TEMP-ARRAY (MAKE-ARRAY LENGTH :ELEMENT-TYPE 'INTEGER))
	 (TEMP-END   (-  LENGTH 2)))
    ;; Set the first X Y. Will always be relative to origin.
    (IF (= COORD-MODE COORD-MODE-ORIGIN)
	(DO*  ((X-POS OFFSET       (INCF X-POS 2))
	       (Y-POS (+ OFFSET 1) (INCF Y-POS 2))
	       (TEMP-X-POS    0    (INCF  TEMP-X-POS 2))
	       (TEMP-Y-POS    1    (INCF  TEMP-Y-POS 2))
	       ;; All  points are relative to origin.
	       (NEXT-X   (+ ORIGIN-X   (AREF-int16 POINTS X-POS))
			 (+ ORIGIN-X   (AREF-int16 POINTS X-POS)))
	       (NEXT-Y   (+ ORIGIN-Y   (AREF-int16 POINTS Y-POS))
			 (+ ORIGIN-Y   (AREF-int16 POINTS Y-POS))))
	      ((> TEMP-Y-POS  TEMP-END)
               (PROGN (SETF (AREF TEMP-ARRAY TEMP-X-POS)   NEXT-X)     ; Set last two points
                      (SETF (AREF TEMP-ARRAY TEMP-Y-POS)   NEXT-Y)
                      (RETURN TEMP-ARRAY)))
	  (SETF (AREF TEMP-ARRAY TEMP-X-POS)   NEXT-X)
	  (SETF (AREF TEMP-ARRAY TEMP-Y-POS)   NEXT-Y))
        ;;ELSE 
	(DO*  ((X-POS OFFSET       (INCF X-POS 2))
	       (Y-POS (+ OFFSET 1) (INCF Y-POS 2))
	       (TEMP-X-POS    0    (INCF  TEMP-X-POS 2))
	       (TEMP-Y-POS    1    (INCF  TEMP-Y-POS 2))
               ;; First X Y points are always relative to origin.
               ;; After that, relative to previous X Y.
	       (NEXT-X    (+ ORIGIN-X (AREF-int16 POINTS X-POS))
			  (+ NEXT-X (AREF-int16 POINTS X-POS)))
	       (NEXT-Y    (+ ORIGIN-Y (AREF-int16 POINTS Y-POS))
			  (+ NEXT-Y (AREF-int16 POINTS Y-POS))))
	      ((> TEMP-Y-POS  TEMP-END)
               (PROGN (SETF (AREF TEMP-ARRAY TEMP-X-POS)   NEXT-X)     ; Set last two points
                      (SETF (AREF TEMP-ARRAY TEMP-Y-POS)   NEXT-Y)
                      (RETURN TEMP-ARRAY)))
	  (SETF (AREF TEMP-ARRAY  TEMP-X-POS)   NEXT-X) 
	  (SETF (AREF TEMP-ARRAY  TEMP-Y-POS)   NEXT-Y)))
    TEMP-ARRAY))

;;; Test code
;;;(SETQ POINTS #(100 100 50 50 200 200 100 100 100 200 50 100 200 100 100 50))

;;;(SETQ THE-POINTS NIL)
;;;(SETQ THE-POINTS (RETURN-OFFSET-POINTS  #(100  100   500  100    300  200) 6 0 0 0 0))
;;;(SETQ THE-POINTS (RETURN-OFFSET-POINTS  #(100  100   200  100 250 150  200  200  100  200 50 150 100 100)
;;;		       14 0 0 0 0))

;;;(SETQ THE-POINTS (RETURN-OFFSET-POINTS  #(100 100 50 50 200 200 100 100 100 200 50 100 200 100 100 50)
;;;		       16 0 0 0 0))
;;;(SETQ THE-POINTS (RETURN-OFFSET-POINTS  #(100 100 50 50 200 200 100 100 100 200 50 100 200 100 100 50)
;;;		       16 0 50 50 1)) 
;;;;;;(SETQ EDGE NIL)
;;;(SETQ EDGE (BUILD-EDGE-TABLE #(100  100   500  100    300  200) 6 0 0 0 0))
;;;(SETQ EDGE (BUILD-EDGE-TABLE #(100  100   100  200   200  100  200  200) 8 0 0 0 0))
;;;(SETQ EDGE (BUILD-EDGE-TABLE #(100  100   200  100 250 150  200  200  100  200 50 150 100 100)
;;;		  14 0 0 0 0))

;;;(SETQ EDGE (BUILD-EDGE-TABLE #(100  100   200  100 250 150  200  200  100  200 50 150)
;;;		  12 0 0 0 0))

;;;(SETQ EDGE (BUILD-EDGE-TABLE #(100 100 50 50 200 200 100 100 100 200 50 100 200 100 100 50)
;;;		  16 0 0 0 0))
;;;(SETQ EDGE (BUILD-EDGE-TABLE #(100 100 50 50 200 200 100 100 100 200 50 100 200 100 100 50)
;;;		  16 0 0 0 1))  ; ORIGIN-X ORIGIN-Y COORD-MODE)

(DEFUN BUILD-EDGE-TABLE (POINTS LENGTH OFFSET ORIGIN-X ORIGIN-Y COORD-MODE)
 "Given an array of points from the server byte stream, build a vector of edges
and return to fill-poly.  LENGTH is the number of points to be grabbed from the
stream, starting at the strem offset."
  (IF (< LENGTH  6)
      ;; If less than 3 point pairs, return nil. 
      NIL
      ;;ELSE
      (LET* ((EDGE-TABLE NIL)	    
	     ;; Grab the relevent points off the server byte stream. Put in a temp-array.
	     (TEMP-ARRAY (RETURN-OFFSET-POINTS POINTS LENGTH OFFSET ORIGIN-X ORIGIN-Y COORD-MODE))
	     (TEMP-X-POS 0) 
             ;; Compare this with very last point in array.
	     (SAVED-FIRST-X (AREF TEMP-ARRAY    TEMP-X-POS))
	     (SAVED-FIRST-Y (AREF TEMP-ARRAY (+ TEMP-X-POS 1))))
        ;; Remove any extraneous vertices (i.e. NIL out any point
        ;; pairs that are same as the prior pair).
	;; May have used before.
	(SETF (FILL-POINTER VERTEX-ARRAY) 0)
        ;; Put on first points.
        (VECTOR-PUSH-EXTEND SAVED-FIRST-X VERTEX-ARRAY 1)
        (VECTOR-PUSH-EXTEND SAVED-FIRST-Y VERTEX-ARRAY 1)
        ;; Work forward looking for duplicates.
        (LOOP FOR INDEX FROM 2 BELOW LENGTH BY 2
              FOR COMP-X FIRST SAVED-FIRST-X THEN NEXT-X
              FOR COMP-Y FIRST SAVED-FIRST-Y THEN NEXT-Y
              FOR NEXT-X = (AREF TEMP-ARRAY INDEX)
              FOR NEXT-Y = (AREF TEMP-ARRAY (1+ INDEX))
              DO (WHEN (NOT (AND (EQL COMP-X NEXT-X) (EQL COMP-Y NEXT-Y)))
                   (VECTOR-PUSH-EXTEND NEXT-X VERTEX-ARRAY 1)
                   (VECTOR-PUSH-EXTEND NEXT-Y VERTEX-ARRAY 1)))

        (WHEN (PLUSP (LENGTH VERTEX-ARRAY))      ; Might have no vertices.
          ;; Loop invariant: (NOT (EQ PPY (POINT-Y CP)))
	  (DO* ((INDEX      0    (+ INDEX 2))
                (LAST-X-POS (- (LENGTH VERTEX-ARRAY) 2))       ; length may have changed..
                (LAST-X     (AREF  VERTEX-ARRAY  LAST-X-POS))
                (LAST-Y     (AREF  VERTEX-ARRAY  (+ LAST-X-POS 1)))
                (NEXT-X)
                (NEXT-Y)
                (CURRENT-X   LAST-X NEXT-X)
                (CURRENT-Y   LAST-Y NEXT-Y)
                (TEMP-LAST   (+ LAST-X-POS 1)) ; Point at last Y position
                ;; Establish invariant by looking back for first previous point at different Y.
                (PPY (LOOP WITH CPY = CURRENT-Y
                           WHILE (> TEMP-LAST 1)
                           FOR PPY = (AREF VERTEX-ARRAY (- TEMP-LAST 2))
                           WHILE (EQ PPY CPY)
                           DO (DECF TEMP-LAST 2)
                           FINALLY (RETURN PPY))))
               ;;EXIT
               ((> INDEX LAST-X-POS))
            (SETQ NEXT-X  (AREF VERTEX-ARRAY INDEX)
                  NEXT-Y  (AREF VERTEX-ARRAY (+ INDEX 1)))
            ;; Skip over any horizontal or NIL edge.
            (UNLESS (EQL NEXT-Y CURRENT-Y)
              ;; Add a new edge to edge table.
              (LET ((EDGE  (MAKE-EDGE :SLOPE  (/ (- NEXT-X CURRENT-X)
                                                 (coerce (- NEXT-Y CURRENT-Y) 'short-float))))
                    (NOT-MAX-MIN-P (MINUSP (* (- PPY    CURRENT-Y)
                                              (- NEXT-Y CURRENT-Y)))))
                ;; If current point is not a max-min vertex, then adjust current-y
                ;; to avoid bogus edge interesection of scan line passing through current point.
                ;; Actual edge adjustment depends on whether current point corresponds to max-y
                ;; or min-y.
                (COND
                  ((> NEXT-Y CURRENT-Y)
                   (SETF (EDGE-MAX-Y EDGE) NEXT-Y)
                   (COND 
                     (NOT-MAX-MIN-P (SETF (EDGE-MIN-X EDGE) (+ CURRENT-X (EDGE-SLOPE EDGE))
                                          (EDGE-MIN-Y EDGE) (1+ CURRENT-Y)))
                     (T             (SETF (EDGE-MIN-X EDGE) CURRENT-X
                                          (EDGE-MIN-Y EDGE) CURRENT-Y))))
                  (T
                   (SETF (EDGE-MIN-X EDGE) NEXT-X
                         (EDGE-MIN-Y EDGE) NEXT-Y)
                   (COND
                     (NOT-MAX-MIN-P 
                      (SETF (EDGE-MAX-Y EDGE) (1- CURRENT-Y)))
                     (T             (SETF (EDGE-MAX-Y EDGE) CURRENT-Y)))))
                (PUSH EDGE EDGE-TABLE))
              
              ;; Set ppy for next iteration.
              (SETQ PPY CURRENT-Y)))
	
	;; Return edge table.
	EDGE-TABLE))))

(DEFUN FILL-POLY (DRAWABLE GCONTEXT SHAPE COORD-MODE LENGTH POINTS OFFSET)
  "Fills the region closed by the specified path.  The path is closed
automatically if the last point in the list does not coincide with the
first point.2 *The first point is always relative to the drawable's origin; the rest
are relative either to that origin or the previous point, depending on
the coordinate-mode."
  
  ;; Vertex-list is a list of point structures which define a polygon boundary.
  ;; The last point need not be given if it is identical to the first point.
  ;; The boundary may be complex (non-convex, self-intersecting).  See Foley
  ;; and Van Dam, 11.7.2-4 for a description of the basic algorithm used.
  
  ;; IMPLEMENTATION NOTE: we are ignoring the shape parameter for now.
  ;; Eventually we might want to use it for optimizing performance.  The shape
  ;; parameter may be used by the server to improve performance.  Complex means
  ;; the path may self-intersect.
  
  ;; Nonconvex means the path does not self-intersect, but the shape is not
  ;; wholly convex.  If known by the client, specifying Nonconvex over Complex
  ;; may improve performance.  If Nonconvex is specified for a
  ;; self-intersecting path, the graphics results are undefined.
  
  ;; Convex means the path is wholly convex.  If known by the client,
  ;; specifying Convex can improve performance.  If Convex is specified for a
  ;; path that is not convex, the graphics results are undefined.
  
  (DECLARE (IGNORE SHAPE))
  (with-drawable (drawable gcontext :clipping-rectangle t)
		 (destination-array window-x window-y explorer-alu drawable-boundaries)
    (setq explorer-alu (AREF X-ALU-TO-EXPLORER-ALU explorer-alu))
    ;; Sort edge table in order of increasing MIN-Y.
    (LET* (
	   ;; Server gives us the number of point pairs. Double it.
	   (ARRAY-LENGTH   (* LENGTH 2))
	   ;; Points are offset by build-edge-table.
	   (EDGE-TABLE     (SORT (BUILD-EDGE-TABLE POINTS ARRAY-LENGTH OFFSET
						   WINDOW-X WINDOW-Y COORD-MODE)
				 #'< :KEY #'EDGE-MIN-Y))
	   )
;      (server-trace "~%***POLY-FILL: ALU= ~d foreground= ~d background= ~d DRAWN-ON-TEMPORARY= ~s"
;		    explorer-alu (gcontext.foreground-pixel GCONTEXT)
;		    (gcontext.background-pixel GCONTEXT) DRAWN-ON-TEMPORARY)
      (unless edge-table (return nil))
      (SETF (FILL-POINTER *ACTIVE-EDGES*) 0)
      ;; Compute and draw interior scan lines from edge table.
      (DO ((CY (ROUND (EDGE-MIN-Y (FIRST EDGE-TABLE))) (1+ CY)))	
	  (())
	
	;; Add every edge beginning at the current y (cy) to the
	;; active edge array.
	(DO ()
	    ((OR (NULL EDGE-TABLE) (> (EDGE-MIN-Y (FIRST EDGE-TABLE)) CY)))
	  (VECTOR-PUSH-EXTEND (POP EDGE-TABLE) *ACTIVE-EDGES*))
	
	;; If active edge array is empty and all edges have been examined,
	;; then quit.
	(LET ((NUMBER-ACTIVE (LENGTH *ACTIVE-EDGES*)))
	  (UNLESS (OR (PLUSP NUMBER-ACTIVE) EDGE-TABLE) (RETURN))
	  ;; Sort active edges in order of increasing min-x.
	  ;; The sort algorithm (insertion from end) is designed to be fast in the
	  ;; typical case where the active edges have not changed.
	  ;; Also delete any inactive edges (i.e. with max-y < cy)
	  (SETF (FILL-POINTER *ACTIVE-EDGES*)
		(DO ((FROM 0 (1+ FROM))
		     (TO   0))
		    ((>= FROM NUMBER-ACTIVE) TO)
		  
		  ;; Find next edge still active.
		  (DO () ((OR
			    (>= (EDGE-MAX-Y (AREF *ACTIVE-EDGES* FROM)) CY)
			    (>= (INCF FROM) NUMBER-ACTIVE))))
		  
		  (WHEN (< FROM NUMBER-ACTIVE)
		    ;; Insert next edge into proper position.
		    (LET* ((NEXT-EDGE (AREF *ACTIVE-EDGES* FROM))
			   (INSERT (DO ((I      TO)
					(NEXT-X (EDGE-MIN-X NEXT-EDGE)))
				       ((OR (MINUSP (DECF I))
					    (>= NEXT-X (EDGE-MIN-X (AREF *ACTIVE-EDGES* I))))
					(1+ I)))))
		      (IF (NEQ INSERT TO)
			  (SETF *ACTIVE-EDGES* (REPLACE *ACTIVE-EDGES* *ACTIVE-EDGES*
							:START2 INSERT :END2 TO
							:START1 (1+ INSERT))))
		      (IF (NEQ INSERT FROM)
			  (SETF (AREF *ACTIVE-EDGES* INSERT) NEXT-EDGE)))
		    (INCF TO))))
	  
	  ;; Fill scan line at cy from active edge array.
	  (DO ((I 0 (+ I 2))
	       (NUMBER-ACTIVE (LENGTH *ACTIVE-EDGES*)))
	      ((>= I NUMBER-ACTIVE))
	    (SYS:%DRAW-SHADED-RASTER-LINE
	      (ROUND (EDGE-MIN-X (AREF *ACTIVE-EDGES* I))) 
	      (ROUND (EDGE-MIN-X (AREF *ACTIVE-EDGES* (1+ I))))
	      CY EXPLORER-ALU T NIL  DESTINATION-ARRAY)
	    ;; Increment x for active edges.
	    (INCF (EDGE-MIN-X (AREF *ACTIVE-EDGES* I))
		  (EDGE-SLOPE (AREF *ACTIVE-EDGES* I)))
	    (INCF (EDGE-MIN-X (AREF *ACTIVE-EDGES* (1+ I)))
		  (EDGE-SLOPE (AREF *ACTIVE-EDGES* (1+ I))))))))))

(defreq Fill-Poly ((:graphics)
		   (drawable DRAWABLE)
		   (gc GCONTEXT)
		   (shape (CARD8 Complex-Polygon NonConvex-Polygon Convex-Polygon))
		   (coord-mode (CARD8 Coord-Mode-Origin Coord-Mode-Previous))
		   (:word 2))
  (fill-poly drawable gc shape coord-mode length words word-offset))



;;;(DEFUN polygon (n)
;;;  (LET ((PRAY (MAKE-ARRAY N
;;;			  :element-type 'INTEGER
;;;			  :adjustable t
;;;			  :fill-pointer 0)))
;;;    (DOTIMES (i n (REVERSE pRAY))
;;;      (LET ((blip (SEND *terminal-io* :any-tyi)))
;;;	(VECTOR-PUSH-EXTEND (make-point :x (FOURTH blip) :y (FIFTH blip)) PRAY)))))
;;;;1;(*test-fill 1V*ARRAY)
;;;(DEFUN test-fill (ARRAY)
;;;  (w:prepare-sheet (*terminal-io*)
;;;    (fill-polygon *terminal-io* VARRAY w:50%-gray)))