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

;;; ARDS codes.

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

(graphs-module grapha)

;;; local declarations to eliminate fixnum consing. 

(declare (fixnum (ards-basic-1 fixnum)
		 (ards-basic-2 fixnum))
	 (*expr (ards-mode-check-out nil fixnum)
		(ards-basic-io fixnum fixnum fixnum fixnum)
		(ards-basic-io-s fixnum fixnum)
		(ards-set-point-out fixnum fixnum)
		(ards-long-vector-out fixnum fixnum)
		(ards-short-vector-out fixnum fixnum)
		(ards-gen-vector fixnum fixnum)))

(defun ards-stream NARGS
  (COMMENT (ARG 1) = ARDS-STREAM
	   (ARG 2) = COMMAND
	   (ARG 3) = X1
	   (ARG 4) = Y1
	   (ARG 5) = X2
	   (ARG 6) = Y2)
  (LET ((ARDS-STREAM (ARG 1)))
    (LET ((OUT-STREAM (ARDS-STREAM-OUT-STREAM))
	  (GRAPHIC-MODE (ARDS-STREAM-GRAPHIC-MODE))
	  (INVISIBLEP (ARDS-STREAM-INVISIBLEP))
	  (DOTTEDP (ARDS-STREAM-DOTTEDP))
	  (LAST-POS (ARDS-STREAM-LAST-POS)))
      (caseq (ARG 2)
	((move-pen)
	 (NARG-CHECK NARGS 4 'ARDS-STREAM)
	 (ards-gen-vector (- (ARG 3) (ards-last-pos-x last-pos))
			  (- (ARG 4) (ards-last-pos-y last-pos)))
	 (setf (ards-last-pos-x last-pos) (ARG 3))
	 (setf (ards-last-pos-y last-pos) (ARG 4))
	 t)
	((vector-pen)
	 (NARG-CHECK NARGS 4 'ARDS-STREAM)
	 (ards-gen-vector (ARG 3) (ARG 4))
	 (setf (ards-last-pos-x last-pos)
	       (+ (ards-last-pos-x last-pos) (ARG 3)))
	 (setf (ards-last-pos-y last-pos)
	       (+ (ards-last-pos-y last-pos) (ARG 4)))
	 t)
	((draw-point)
	 (NARG-CHECK NARGS 4 'ARDS-STREAM)
	 (CALL ards-stream 'set-pen (ARG 3) (ARG 4))
	 (CALL ards-stream 'vector-pen 0 0))
	((draw-line)
	 (NARG-CHECK NARGS 6 'ARDS-STREAM)
	 (CALL ards-stream 'set-pen (ARG 3) (ARG 4))
	 (CALL ards-stream 'move-pen (ARG 5) (ARG 6)))
	((set-pen)
	 (NARG-CHECK NARGS 4 'ARDS-STREAM)
	 (cond ((and (= (ARG 3) (ards-last-pos-x last-pos))
		     (= (ARG 4) (ards-last-pos-y last-pos))))
	       (t
		(ards-mode-check-out 'set-point #/)
		(ards-set-point-out (ARG 3) (ARG 4))
		(setf (ards-last-pos-x last-pos) (ARG 3))
		(setf (ards-last-pos-y last-pos) (ARG 4))
		t)))
	((tyo)
	 (NARG-CHECK NARGS 3 'ARDS-STREAM)
	 (ards-gen-tyo (ARG 3)))
	((SET-DOTTEDP)
	 (NARG-CHECK NARGS 3 'ARDS-STREAM)
	 (setf (ards-stream-dottedp) (ARG 3)))
	((set-invisiblep)
	 (NARG-CHECK NARGS 3 'ARDS-STREAM)
	 (setf (ards-stream-invisiblep) (ARG 3)))
	((boundaries)
	 (list (ards-stream-x-min)
	       (ards-stream-x-max)
	       (ards-stream-y-min)
	       (ards-stream-y-max)))
	((which-operations)
	 (NARG-CHECK NARGS 2 'ARDS-STREAM)
	 '(tyo set-pen move-pen vector-pen draw-point
	       set-dottedp set-invisiblep size))
	(t
	 (UNKNOWN-COMMAND (ARG 2) 'ARDS-STREAM))))))

(defun make-ards-stream (s)
  (make-ards-stream-1 out-stream s))

(defun ards-mode-check-out (mode signal)
  (when (not (eq graphic-mode mode))
	(setq graphic-mode mode)
	(setf (ards-stream-graphic-mode) mode)
	(+tyo (+ signal #o200) OUT-STREAM)))

(defun ards-basic-1 (x)
  (+ (lsh (logand (abs x) #o37) 1) 
     (if (minusp x) 1 0)
     #o100))

(defun ards-basic-2 (x)
  (+ (logand (lsh (abs x) #o-5) #o37) #o100))

(defun ards-basic-io (x1 x2 y1 y2)
  (+tyo x1 OUT-STREAM)
  (+tyo x2 OUT-STREAM)
  (+tyo y1 OUT-STREAM)
  (+tyo y2 OUT-STREAM))

(defun ards-basic-io-s (x1 y1)
  (+tyo x1 OUT-STREAM)
  (+tyo y1 OUT-STREAM))


(defun ards-set-point-out (x y)
  (ards-basic-io (ards-basic-1 x)
		 (ards-basic-2 x)
		 (ards-basic-1 y)
		 (ards-basic-2 y)))
		     

(defun ards-long-vector-out (x y)
  (ards-basic-io (ards-basic-1 x)
		 (+ (ards-basic-2 x) (if invisiblep #o40 0))
		 (ards-basic-1 y)
		 (+ (ards-basic-2 y) (if dottedp #o40 0))))

(defun ards-short-vector-out (x y)
  (ards-basic-io-s (ards-basic-1 x)
		   (ards-basic-1 y)))

(defun ards-gen-vector (x y)
  (declare (fixnum x y))
  (cond ((and (< (abs x) #o40) (< (abs y) #o40) (not invisiblep) (not dottedp))
	 (ards-mode-check-out 'short-vector #/)
	 (ards-short-vector-out x y))
	(t
	 (ards-mode-check-out 'long-vector #/)
	 (ards-long-vector-out x y))))

(defun ards-gen-tyo (C)
  (ards-mode-check-out nil #/)
  (tyo C OUT-STREAM))