;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*-

;;; Reason: Prevent infinite loop in poly-arc request.

;;;                           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, M/S 2151             
;;;   AUSTIN, TEXAS 78769                 
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Patch file for X11M version 6.8
;;; Written 07/07/89 19:29:54 by buehring,
;;; while running on Spud from band LOD4
;;; With SYSTEM 6.10, VIRTUAL-MEMORY 6.1, EH 6.3, MAKE-SYSTEM 6.0, MICRONET 6.0, LOCAL-FILE 6.0,
;;;  BASIC-PATHNAME 6.1, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.1, NETWORK-NAMESPACE 6.0,
;;;  DISK-IO 6.0, DISK-LABEL 6.0, BASIC-FILE 6.2, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0,
;;;  COMPILER 6.7, TV 6.12, DATALINK 6.0, CHAOSNET 6.0, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.1,
;;;  SYSLOG 6.1, STREAMER-TAPE 6.4, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.3,
;;;  DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.1, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.3, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.1,
;;;  IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.1, TELNET 6.0, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.2, TI-CLOS 6.11, CLEH 6.4, IP 3.47,
;;;  Experimental BUG 11.10, Experimental CLX 6.2, CLUE 6.5, X11M 6.7,  microcode 429,
;;;  Band Name: Release 6.0 + SLE  6/26

#!C
; From file DRAW-ARC.LISP#> X11M.SERVER; MR-X:
#10R X11#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "X11"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* SYS:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: X11M.SERVER; DRAW-ARC.#"


