;;; -*- Mode: Lisp;  Package: Graph;  Syntax: ZetaLisp;  Base: 10. -*-

;;;  ****************
;;;  Actually Drawing and erasing things.
;;;  ****************

;;;  You specify the two corners of the rectangle.  We do the rest.
;;; This method takes care of translation, etc.
	    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod (graph-display-mixin :draw-graph-rectangle)
	    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	   (x1 y1 width height)
  (let ((tx1 (send self ':translate-x x1))
	(ty1 (send self ':translate-y y1))
	(wid (// width zoomx))
	(hei (// height zoomy)))
    (send self ':draw-lines tv:alu-ior
	  tx1 ty1
	  (+ tx1 wid -1) ty1
	  (+ tx1 wid -1) (+ ty1 hei -1)
	  tx1 (+ ty1 hei -1)
	  tx1 ty1)))

;;; Draw a parallelogram. Specify the center, the width, the height and the slant.

(defmethod (graph-display-mixin :draw-graph-parallelogram)
	   (x-center y-center width height slant)
  (setq x-center (send self ':translate-x x-center)
	y-center (send self ':translate-y y-center)
	width (// width zoomx)
	height (// height zoomy))
  (let* ((offset (fixr (// (* height (cos slant) zoomy) (* (sin slant) zoomx))))
	 (width2 (// width 2.))
	 (height2 (// height 2.))
	 (upper (- y-center height2))
	 (lower (+ y-center height2))
	 (xleft (- x-center width2))
	 (xmidleft (+ xleft offset))
	 (xright (+ x-center width2))
	 (xmidright (- xright offset)))
    (send self ':draw-lines tv:alu-ior
	  xmidleft upper
	  xright upper
	  xmidright lower
	  xleft lower
	  xmidleft upper)))

;;; Erase a parallelogram. We are passed the center and size and slant of the 
;;; parallelogram (slant is ignored for now).
(defmethod (graph-display-mixin :erase-graph-parallelogram)
	   (x-center y-center width height ignore)
  (setq x-center (send self ':translate-x x-center)
	y-center (send self ':translate-y y-center)
	width (// width zoomx)
	height (// height zoomy))
  (send self ':draw-rectangle
	(1+ width)
	(1+ height)
	(- x-center (// width 2.))
	(- y-center (// height 2.))
	tv:alu-andca))

;;; Draw an ellipse. We first translate the world coordinates to screen coordiates.
;;; Then we check the special (and simplier) case that the ellipse is really a circle.
(defmethod (graph-display-mixin :draw-graph-ellipse)
	   (x y x-radius y-radius)
  (let ((x (send self ':translate-x x))
	(y (send self ':translate-y y))
	(x-radius (// x-radius zoomx))
	(y-radius (// y-radius zoomy)))
    (if (equal x-radius y-radius)
	(send self ':draw-circle x y x-radius tv:alu-ior)
	(send self ':draw-ellipse x y x-radius y-radius tv:alu-ior))))

;;; Erase an ellipse. First translate to screen coordiantes. Then just blank out the
;;; bounding box for the ellipse.
(defmethod (graph-display-mixin :erase-graph-ellipse)
	   (x y x-radius y-radius)
  (let ((x (send self ':translate-x x))
	(y (send self ':translate-y y))
	(x-radius (1+ (// x-radius zoomx)))
	(y-radius (1+ (// y-radius zoomy))))
    (send self ':draw-rectangle (+ x-radius x-radius) (+ y-radius y-radius)
	  (- x x-radius) (- y y-radius) tv:alu-andca)))

(defmethod (graph-display-mixin :draw-graph-line)
	    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	   (x1 y1 x2 y2)
  (send self ':draw-line
	(send self ':translate-x x1) (send self ':translate-y y1)
	(send self ':translate-x x2) (send self ':translate-y y2)
	tv:alu-ior))

(defmethod (graph-display-mixin :draw-graph-sausage)
	   (x y min-radius max-radius)
  (setq x (send self ':translate-x x)
	y (send self ':translate-y y)
	min-radius (// min-radius zoomy)
	max-radius (// max-radius zoomx))
  (let ((left-center-x (- x max-radius (- min-radius)))
	(right-center-x (+ x max-radius (- min-radius)))
	(upper-y (- y min-radius))
	(lower-y (+ y min-radius))
	(pi2 (// *pi* 2)))
    (send self ':draw-circular-arc left-center-x y min-radius pi2
	  (- pi2) tv:alu-ior)
    (send self ':draw-circular-arc right-center-x y min-radius (- pi2)
	  pi2 tv:alu-ior)
    (send self ':draw-line left-center-x upper-y right-center-x upper-y tv:alu-ior)
    (send self ':draw-line left-center-x lower-y right-center-x lower-y tv:alu-ior)))



       	    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod (graph-display-mixin :erase-graph-line)
	    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	   (x1 y1 x2 y2)
  (send self ':draw-line
	(send self ':translate-x x1) (send self ':translate-y y1)
	(send self ':translate-x x2) (send self ':translate-y y2)
	tv:alu-andca))

(defmethod (graph-display-mixin :draw-graph-lines)
	   (&rest x-y-points)
  (lexpr-funcall self ':draw-lines tv:alu-ior
		 (loop for (x y . rest) on x-y-points by 'cddr
		       collect (send self ':translate-x x)
		       collect (send self ':translate-y y))))

(defmethod (graph-display-mixin :erase-graph-lines)
	   (&rest x-y-points)
  (lexpr-funcall self ':draw-lines tv:alu-andca
		 (loop for (x y . rest) on x-y-points by 'cddr
		       collect (send self ':translate-x x)
		       collect (send self ':translate-y y))))

(defmethod (graph-display-mixin :draw-dotted-graph-lines)
	   (draw-p &rest x-y-points)
  (loop for (x1 y1 x2 y2 . rest) on x-y-points by 'cddr
	until (null x2)
	do (send self ':draw-dashed-line
		 (clip (send self ':translate-x x1) 0 tv:width)
		 (clip (send self ':translate-y y1) 0 tv:height)
		 (clip (send self ':translate-x x2) 0 tv:width)
		 (clip (send self ':translate-y y2) 0 tv:height)
		 (if draw-p tv:alu-ior tv:alu-andca) 4 nil 0 2)))

(defmethod (graph-display-mixin :draw-dashed-graph-lines)
	   (draw-p &rest x-y-points)
  (loop for (x1 y1 x2 y2 . rest) on x-y-points by 'cddr
	until (null x2)
	do (send self ':draw-dashed-line
		 (clip (send self ':translate-x x1) 0 tv:width)
		 (clip (send self ':translate-y y1) 0 tv:height)
		 (clip (send self ':translate-x x2) 0 tv:width)
		 (clip (send self ':translate-y y2) 0 tv:height)
		 (if draw-p tv:alu-ior tv:alu-andca) 18. nil 0 12.)))

;;; Latest, greatest feature.  Now you can draw splines!!
(defmethod (graph-display-mixin :draw-spline-graph-line)
	   (draw-p width &rest x-y-points)
  ;; Reset the temporary arrays
  (setf (fill-pointer *spline-x-array*) 0)
  (setf (fill-pointer *spline-y-array*) 0)
  ;; Fill the arrays
  (loop for (x1 y1 . rest) on x-y-points by 'cddr
	until (null x1)
	do (array-push-extend *spline-x-array*
			      (send self ':translate-x x1))
	do (array-push-extend *spline-y-array*
			      (send self ':translate-y y1)))
    (send self ':draw-cubic-spline
	  *spline-x-array* *spline-y-array*
	  10. width (if draw-p tv:alu-ior tv:alu-andca)))


;;;  You specify the top-left corner of the box, and its width and
;;; height.
	    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod (graph-display-mixin :draw-white-box)
	    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	   (x y width height)
  (send self ':draw-rectangle
	(1+ (// width zoomx)) (1+ (// height zoomy))
	(send self ':translate-x x) (send self ':translate-y y)
	tv:alu-andca))


;;;  Draws a string on a given Y level, centered between the two X coordinates.
;;; Under no circumstances will the string be printed outside the x boundaries.
;;; If necessary, the font will be changed, or the string will be truncated
;;; to insure this.  Fortunately, the Lisp Machine provides a primitive for
;;; this operation.  Here, we need only translate the coordinates.
;;;
;;;  The constants here are only used in this method.  Probably no need to 
;;; hide these elsewhere.  Don't fool with them.  Susan and John spent almost
;;; an hour trying to find the correct values.  The constants prevent text from
;;; wrapping around screen boundaries, appearing on the other side.
	    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod (graph-display-mixin :draw-centered-graph-string)
	   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	   (string left-x right-x y)
  (setq left-x (send self ':translate-x left-x)
	right-x (send self ':translate-x right-x)
	y (send self ':translate-y y))
  (when (<= 0 y (- tv:height (+ 20. (font-char-height tv:current-font))))
    (send self ':display-centered-string string
	  (min (max 0 left-x) (- tv:width 10.))
	  (min (max 0 right-x) (- tv:width 10.))
	  y)))


(defmethod (graph-display-mixin :draw-underlined-graph-string)
	   (string horizontal-p x1 y1 length &optional (leftp nil))
  (setq x1 (send self ':translate-x x1)
	y1 (send self ':translate-y y1)
	length (// length zoomx))
  (if leftp (setq x1 (- x1 length 10.)))
  (when ( 0 (- y1 (tv:font-baseline tv:current-font) 1.)
	   (- tv:height (+ 20. (font-char-height tv:current-font))))
    (send self ':string-out-explicit
	  string
	  (clip (+ x1 5.) 0 (- tv:width 10.))
	  (- y1 (tv:font-baseline tv:current-font) 1.)
	  (clip (+ x1 length 5.) 0 (- tv:width 10.))
	  #+LMI (+ y1 10)
	  tv:current-font tv:alu-ior)
    (unless horizontal-p
      (send self ':draw-dashed-line
	    (clip x1 0 tv:width)
	    y1
	    (clip (+ x1 length 5.) 0 tv:width)
	    y1 
	    tv:alu-ior 4.))))

(defmethod (graph-display-mixin :erase-underlined-graph-string)
	   (string horizontal-p x1 y1 length &optional (leftp nil))
  (setq x1 (send self ':translate-x x1)
	y1 (send self ':translate-y y1)
	length (// length zoomx))
  (if leftp (setq x1 (- x1 length 10.)))
  (when ( 0 (- y1 (tv:font-baseline tv:current-font) 1.)
	   (- tv:height (+ 20. (font-char-height tv:current-font))))
    (send self ':string-out-explicit
	  string
	  (clip (+ x1 5.) 0 (- tv:width 10.))
	  (- y1 (tv:font-baseline tv:current-font) 1.)
	  (clip (+ x1 length 5.) 0 (- tv:width 10.))
	  #+LMI (+ y1 10)
	  tv:current-font tv:alu-andca)
    (unless horizontal-p
      (send self ':draw-dashed-line
	    (clip x1 0 tv:width)
	    y1
	    (clip (+ x1 length 5.) 0 tv:width)
	    y1 
	    tv:alu-andca 4.))))
 
(defun clip (number min max)
  (min (max number min) max))
  
;;;draw a closed in triangle given the three endpoints
(defmethod (graph-display-mixin :draw-graph-triangle)
	   (x1 y1 x2 y2 x3 y3)
  (setq x1 (send self ':translate-x x1)
	y1 (send self ':translate-y y1)
	x2 (send self ':translate-x x2)
	y2 (send self ':translate-y y2)
	x3 (send self ':translate-x x3)
	y3 (send self ':translate-y y3))
  (send self ':draw-triangle x1 y1 x2 y2 x3 y3 tv:alu-ior))

;;erase a graph triangle.  Assume point 1 is left of point 2.
(defmethod (graph-display-mixin :erase-graph-triangle)
	   (x1 y1 x2 y2 x3 y3)
  (setq x1 (send self ':translate-x x1)
	y1 (send self ':translate-y y1)
	x2 (send self ':translate-x x2)
	y2 (send self ':translate-y y2)
	x3 (send self ':translate-x x3)
	y3 (send self ':translate-y y3))
  (send self ':draw-triangle x1 y1 x2 y2 x3 y3 tv:alu-andca))

;;;  ****************
;;;  Primitives to help drawing.
;;;  ****************

;;; Takes an x in the graphics world, and translates into screen coordinates.
	    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod (graph-display-mixin :translate-x)
	    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	   (x)
  (fix (// (- x screen-x) zoomx)))

	    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod (graph-display-mixin :translate-y)
	    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	   (y)
  (fix (// (- y screen-y) zoomy)))


(defmethod (graph-display-mixin :untranslate-x)
	   (x)
  (+ (* x zoomx) screen-x))

(defmethod (graph-display-mixin :untranslate-y)
	   (y)
  (+ (* y zoomy) screen-y))