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

;;; Tektronix graphics.

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

(graphs-module grapht)

;; For info on Tek graphic protocol see .INFO.;TEK INFO
;; This code was nabbed from JGA.

(DEFVAR TEK-PRINTMODE #o37)
(DEFVAR TEK-GRAPHMODE #o35)

;; TEK Primitives

(defun tek-stream NARGS
  (COMMENT (ARG 1) = TEK-STREAM
	   (ARG 2) = COMMAND
	   (ARG 3) = X1
	   (ARG 4) = Y1
	   (ARG 5) = X2
	   (ARG 6) = Y2)
  (LET ((TEK-STREAM (ARG 1)))
    (LET ((VIEWPORT (TEK-STREAM-VIEWPORT))
	  (GRAPHIC-OUTPUT (TEK-STREAM-GRAPHIC-OUTPUT)))
      (caseq (ARG 2)
	((SET-PEN)
	 (NARG-CHECK NARGS 4 'TEK-STREAM)
	 (TEK-SET-PEN (ARG 3) (ARG 4)))
	((MOVE-PEN)
	 (NARG-CHECK NARGS 4 'TEK-STREAM)
	 (TEK-MOVE-PEN (ARG 3) (ARG 4)))
	(VECTOR-PEN
	 (NARG-CHECK NARGS 4 'TEK-STREAM)
	 (TEK-VECTOR-PEN (ARG 3) (ARG 4)))
	(DRAW-POINT
	 (NARG-CHECK NARGS 4 'TEK-STREAM)
	 (TEK-SET-PEN (ARG 3) (ARG 4))
	 (TEK-VECTOR-PEN 0 0))
	(DRAW-LINE
	 (NARG-CHECK NARGS 6 'TEK-STREAM)
	 (TEK-SET-PEN (ARG 3) (ARG 4))
	 (TEK-MOVE-PEN (ARG 5) (ARG 6)))
	((print-text)
	 (NARG-CHECK NARGS 3 'TEK-STREAM)
	 (tek-print-text (ARG 3)))
	((tyo)
	 (NARG-CHECK NARGS 3 'TEK-STREAM)
	 (tek-tyo (ARG 3)))
	((boundaries)
	 (list (tek-x-min)
	       (tek-x-max)
	       (tek-y-min)
	       (tek-y-max)))
	((which-operations)
	 (NARG-CHECK NARGS 2 'TEK-STREAM)
	 '(SET-PEN MOVE-PEN VECTOR-PEN
		   DRAW-POINT DRAW-LINE TYO
		   print-text))
	(t
	 (UNKNOWN-COMMAND (ARG 2) 'TEK-STREAM))))))

;; These are the basic graphic operations in fixnum (viewport) coordinates.  
;; No attempt is made to clip lines for the viewport here, nor check for
;; out-of-range arguments which will fold over mod #o2000.

(defun tek-tyo (c)
  (unless (= (tek-graphic-mode) TEK-PRINTMODE)
	  (+tyo TEK-PRINTMODE graphic-output)
	  (setf (tek-graphic-mode) TEK-PRINTMODE))
  (tyo c graphic-output))
  
(defun tek-print-text (text)
  (unless (= (tek-graphic-mode) TEK-PRINTMODE)
	  (+tyo TEK-PRINTMODE graphic-output)
	  (setf (tek-graphic-mode) TEK-PRINTMODE))
  (princ text graphic-output))

;; tekout does the basic encoding of all coordinates into Tek format
;; Note that it does the storage of high-y, low-y, etc., but not x or y.

(DEFUN tekout (x y)
  (let ((high-y (lsh (logand y #o1740) -5))
	(low-y (logand y #o37))
	(high-x (lsh (logand x #o1740) -5))
	(low-x (logand x #o37))
	(old-high-y (tek-high-y))
	(old-low-y (tek-low-y))
	(old-high-x (tek-high-x)))
    (declare (fixnum high-y low-y high-x low-x
		     old-high-y old-low-y old-high-x))
    (unless (= high-y old-high-y)
	    (+tyo (+ high-y #o40) graphic-output)
	    (setf (tek-high-y) high-y))
    (unless (and (= low-y old-low-y) (= high-x old-high-x))
	    (+tyo (+ low-y #o140) graphic-output)
	    (setf (tek-low-y) low-y)
	    (unless (= high-x old-high-x)
		    (+tyo (+ high-x #o40) graphic-output)
		    (setf (tek-high-x) high-x)))
    (+tyo (+ low-x #o100) graphic-output)
    (setf (tek-low-x) low-x))
  nil)

(defun tek-set-pen (x y)
  (declare (fixnum x y)
	   (special viewport))
  (+tyo TEK-GRAPHMODE graphic-output)
  (setf (tek-graphic-mode) TEK-GRAPHMODE)
  (tekout x y)
  (setf (tek-x-pen) x)
  (setf (tek-y-pen) y)
  nil)

(defun tek-move-pen (x y)
  (declare (fixnum x y))
  (unless (= (tek-graphic-mode) TEK-GRAPHMODE)
	  (+tyo TEK-GRAPHMODE graphic-output)
	  (tekout (tek-x-pen)
		  (tek-y-pen))
	  (setf (tek-graphic-mode) TEK-GRAPHMODE))
  (tekout x y)
  (setf (tek-x-pen) x)
  (setf (tek-y-pen) y)
  nil)

(defun tek-vector-pen (dx dy)
  (declare (fixnum dx dy))
  (unless (= (tek-graphic-mode) TEK-GRAPHMODE)
	  (+tyo TEK-GRAPHMODE graphic-output)
	  (tekout (tek-x-pen)
		  (tek-y-pen))
	  (setf (tek-graphic-mode) TEK-GRAPHMODE))
  (let ((x (+ dx (tek-x-pen)))
	(y (+ dy (tek-y-pen))))
    (declare (fixnum x y))
    (tekout x y)
    (setf (tek-x-pen) x)
    (setf (tek-y-pen) y))
  nil)

(defun make-tek-stream (s)
  (make-tek-stream-1 graphic-output s))