;;;-*-LISP-*-
;;; A graphics utility package. - George Carrette.

;; Floating-point graphics window.

(eval-when (eval compile)
  (or (get 'graphm 'version)
      (load (list (car (namelist infile)) 'graphm))))

(graphs-module graph$)

;;; This is general code for dealing with floating point windows.
;;; It will handle scaling and clipping.
;;;      ________
;;; y1 - |      |
;;;      |      |
;;;      |      |
;;; y0 - --------
;;;      '      '
;;;      x0     x1

(defun graphics-stream NARGS
  (COMMENT (ARG 1) = GRAPHICS-STREAM
	   (ARG 2) = COMMAND
	   (ARG 3) = X1
	   (ARG 4) = Y1
	   (ARG 5) = X2
	   (ARG 6) = Y2)
  (LET ((GRAPHICS-STREAM (ARG 1)))
    (LET ((WINDOW (GRAPHICS-STREAM-WINDOW))
	  (VIEWPORT (GRAPHICS-STREAM-VIEWPORT))
	  (SCALING-COEF (GRAPHICS-STREAM-SCALING-COEF))
	  (WLAST-POS (GRAPHICS-STREAM-WLAST-POS))
	  (OUT-STREAM (GRAPHICS-STREAM-OUT-STREAM)))
      (caseq (ARG 2)
	((move-pen)
	 (NARG-CHECK NARGS 4 'GRAPHICS-STREAM)
	 (CALL GRAPHICS-STREAM
	       'draw-line
	       (wlast-pos-x wlast-pos)
	       (wlast-pos-y wlast-pos)
	       (ARG 3) (ARG 4)))
	((draw-point)
	 (NARG-CHECK NARGS 4 'GRAPHICS-STREAM)
	 (UNLESS (out-of-windowp (ARG 3) (ARG 4))
		 (CALL out-stream
		       'draw-point
		       (scale-x (ARG 3))
		       (scale-y (ARG 4))))
	 (update-wlast-pos (ARG 3) (ARG 4)))
	((draw-line)
	 (NARG-CHECK NARGS 6 'GRAPHICS-STREAM)
	 (draw-line-clip-X0 (ARG 3) (ARG 4) (ARG 5) (ARG 6))
	 (update-wlast-pos (ARG 5) (ARG 6)))
	((set-pen)
	 (NARG-CHECK NARGS 4 'GRAPHICS-STREAM)
	 (update-wlast-pos (ARG 3) (ARG 4)))
	((tyo)
	 (NARG-CHECK NARGS 3 'GRAPHICS-STREAM)
	 (graphics-stream-tyo out-stream (ARG 3)))
	((init-scaling)
	 (NARG-CHECK NARGS 2 'GRAPHICS-STREAM)
	 (graph$-set-scaling))
	((set-window)
	 (NARG-CHECK NARGS 6 'GRAPHICS-STREAM)
	 (setf (window-x0 window) (float (or (ARG 3) (window-x0 window))))
	 (setf (window-x1 window) (float (or (ARG 4) (window-x1 window))))
	 (setf (window-y0 window) (float (or (ARG 5) (window-y0 window))))
	 (setf (window-y1 window) (float (or (ARG 6) (window-y1 window))))
	 (CALL GRAPHICS-STREAM 'init-scaling))
	((window)
	 (NARG-CHECK NARGS 2 'GRAPHICS-STREAM)
	 (list (window-x0 window)
	       (window-x1 window)
	       (window-y0 window)
	       (window-y1 window)))
	((viewport)
	 (NARG-CHECK NARGS 2 'GRAPHICS-STREAM)
	 (list (viewport-x0 viewport)
	       (viewport-x1 viewport)
	       (viewport-y0 viewport)
	       (viewport-y1 viewport)))
	((set-viewport)
	 (NARG-CHECK NARGS 6 'GRAPHICS-STREAM)
	 (setf (viewport-x0 viewport) (ifix (or (ARG 3) (viewport-x0 viewport))))
	 (setf (viewport-x1 viewport) (ifix (or (ARG 4) (viewport-x1 viewport))))
	 (setf (viewport-y0 viewport) (ifix (or (ARG 5) (viewport-y0 viewport))))
	 (setf (viewport-y1 viewport) (ifix (or (ARG 6) (viewport-y1 viewport)))))
	((which-operations)
	 (NARG-CHECK NARGS 2 'GRAPHICS-STREAM)
	 '(tyo set-pen move-pen init-scaling window
	       viewport set-window set-viewport set-clippingp break))
	((break)
	 (*break t "graphics"))
	(t
	 (UNKNOWN-COMMAND (ARG 2) 'GRAPHICS-STREAM))))))

(defun out-of-windowp (x y)
  (or (< x (window-x0 window))
      (> y (window-x1 window))
      (< x (window-y0 window))
      (> y (window-y1 window))))

(defun update-wlast-pos (x y)
  (setf (wlast-pos-x wlast-pos) x)
  (setf (wlast-pos-y wlast-pos) y)
  nil)

(declare (flonum (y-intercept flonum flonum flonum flonum flonum)))

;;;  Y - YB   YB - YA          (XA - X) YB + (X - XB) YA
;;;  ------ = -------   [Y = - -------------------------]
;;;  X - XB   XB - XA 			XB - XA


(defun y-intercept (XA YA XB YB X)
  (//$ (+$ (*$ (-$ XA X) YB)
	   (*$ (-$ X XB) YA))
       (-$ XA XB)))


(DEFUN DRAW-LINE-CLIP-X0 (XA YA XB YB &AUX (V (WINDOW-X0 WINDOW)))
  (COND ((< XA V)
	 (COND ((< XB V))
	       (T
		(DRAW-LINE-CLIP-X1 V (Y-INTERCEPT XA YA XB YB V) XB YB))))
	((< XB V)
	 (DRAW-LINE-CLIP-X1 XA YA V (Y-INTERCEPT XA YA XB YB V)))
	(T
	 (DRAW-LINE-CLIP-X1 XA YA XB YB))))

(DEFUN DRAW-LINE-CLIP-X1 (XA YA XB YB &AUX (V (WINDOW-X1 WINDOW)))
  (COND ((> XA V)
	 (COND ((> XB V))
	       (T
		(DRAW-LINE-CLIP-Y0 V (Y-INTERCEPT XA YA XB YB V) xb yb))))
	((> XB V)
	 (DRAW-LINE-CLIP-Y0 XA YA V (Y-INTERCEPT XA YA XB YB V)))
	(T
	 (DRAW-LINE-CLIP-Y0 XA YA XB YB))))

(DEFUN DRAW-LINE-CLIP-Y0 (XA YA XB YB &AUX (V (WINDOW-Y0 WINDOW)))
  (COND ((< YA V)
	 (COND ((< YB V))
	       (T
		(DRAW-LINE-CLIP-Y1 (X-INTERCEPT XA YA XB YB V) V XB YB))))
	((< YB V)
	 (DRAW-LINE-CLIP-Y1 XA YA (X-INTERCEPT XA YA XB YB V) V))
	(T
	 (DRAW-LINE-CLIP-Y1 XA YA XB YB))))

(DEFUN DRAW-LINE-CLIP-Y1 (XA YA XB YB &AUX (V (WINDOW-Y1 WINDOW)))
  (COND ((> YA V)
	 (COND ((> YB V))
	       (T
		(DRAW-LINE-GO (X-INTERCEPT XA YA XB YB V) V XB YB))))
	((> YB V)
	 (DRAW-LINE-GO XA YA (X-INTERCEPT XA YA XB YB V) V))
	(T
	 (DRAW-LINE-GO XA YA XB YB))))

(DEFUN DRAW-LINE-GO (XA YA XB YB)
  (CALL OUT-STREAM 'DRAW-LINE (SCALE-X XA)(SCALE-Y YA)
	 (SCALE-X XB)(SCALE-Y YB)))

(defun make-graphics-stream (out-stream)
  (let ((u (make-graphics-stream-1 out-stream out-stream)))
    (lexpr-funcall #'set-viewport u (call out-stream 'boundaries))
    u))

;;; V = K * W + M  K=(v1-v0) / (w1-w0)
;;;                M= v0 - K * w0
;;; the question is when to do the IFIX. For the convenience of having
;;; all the coeff flonum I will do it at then end.

(defun graph$-set-scaling ()
  (setf (scaling-coef-k-x scaling-coef)
	(//$ (float (- (viewport-x1 viewport) (viewport-x0 viewport)))
	     (-$ (window-x1 window) (window-x0 window))))
  (setf (scaling-coef-m-x scaling-coef)
	(-$ (float (viewport-x0 viewport))
	    (*$ (scaling-coef-k-x scaling-coef) (window-x0 window))))
  (setf (scaling-coef-k-y scaling-coef)
	(//$ (float (- (viewport-y1 viewport) (viewport-y0 viewport)))
	     (-$ (window-y1 window) (window-y0 window))))
  (setf (scaling-coef-m-y scaling-coef)
	(-$ (float (viewport-y0 viewport))
	    (*$ (scaling-coef-k-y scaling-coef) (window-y0 window))))
  t)