;;; -*- Package: TV; Base: 10. -*-

;;; New CHOOSE-VARIABLES-VALUES type to support graphic sizes.
(defprop :positive-number
	 (prin1 read-positive-number nil nil nil "Click left to input a new number from the keyboard.")
	 choose-variable-values-keyword)

(defun read-positive-number (stream)
  (let ((val (read stream)))
    (unless (and (numberp val) (> val 0))
      (ferror nil "a positive number is required"))
    val))

(defconst *ellipse* 10000000. "Square of the largest ellipse radius to be drawn.")

;;; This method will draw an ellipse centered at (x-center, y-center) with "radius's"
;;; of x-radius and y-radius. The points are computed via an adaptation of 
;;; Brensenham's algorithim to conic sections. The equation for an ellipse is
;;; ax^2 + by^2 - c^2 = 0. The algorithim works by treating this as an error term.
;;; The key to updating the error term is to note that a unit step in y will change
;;; the error by 2by + b. (similarly for x) Decrementing y will change the error
;;; term by 2by - b.
;;; The coordinate of greatest movement is stepped by unit increments. The other
;;; coordinate is stepped conditionally depending on the size of the error term.
;;; The ellipse is draw in two passes. First we step the y and conditionaly step x.
;;; When the derivative passes through 1, we switch over to stepping x and condionally
;;; stepping y. Each time we step, we draw four points. 
;;; The conditional step is determined by testing whether the step will make the 
;;; size of the error smaller.


;;; Very special kludgey macro for :draw-ellipse. Borrowed from :draw-circle.

