;;;-*-Lisp-*-

; (c) Copyright 1976, 1983 Massachusetts Institute of Technology. 
; All Rights Reserved. Enhancements (c) Copyright 1983 Symbolics Inc.
; All Rights Reserved. 
; 
;  The data and information in the Enhancements is proprietary to, and a
; valuable trade secret of, SYMBOLICS, INC., a Delaware corporation. It is
; given in confidence by SYMBOLICS, and may not be used as the basis of
; manufacture, or be reproduced or copied, or distributed to any other
; party, in whole or in part, without the prior written consent of SYMBOLICS.


(declare (special char-height char-width print-line1 linel $plotheight
		  print-x print-y tty-graphics)
	 (fixnum x y x1 y1 ix iy ix1 iy1 i j k width print-x print-y sign char-height
		 char-width print-line1 linel $plotheight (prin-tyo fixnum)
		 (prin-tyo fixnum) (tyob0 fixnum))
	 (notype (print-line1 fixnum fixnum fixnum fixnum)
		 (print-char fixnum fixnum fixnum)
		 (putchar fixnum fixnum fixnum)
		 (print-point fixnum fixnum)))

;(setq char-height 22. char-width 12.)

(defun print-line1 (x y x1 y1)
 ((lambda (horiz sign)
   (cond ((and (= x x1) (= y y1)) (print-point x y))
	 (horiz
	  (and (> x x1) (setq sign -1.))
	  (do ((ix (// x char-width) (+ sign ix)) (ix1 (// x1 char-width)))
	      ((> (* sign ix) (* sign ix1)))
	      (putchar ix
		       (// (+ y (// (* (- y1 y)
				       (- (+ (* ix char-width) (// char-width 2.)) x))
				    (- x1 x)))
			   char-height)
		       print-line1)))
	 (t
	  (and (> y y1) (setq sign -1.))
	  (do ((iy (// y char-height) (+ sign iy)) (iy1 (// y1 char-height)))
	      ((> (* sign iy) (* sign iy1)))
	      (putchar (// (+ x (// (* (- x1 x)
				       (- (+ (* iy char-height) (// char-height 2.)) y))
				    (- y1 y)))
			   char-width)
		       iy print-line1)))))
  (> (* char-height (abs (- x1 x))) (* char-width (abs (- y1 y)))) 1.))

(defun print-point (x y) (print-char x y print-line1))

(defun print-char (x y i) (putchar (// x char-width) (// y char-height) i))

(defun putchar (x y i)
       (setq y (1- (- $plotheight y)))
       (or (< x 0.) (not (< x linel)) (< y 0) (not (< y $plotheight))
	   (< i 32.) (not (< i 127.))
	   (cond ((eq tty-graphics 'disp)
		  (cond ((not (and (= y print-y) (= x print-x)))
			 (prin-tyo 143.)
			 (prin-tyo y)
			 (prin-tyo x)
			 (setq print-y y)))
		  (prin-tyo i) (setq print-x (1+ x)))
		 ((eq tty-graphics 'print)
		  (store (screen-array y x) i))))
       nil)

(defun screen-output nil
       (do ((flg) (k 0.) (i 0 (1+ i)) (width)) ((not (< i $plotheight)))
	   (do ((j (1- linel) (1- j)))
	       ((or (< j 0.) (not (= (screen-array i j) 32.)))
		(setq width j)))
	   (cond ((and (< width 0.) flg) (setq k (1+ k)))
		 ((not (< width 0.))
		  (do ((j 0. (1+ j))) ((= j k)) (mterpri))
		  (setq flg t k 0.)
		  (do ((j 0. (1+ j))) ((> j width))
		      (tyo (screen-array i j)))
		  (mterpri)))))

#-franz (putprop 'prin-tyo (get 'tyob0 'subr) 'subr)
#+franz (putd 'prin-tyo (getd 'tyob0))