(defun  draw-elliptical-pie-slice (cent-x cent-y half-width half-height theta-1 theta-2
				   destination alu color value fill-p &optional chordp)
  " Generate the points that define  the path of an ellipse. If fill-p is t, fill the ellipse.
 Theta-1 is the starting angle, and theta-2 is the ending angle relative to theta-1."
  (declare (type integer cent-x cent-y  half-height half-width ))

  ;;Handle trivial case and avoid infinite loop
  (when (and (zerop half-width) (zerop half-height))
    (return-from draw-elliptical-pie-slice))

  (let* ((w     half-width) 
	 (h     half-height)
	 (x      (+ w cent-x))			;IT WORKS. DON'T FIX IT
   	 (y   cent-y)       
	 (start-x x)				;SAVE              
	 (start-reflex (- cent-x w))		;GET REFLECTED X
	 
	 ;; SET THE FOLLOWING TO AVOID MULTIPLICATION IN THE LOOPS
	 (w^2 (* w w))				; T1 BREVITY AND NMEMONICITY CONFLICT. MAYBE T1 THRU T9 ARE BETTER.
	 (2w^2 (* w^2 2))			;T2 
	 (4w^2 (* 2w^2 2))			;T3 
	 (h^2 (* h h))				;T4 
	 (2h^2 (* h^2 2))			;T5
	 (4h^2 (* 2h^2 2))			;T6
	 (2wh^2 (* w 2h^2))			;T7 
	 (4h^2-x (* 2wh^2 2))			;T8
	 (4w^2-y 0 )				;T9 WID      
	 ;;(t2 - t7) + (t4 / 2)
	 (decide-1  (+ (-  2w^2 2wh^2)  (/ h^2 2.0s0))) 
	 ;;((t1 / 2) - t8) + t5
	 (decide-2  (+ (- (/ w^2 2.0s0) 4h^2-x) 2h^2))
	 co-x0
	 co-y0
	 co-x1
	 co-y1
	 slope
	 ;; Flag is T when the arc angle is greater than PI radians.
	 (flag (> (abs theta-2) short-pi))
	 draw-clipped-raster
	 )
    (flet ((draw-clipped-slice-raster (x0 x1 y0 &rest ignore)
	     (let* ((u0 (- x0 cent-x)) ;; Translate values so center is at 0,0
		    (u1 (- x1 cent-x))
		    (v0 u0)
		    (v1 u1)
		    (y (- y0 cent-y)))
	       (when (> (* co-y0 y) (* co-x0 u1))	;Clip with first plane
		 (setq u1 (if (= 0 co-x0) 0 (truncate (* co-y0 y) co-x0))))
	       (when (> (* co-y0 y) (* co-x0 u0))
		 (setq u0 (if (= 0 co-x0) 0 (truncate (* co-y0 y) co-x0))))
	       
	       (when (< (* co-y1 y) (* co-x1 v1))	;Clip with second plane
		 (setq v1 (if (= 0 co-x1) 0 (truncate (* co-y1 y) co-x1))))
	       (when (< (* co-y1 y) (* co-x1 v0))
		 (setq v0 (if (= 0 co-x1) 0 (truncate (* co-y1 y) co-x1))))
	       
	       (cond ((not flag)
		      (let ((left (max u0 v0))	;Compute intersection
			    (right (min u1 v1)))
			(and (> right left)
			     (sys:%draw-shaded-raster-line (+ cent-x left) (+ cent-x right) (+ cent-y y)
							   alu t color destination))))
		     
		     ((and (> u1 u0) (> v1 v0))	; Ensure rasters don't overlap
		      (cond ((<= u0 v0 u1)
			     (sys:%draw-shaded-raster-line (+ cent-x u0) (+ cent-x (max u1 v1)) (+ cent-y y)
							   alu t color destination))
			    ((<= v0 u0 v1)
			     (sys:%draw-shaded-raster-line (+ cent-x v0) (+ cent-x (max u1 v1)) (+ cent-y y)
							   alu t color destination))
			    (t
			     (sys:%draw-shaded-raster-line (+ cent-x u0) (+ cent-x u1) (+ cent-y y)
							   alu t color destination)
			     (sys:%draw-shaded-raster-line (+ cent-x v0) (+ cent-x v1) (+ cent-y y)
							   alu t color destination))))
		     ((> u1 u0)
		      (sys:%draw-shaded-raster-line (+ cent-x u0) (+ cent-x u1) (+ cent-y y)
						    alu t color destination))
		     ((> v1 v0)
		      (sys:%draw-shaded-raster-line (+ cent-x v0) (+ cent-x v1) (+ cent-y y)
						    alu t color destination)))))

	   (draw-clipped-chord-raster (x0 x1 y0)
	      (macrolet ((xint (default)
			  ;; Return the x-intercept
			  `(cond ((null slope) co-x0)	  ;; Vertical
				 ((zerop slope) ,default) ;; Horizontal
				 (t (let ((res (floor (- y0 (- co-y0 (* slope co-x0))) slope)))
				      ,(if (eq default 'x0)
					   '(max res x0)
					 '(min res x1))))))
			 (draw-raster-line (xa xb y)
			   (once-only (xa xb)
			     `(when (< ,xa ,xb)
				(if fill-p
				    (sys:%draw-shaded-raster-line ,xa ,xb ,y alu t color destination)
				  (when (eq ,xa x0) ;; use eq for better optimization
				    (sys:%draw-shaded-raster-line ,xa ,xa ,y alu t color destination)
                                    #+comment
				    (setf (aref destination ,y ,xa) (boole alu value (aref destination ,y ,xa))))
				  (when (eq ,xb x1)
				    (sys:%draw-shaded-raster-line ,xb ,xb ,y alu t color destination)
                                    #+comment
				    (setf (aref destination ,y ,xb) (boole alu value (aref destination ,y ,xb)))))))))
	      (cond ((= co-y0 co-y1)
		     (if (> co-x0 co-x1)
			 (when (<= y0 co-y0) (draw-raster-line x0 x1 y0))
			 (when (>= y0 co-y0) (draw-raster-line x0 x1 y0))))
		    ((< co-y0 co-y1) (draw-raster-line x0 (xint x1) y0))
		    (t
		     (draw-raster-line (xint x0) x1 y0)))))

	   (draw-full-raster (x0 x1 y0)
	      (sys:%draw-shaded-raster-line x0 x1 y0 alu t color destination))

	   (draw-full-points (x0 x1 y0)
	      (setf (aref destination  y0 x0) (boole alu value (aref destination y0 x0)))
	      (setf (aref destination  y0 x1) (boole alu value (aref destination y0 x1))))

	   (ellipitical-translate (theta half-width half-height x y)
	     (let ((d (sqrt (+ (* (expt half-width 2) (expt (sin theta) 2))
			       (* (expt half-height 2) (expt (cos theta) 2))))))
	       (values (+ x (floor (/ (* half-width half-height (cos theta)) d)))
		       (+ y (floor (/ (* half-width half-height (- (sin theta))) d))))))

	   #+comment ;; This works too, but it's ugly...
	   (ellipitical-translate (theta half-width half-height x y)
	     ;; tan(t1) = half-width / half-height * tan(theta)
	     ;; if a = arctan q then cos a = 1 / sqrt (1 + (q * q))
	     ;;                 and  sin a = q / sqrt (1 + (q * q))
	     (let ((hw (/ half-width (short-float half-height)))
		   (sin (sin theta))
		   (cos (cos theta)))
	       (cond ((zerop cos)
		      (setq cos 0 sin (signum sin)))
		     ((zerop sin)
		      (setq cos (signum cos) sin 0))
		     (t (let* ((r (and (not (zerop cos)) (abs (* (/ sin cos) hw))))
			       (q (if (zerop r) 1.0 (sqrt (+ 1.0s0 (* r r))))))
			  (setq cos (* (/ 1.0s0 q) (signum cos))
				sin (* (/ r q) (signum sin))))))
	       (values (+ x (floor (* half-width cos)))
		       (+ y (floor (* half-height (- sin)))))))
	   )

      (cond ((>= theta-2 2-pi)			; Whole Ellipse
	     (setq draw-clipped-raster
		   (if fill-p #'draw-full-raster #'draw-full-points)))	    
	    ((or chordp (not fill-p))		; Chord or Line only
	     (setq draw-clipped-raster #'draw-clipped-chord-raster
		   theta-2 (+ theta-1 theta-2))
	     (when (> theta-1 theta-2) (rotatef theta-1 theta-2))
	     ;; Calculate the X/Y coordinates of the points on the ellipse at angles THETA-1 and THETA-2
	     (multiple-value-setq (co-x0 co-y0)
	       (ellipitical-translate theta-1 half-width half-height cent-x cent-y))
	     (multiple-value-setq (co-x1 co-y1)
	       (ellipitical-translate theta-2 half-width half-height cent-x cent-y))
	     (setq slope (and (not (= co-x0 co-x1))
			      (/ (- co-y0 co-y1) (short-float (- co-x0 co-x1)))))
;; debug
;;	     (send *terminal-io* :draw-line cent-x cent-y co-x0 co-y0)
;;	     (send *terminal-io* :draw-line cent-x cent-y co-x1 co-y1)
	     )
	    (t					; Filled elliptical slice
	     (setq draw-clipped-raster #'draw-clipped-slice-raster
		   theta-2 (+ theta-1 theta-2))
	     (when (> theta-1 theta-2) (rotatef theta-1 theta-2))
	     (setq co-x0 (values (floor (* -1000.0s0 (sin theta-1))))
		   co-y0 (values (floor (*  1000.0s0 (cos theta-1))))
		   co-x1 (values (floor (* -1000.0s0 (sin theta-2))))
		   co-y1 (values (floor (*  1000.0s0 (cos theta-2)))))))

    ;; FIRST XY
      (funcall draw-clipped-raster  (- cent-x w) x y)
    
    ;; REST OF ELLIPSE
    (do ((reflex-x   (- cent-x w) (+ start-reflex (abs (- start-x x))))
	 (reflex-y (- cent-y (abs (- cent-y y))) (- cent-y (abs (- cent-y y)))))
	
	((> decide-2 0))			;EXIT
      
      ;; REGION ONE OF ELLIPSE
      
      (funcall draw-clipped-raster reflex-x x y)
      (funcall draw-clipped-raster reflex-x x reflex-y)
      
      (incf y 1)  ;; REGION 1. ALWAYS INCREMENT Y.
      (setq 4w^2-y (+ 4w^2-y 4w^2 ))		;T9 T3
      
      (if (< decide-1 0) 
	  (progn
	    (incf decide-1 (+  4w^2-y 2w^2 ))	;T9 T2
	    (incf decide-2 4w^2-y))               
						;ELSE
	(progn 
	  (decf x 1)
	  (decf   4h^2-x 4h^2 )			;T8 T6
	  (setq  decide-1 (+ (- decide-1 4h^2-x) 4w^2-y 2w^2)) 
	  (setq  decide-2 (+ (- decide-2  4h^2-x) 4w^2-y 2h^2)))))
    
    ;; REGION TWO
    
    (do  ((reflex-x  (- cent-x  (abs (- cent-x  x))) (- cent-x  (abs (-  cent-x  x))))
	  (reflex-y (- cent-y (abs (- cent-y y))) (- cent-y (abs (- cent-y y))))
	  (new-y-p t))
	 
	 
	 ((<   x  cent-x)) ;; exit

      (when new-y-p   ;; IF NEW Y THEN DRAW LINE. AVOID DRAWING LINE TWICE..
	(funcall draw-clipped-raster reflex-x x y)
	(funcall draw-clipped-raster reflex-x x reflex-y))
      
      (decf x 1)
      (decf 4h^2-x 4h^2 )			; T8 T6
      
      (if (< decide-2 0)  ;; GO TO PIXEL C?
	  (progn
	    
	    (incf y 1 ) ;; (DECF Y 1)
	    (setq new-y-p t)
	    (setq 4w^2-y (+ 4w^2-y 4w^2 ))	;T9 T3    ;;( 4W^2-Y 4W^2 ) ;T9 T3   ;(d2 - t8) + t5
	    (setq  decide-2  (+ (- decide-2  4h^2-x) 4w^2-y 2h^2)))	;T895
	(progn
	  (setq decide-2  (+ (- decide-2  4h^2-x)  2h^2))
	  (setq new-y-p nil)))))))

))