(defmacro ellipse-draw-clipped-point (x-val y-val)
  `(or (< ,x-val il) ( ,x-val ir)
       (< ,y-val it) ( ,y-val ib)
       (aset (boole alu -1 (aref tv:screen-array ,x-val ,y-val))
	     tv:screen-array ,x-val ,y-val)))


(defmethod (graphics-mixin :draw-ellipse)
	   #+LMI (x-center y-center x-radius y-radius &optional (alu tv:char-aluf))
	   #+Symbolics (y-center x-center y-radius x-radius &optional (alu tv:char-aluf))
  (setq x-radius (fixr x-radius)
	y-radius (fixr y-radius))
  (let ((il (tv:sheet-inside-left))
	(it (tv:sheet-inside-top))
	(ir (tv:sheet-inside-right))
	(ib (tv:sheet-inside-bottom))
	(a (fixr (// *ellipse* (* y-radius y-radius))))
	(b (fixr (// *ellipse* (* x-radius x-radius)))))
    (setq y-center (fixr (+ y-center il))
	  x-center (fixr (+ x-center it)))
    (prepare-sheet (self)
      (loop for error = 0. then (+ error bx bx b)
	    for x upfrom 0
	    for ay = (* a y)
	    for bx = (* b x)
	    for y = y-radius then (cond (( error ay)
					 (setq error (- error ay ay (- a)))
					 (setq ay (- ay a))
					 (1- y))
					(t y))
	    while (> ay bx)
	    for yr = (+ y-center y)
	    for xb = (+ x-center x)
	    for yl = (- y-center y)
	    for xt = (- x-center x)
	    do (ellipse-draw-clipped-point yr xb)
	    do (ellipse-draw-clipped-point yl xb)
	    do (ellipse-draw-clipped-point yr xt)
	    do (ellipse-draw-clipped-point yl xt))
      (loop for error = 0. then (+ error ay ay a) 
	    for y upfrom 0
	    for ay = (* a y)
	    for bx = (* b x)
	    for x = x-radius then (cond (( error bx)
					 (setq error (- error bx bx (- b)))
					 (setq bx (- bx b))
					 (1- x))
					(t x))
	    while (> bx ay)
	    for yr = (+ y-center y)
	    for xb = (+ x-center x)
	    for yl = (- y-center y)
	    for xt = (- x-center x)
	    do (ellipse-draw-clipped-point yr xb)
	    do (ellipse-draw-clipped-point yl xb)
	    do (ellipse-draw-clipped-point yr xt)
	    do (ellipse-draw-clipped-point yl xt)))))

;;;  ****************
;;;  Circular-blinker stuff
;;;  ****************

(defflavor circular-blinker
	((radius 5.))
	(blinker)
  :gettable-instance-variables
  :settable-instance-variables
  :initable-instance-variables)

(defmethod (circular-blinker :size)
	   ()
  (let ((two (* 2. radius)))
    (values two two)))

;;;  This always runs inside a sheet-prepared form.
(defmethod (circular-blinker :blink)
	   ()
  (let ((rad (float radius)))
    (do ((x 0.0s0)
	 (y rad)
	 (fy nil nfy) (nfy)
	 (fx) (nfx)
	 ( (- (* 0.9s0 (// rad))))
	 (owidth) (nwidth)
	 (flag nil))
	(nil)
      (setq nwidth (fix (* x 2))
	    nfy (fix (- y-pos y))
	    nfx (fix (- x-pos x)))
      (if (eq nfy fy)				;if same line
	  (and (> nwidth owidth)		;and this line wider
	       (setq owidth nwidth fx nfx))	;remember to draw it
	  ;; different lines, draw last one
	  (and fy (draw-rectangle-inside-clipped
		    owidth 1 (1+ fx) (1+ fy) tv:alu-xor sheet))
	  (setq owidth nwidth fx nfx fy nfy)	;remember new values
	  (if ( owidth 0)
	      (and flag (return t))
	      (setq flag t)))
      (setq y (+ y (*  x))
	    x (- x (*  y))))))

;;;  ****************
;;;  Wide-curve-blinker stuff
;;;  ****************


;;;  This is used to highlight arcs.
(defflavor wide-curve-blinker
	((x-array (make-array 10 ':leader-list '(0)))
	 (y-array (make-array 10 ':leader-list '(0)))
	 (arc nil))
	(tv:blinker)
  :gettable-instance-variables
  :settable-instance-variables
  :initable-instance-variables)


;;;  The body of this is "borrowed" from the graphics-mixin, draw-wide-curve
;;; method.
;;;
(defmethod (wide-curve-blinker :blink) (&aux curve-width end (alu tv:alu-xor))
  (setq end (array-active-length x-array))
  (setq curve-width (// graph:*line-highlight-width* 2.0s0))
    (do ((i 0 (1+ i))
	 (x0) (y0)
	 (x1) (y1)
	 (px1) (py1)
	 (px2) (py2)
	 (px3) (py3)
	 (px4) (py4))
	(( i end))
      (setq x0 x1)
      (or (setq x1 (aref x-array i)) (return nil))
      (setq y0 y1)
      (or (setq y1 (aref y-array i)) (return nil))
      (or (= i 0)
	  (let ((dx (- x1 x0))
		(dy (- y1 y0))
		len)
	    (setq len (sqrt (+ (* dx dx) (* dy dy))))
	    (and (zerop len) (= i 1) (setq len 1))
	    (cond ((not (zerop len))
		   (psetq dx (// (* curve-width dy) len)
			  dy (// (* curve-width dx) len))
		   (if (= i 1)
		       (setq px1 (fix (- x0 dx)) py1 (fix (+ y0 dy))
			     px2 (fix (+ x0 dx)) py2 (fix (- y0 dy)))
		       (setq px1 px3 py1 py3 px2 px4 py2 py4))
		   (setq px3 (fix (- x1 dx)) py3 (fix (+ y1 dy))
			 px4 (fix (+ x1 dx)) py4 (fix (- y1 dy)))
		   (sys:%draw-triangle
		     (+ (tv:sheet-inside-left tv:sheet) px1)
		     (+ (tv:sheet-inside-top tv:sheet) py1)
		     (+ (tv:sheet-inside-left tv:sheet) px2)
		     (+ (tv:sheet-inside-top tv:sheet) py2)
		     (+ (tv:sheet-inside-left tv:sheet) px4)
		     (+ (tv:sheet-inside-top tv:sheet) py4)
		     alu tv:sheet)
		   (sys:%draw-triangle
		     (+ (tv:sheet-inside-left tv:sheet) px1)
		     (+ (tv:sheet-inside-top tv:sheet) py1)
		     (+ (tv:sheet-inside-left tv:sheet) px3)
		     (+ (tv:sheet-inside-top tv:sheet) py3)
		     (+ (tv:sheet-inside-left tv:sheet) px4)
		     (+ (tv:sheet-inside-top tv:sheet) py4)
		     alu tv:sheet)))))))


;;;  This is a bit of a kludge, but we wanted to do the translation
;;; here, to avoid consing elsewhere.
(defmethod (wide-curve-blinker :set-points)
	   (graph-window x-and-y-values)
  (send self ':set-visibility nil)
  (fillarray x-array nil)
  (fillarray y-array nil)
  (setf (fill-pointer x-array) 0)
  (setf (fill-pointer y-array) 0)
  (loop for (x y . rest) on x-and-y-values by 'cddr
	do (array-push-extend x-array (send graph-window ':translate-x x))
	do (array-push-extend y-array (send graph-window ':translate-y y))))


(defmethod (wide-curve-blinker :size)
	   ()
  (loop for x being the array-elements of x-array
	for y being the array-elements of y-array
	maximize x into maxx
	maximize y into maxy
	minimize x into minx
	minimize y into miny
	finally (values (- maxx minx) (- maxy miny))))