;;;-*- Mode:LISP; Package:TIGER; Base:8; Fonts:(CPTFONT TR12I); Readtable:T -*-

; Copyright LISP Machine, Inc. 1984
;   See filename "Copyright" for
; licensing and release information.

;1;; Printer stuff for the Toshiba P1350 dot matrix printer (with serial interface)*
(def-tiger-props :toshiba
		 tiger-stream-flavor toshiba-stream
		 default-x-scale 2
		 default-y-scale 2
		 bullethole-p t
		 tiger-font-type toshiba-font
		 tiger-options ((:font "Font" :assoc (("Default" . nil)
						      (0 . 0)
						      (1 . 1)
						      (2 . 2)
						      ("25FG" . 25fg)
						      ("25FGB" . 25fgb)
						      ("25FGI" . 25fgi)
						      ("25VG" . 25vg)
						      ("25VGI" . 25vgi)
						      ("25VGB" . 25vgb)
						      ("25VR" . 25vr)
						      ("25VRB" . 25vrb)
						      ("25VRI" . 25vri)
						      ("25VMIC" . 25vmic)))
				(:font-list "Font list" :sexp)
				(:characters-per-inch "Characters per inch" :number-or-nil)
				(:lines-per-inch "Lines per inch" :number))
		 options-and-defaults ((:font nil)
				       (:font-list nil)
				       (:characters-per-inch 10.)
				       (:lines-per-inch 6.))
		 font-directory "SYS:TIGER;TOSHIBA-FONTS;")

(defvar maximum-horizontal-move 1788.)		;1What a crock!*

(defvar toshiba-default-font '25fr3) 	;1Font to use for simulation of Lisp Machine chars*

(defvar toshiba-simulation-table (make-array 256.)
  "The table to use to decide how to simulate Lisp Machine characters on the Toshiba printer.
This printer handles whitespace (space, tab, return, etc.) specially because of the
interaction between graphics and non-graphics printing.")

(stuff-array toshiba-simulation-table
  (:graphics-maybe (0 400))
  (t (#\Center-Dot #\Space))
  (t #\Integral)
  (:space #\Space)
  (:discard (#\Null 400))
  (:tab #\Tab)
  ((ascii-code #\line) #\Line)
  ((ascii-code #\form) #\Form)
  (:new-line #\Return))

(defflavor toshiba-stream
	   ((temporary-bit-graphics-array
	      (make-array #.(* 4 2448.) :type 'art-string :fill-pointer 0))
	    (temporary-bit-graphics-array-2
	      (make-array #.(* 4 2448.) :type 'art-string :fill-pointer 0))
	    (horizontal-position 0)
	    (vertical-position 0)
	    (bullethole-p t)
	    (space-count 0)
	    (publication-mode nil)
	    (whitespace-threshold (select si:processor-type-code
				      (si:cadr-type-code 100000.)
				      (si:lambda-type-code 128.))))
	;1Turn off whitespace hack until serial streams fixed*
	   (basic-printer-stream-mixin)
  :gettable-instance-variables
  :settable-instance-variables
  (:default-init-plist :name :toshiba
		       :discard-font-changes t
		       :process-font-changes t
		       :character-simulation-table toshiba-simulation-table
		       :font 0
		       :dots-per-line 24.
		       :simulation-mode :simulate-with-graphics))

(defmethod (toshiba-stream :set-publication-mode) (publication-p)
  (if publication-p
      (setq x-scale 2 y-scale 2 publication-mode t bullethole-p t)
    (setq publication-mode nil)))

(defmethod (toshiba-stream :setup-normal) ()
  (escape-sequence (ascii-code :sub) (ascii-code #/i)))

(defmethod (toshiba-stream :set-characters-per-inch) (cpi)
  (setq characters-per-inch (or cpi 10.))
  (escape-sequence (ascii-code #/E))
  (long-number (round 120. characters-per-inch) destination)
  (send self :set-tab-stops))			;1Must be redone because tabs are absolute by position*
						;1rather than by column.*
; (escape-sequence (ascii-code :US) (short-number (round 120. cpi))))

(defmethod (toshiba-stream :set-lines-per-inch) (lpi)
  (setq lines-per-inch (or lpi 6))
  (escape-sequence (ascii-code #/L))
  (long-number (round 48. lines-per-inch) destination))
; (escape-sequence (ascii-code :RS) (short-number (round 48. lines-per-inch))))

(defmethod (toshiba-stream :set-elongated-printing) (&optional (elongated-p t))
  (setq elongated-characters elongated-p)
  (cond (elongated-p (escape-sequence (ascii-code #/!)))
	(t (escape-sequence (ascii-code #/")))))

(defmethod (toshiba-stream :set-tab-stops) (&optional (n-columns 8.))
  (setq tab-stops n-columns)
  (escape-sequence (ascii-code #/())
  (loop for first-time-p = t then nil
	for column from (1+ n-columns) below 160. by n-columns
	unless first-time-p
	  do (send destination :tyo (ascii-code #/,))
	do (long-number column destination)
	finally (send destination :tyo (ascii-code #/.))))

(defmethod (toshiba-stream :set-form-length) (&optional (inches 11.))
  (setq form-length inches)
  (let ((sixths (round (* inches 6))))
    (when (> sixths 127.)
      (ferror nil "Invalid Toshiba forms length ~D inches."))
    (escape-sequence (ascii-code #/F))
    (long-number sixths destination)))

(defmethod (toshiba-stream :set-font) (&optional font-spec (literal-p nil) (push-p t))
  push-p
  (unless font-spec (setq font-spec 0 literal-p nil))
  (let ((new-font (if literal-p
		      font-spec
		    (lookup-font font-spec font-list 'toshiba-font))))
    (cond ((eq font new-font) nil)		;1Don't bother emitting a change if we really didn't*
	  ((fixnump new-font)
	   (setq font (remainder new-font 3))
	   (escape-sequence (ascii-code #/*) (+ font (ascii-code #/0)))
	   (setq graphics-font-p nil)
	   (force-toshiba-graphics-output))
	  (t (setq font (load-font-if-necessary new-font :toshiba))
	     (setq graphics-font-p t)))
    (setq new-line-p nil)))

(defmethod (toshiba-stream :simulate-with-graphics) (char &optional
						     (fon (symeval toshiba-default-font))
						     (force-spaces t))
  (unless (typep fon 'toshiba-font) (setq fon (symeval toshiba-default-font)))
  (when force-spaces (force-toshiba-graphics-output t))
  (let ((string (aref fon char)))
    (cond (string (string-nconc temporary-bit-graphics-array string "        "))
	  (t (send destination :tyo char))))
  (setq new-line-p nil))

(defmethod (toshiba-stream :space) (&rest ignore)
  (incf space-count))

(defmethod (toshiba-stream :tab) (&rest ignore)
  (send self :set-font 0 t)
  (send destination :tyo (ascii-code #\tab))
  (send self :pop-font))

(defmethod (toshiba-stream :new-line) (&rest ignore)
  (force-toshiba-graphics-output nil t)
  (send destination :tyo (ascii-code #\return))
  (send destination :tyo (ascii-code #\line))
  (setq new-line-p t))

;1;; Bit array stuff.*

(defmethod (toshiba-stream :before :tyo) (ignore)
  (unless graphics-font-p (force-toshiba-graphics-output)))

(defmethod (toshiba-stream :set-up-for-graphics) (ignore)
  (send self :set-bullethole-p (get :toshiba 'bullethole-p))
  (escape-sequence (ascii-code #/L))
  (long-number 7 destination)
  (send self :set-characters-per-inch 12.)
  (setf (fill-pointer temporary-bit-graphics-array) 0)
  ;1; Hack to get around Toshiba bug.*
  (push-graphic-blanks 80.)
  (send self :new-graphics-line))

(defmethod (toshiba-stream :print-bit-graphics) (char)
  (incf horizontal-position)
  (array-push temporary-bit-graphics-array (%logldb #o2206 char))
  (array-push temporary-bit-graphics-array (%logldb #o1406 char))
  (array-push temporary-bit-graphics-array (%logldb #o0606 char))
  (array-push temporary-bit-graphics-array (%logldb #o0006 char)))

(defun force-toshiba-graphics-output (&optional spaces-only end-of-line)
  (declare (:self-flavor toshiba-stream))
  (let ((n-pixels (* space-count (round 180. characters-per-inch))))
    ;1; First, maybe we aren't simulating graphics at all, in which case we should just type the spaces*
    (cond ((and (not graphics-font-p) (zerop (string-length temporary-bit-graphics-array)))
	   (dotimes (foo space-count) (send destination :tyo #\Space))
	   (setq space-count 0))
	  (t 
	   ;1; Start by adding spaces to the bit-graphics array if appropriate*
	   ;1; Don't worry about publication mode here; this is only for mixed text-and-graphics.*
	   (unless (or end-of-line new-line-p (> n-pixels whitespace-threshold))
	     (dotimes (foo space-count)
	       (send self :simulate-with-graphics #\Space font nil))
	     (setq space-count 0))
	   ;1; Next dump the contents of the bit graphics array, unless we are only hacking spaces*
	   (unless (or spaces-only (zerop (fill-pointer temporary-bit-graphics-array)))
	     (actually-print-graphics)
	     (when publication-mode
	       (send destination :tyo (ascii-code #\return))
	       (actually-print-graphics t))
	     (setf (fill-pointer temporary-bit-graphics-array) 0))
	   ;1; Finally print out any space characters we have to, unless we are at the end of line*
	   (unless (or (zerop space-count) end-of-line)
	     (dotimes (foo space-count)
	       (send destination :tyo #\Space))
	     (setq space-count 0))))))

(defun actually-print-graphics (&optional (bullethole-phase nil))
  (declare (:self-flavor toshiba-stream))
  (let ((bullethole (if bullethole-phase #2R101010 #2R010101)))
    (escape-sequence #/;)
    (format destination "~4,VD" (ascii-code #/0)
	    (floor (string-length temporary-bit-graphics-array) 4))
    (cond (bullethole-p
	   (loop for i from 0 below (string-length temporary-bit-graphics-array) by 4
		 do (aset (logand (aref temporary-bit-graphics-array i) bullethole)
			  temporary-bit-graphics-array-2 i)
		    (aset (logand (aref temporary-bit-graphics-array (1+ i)) bullethole)
			  temporary-bit-graphics-array-2 (1+ i))
		    (aset (logand (aref temporary-bit-graphics-array (+ 2 i)) bullethole)
			  temporary-bit-graphics-array-2 (+ 2 i))
		    (aset (logand (aref temporary-bit-graphics-array (+ 3 i)) bullethole)
			  temporary-bit-graphics-array-2 (+ 3 i))
		    (setq bullethole (logxor bullethole #2R111111)))
	   (setf (fill-pointer temporary-bit-graphics-array-2)
		 (fill-pointer temporary-bit-graphics-array))
	   (send destination :string-out temporary-bit-graphics-array-2))
	  (t (send destination :string-out temporary-bit-graphics-array)))))

(defmethod (toshiba-stream :position-horizontal) (new-position)
  (let ((delta-x (- new-position horizontal-position)))
    (cond ((minusp delta-x)
	   (ferror nil "Unable to handle negative horizontal position command."))
	  ;1; Hack so that beginning-of-line whitespace is always optimized out.*
	  ((or publication-mode
	       (and (not (zerop horizontal-position)) (< delta-x whitespace-threshold)))
	   (push-graphic-blanks (* 4 delta-x)))
	  (t (multiple-value-bind (threes leftover)
		 (floor delta-x 3)
	       (unless (zerop threes)
		 (force-toshiba-graphics-output)
		 (perform-relative-horizontal-movement (* threes 4)))
	       (push-graphic-blanks (* 4 leftover))))))
  (setq horizontal-position new-position))

(defsubst perform-movement-1 (distance stream)
  (escape-sequence (ascii-code #/H))
  (very-long-number distance stream))

(defun perform-relative-horizontal-movement (amount)
  (declare (:self-flavor toshiba-stream))
  (multiple-value-bind (max-moves leftover)
      (floor amount maximum-horizontal-move)
    (dotimes (foo max-moves)
      (perform-movement-1 maximum-horizontal-move destination))
    (perform-movement-1 leftover destination)))

;(defmethod (toshiba-stream :position-horizontal) (new-position)
;  (let ((delta-x (- new-position horizontal-position)))
;    (when (minusp delta-x)
;      (ferror nil "unable to handle negative horizontal position command."))
;    (multiple-value-bind (new-column new-position)
;	(floor new-position 15.)
;      (multiple-value-bind (current-column current-position)
;	  (floor horizontal-position 15.)
;	(cond ((eq new-column current-column)
;	       (dotimes (foo (* delta-x 4))
;		 (array-push temporary-bit-graphics-array 0)))
;	      (t (force-toshiba-graphics-output)
;		 (multiple-value-bind (tens ones)
;		     (long-number (1+ new-column))
;		   (escape-sequence (ascii-code #/C) tens ones))
;		 (dotimes (foo (* new-position 4))
;		   (array-push temporary-bit-graphics-array 0)))))))
;  (setq horizontal-position new-position))

(defmethod (toshiba-stream :new-graphics-line) ()
  (force-toshiba-graphics-output)
  (send destination :tyo (ascii-code #\return))
  (send destination :tyo (ascii-code #\line))
  (setq horizontal-position 0))

(defun set-toshiba-scale (&optional (scale 2))
  (check-arg-type scale :fixnum)
  (selectq scale
    (1 
     (putprop :toshiba nil 'bullethole-p)
     (putprop :toshiba 1 'default-x-scale)
     (putprop :toshiba 1 'default-y-scale))
    (2
     (putprop :toshiba t 'bullethole-p)
     (putprop :toshiba 2 'default-x-scale)
     (putprop :toshiba 2 'default-y-scale))
    (:otherwise (ferror nil "Unsupported toshiba scale factor ~O specified." scale))))

(compile-flavor-methods toshiba-stream)

;1;; The rest of this file is stuff specific to the Toshiba P1351.  This code won't work on a P1350.*
;1;; Notably included here is the code for downloading fonts.* -- which has clearly never once
;1;; *worked! (See my note below the method (toshibal-p1351-stream :download-font).

(def-tiger-props :toshiba-p1351
		 tiger-stream-flavor toshiba-p1351-stream
		 default-x-scale 2
		 default-y-scale 2
		 bullethole-p t
		 tiger-font-type toshiba-font
		 tiger-options ((:font "Font" :choose (nil 0 1 2 25fg 25fgb 25fgi 25vg 25vgi 25vgb
							   25vr 25vrb 25vri 25vmic))
				(:font-list "Font list" :sexp)
				(:characters-per-inch "Characters per inch" :number-or-nil)
				(:lines-per-inch "Lines per inch" :number))
		 options-and-defaults ((:font nil)
				       (:font-list nil)
				       (:characters-per-inch 10.)
				       (:lines-per-inch 6.))
		 font-directory "SYS:TIGER;TOSHIBA-FONTS;")

(defflavor toshiba-P1351-stream ()
	   (toshiba-stream))

;; This used to be (toshiba-p1351-stream :after :init), which was wrong, whereas now it
;; is right, right? -mhd, 1/18/86

(defmethod (toshiba-p1351-stream :after :set-destination) (&rest ignore)
  (send self :download-font toshiba-default-font :font-first-char #xA0 :n-chars 32.))

(defmethod (toshiba-p1351-stream :download-font)
	   (font-name &optional &key (font-number 4) (first-char 40) (n-chars 100000)
	    (font-first-char 40) (create-p t) (cpi 10.) (cpi10-p t)
	    (cpi12-p t))
  (condition-case (c)
      (progn
       (check-arg-type font-name symbol)
       (let ((fon (load-font-if-necessary font-name :toshiba)))
	 (escape-sequence (ascii-code #/&))
	 (send destination :tyo (selectq font-number
				  (4 (ascii-code #/4))
				  (5 (ascii-code #/5))
				  (t (ferror nil "~O is not a valid font number." font-number))))
	 (send destination :tyo (dpb (if cpi10-p 1 0) 0001 (dpb (if cpi12-p 1 0) 0101
								(ascii-code #/4))))
	 (send destination :tyo (selectq cpi
				  (10. (ascii-code #/N))
				  (12. (ascii-code #/E))
				  (:proportional (ascii-code #/P))
				  (t (ferror nil "~O is not a valid pitch." cpi))))
	 (send destination :tyo (if create-p (ascii-code #/0) (ascii-code #/1)))
	 (send destination :tyo 0)
	 (send destination :tyo 0)
	 (loop for ch from first-char below (array-active-length fon)
	       for n from 0 below n-chars
	       for font-ch from font-first-char
	       for ch-string = (aref fon ch)
	       when (and ch-string (not (eq (array-active-length ch-string) 0)))
	       do (send destination :tyo (logand font-ch 177))
	       (send destination :tyo (if (> font-ch 177) (ascii-code :SI) (ascii-code :SO)))
	       (multiple-value-bind (trim-str ch-width pat-width)
		   (trim-font-string ch-string)
		 (format destination "~2D"	;You meant "~2,VD", didn't you?
			 (ascii-code #/0) ch-width)
		 (cond ((eq font-ch (ascii-code :Space))
			(send destination :tyo (ascii-code #/0))
			(send destination :tyo (ascii-code #/0)))
		       (t (format destination "~2,VD" (ascii-code #/0) pat-width)
			  (loop for x from 0 below (array-active-length trim-str) by 4
				do (send destination :tyo (logand (aref trim-str x) 125))
				(send destination :tyo (logand (aref trim-str (1+ x)) 125))
				(send destination :tyo (logand (aref trim-str (+ 2 x)) 125))
				(send destination :tyo (logand (aref trim-str (+ 3 x)) 125))
				(send destination :tyo (logand (aref trim-str x) 252))
				(send destination :tyo (logand (aref trim-str (1+ x)) 252))
				(send destination :tyo (logand (aref trim-str (+ 2 x)) 252))
				(send destination :tyo
				      (logand (aref trim-str (+ 3 x)) 252))))))
	       finally (send destination :tyo 0)
	       (send destination :tyo 0))))
    (error
     (format error-output "~&Trouble downloading toshiba font ....")
     (send c ':report error-output)
     (format error-output "~&... will now continue to print."))))

;; Errors are good and well if you have someone to fix them and if they stop a process
;; that it is important to stop for the purpose of human intervention; getting the right
;; font or even being able to handle non-ASCII characters in not that important, I claim,
;; and we do not currently have anyone to rewrite this whole driver, which is likely what
;; is needed.

;; I've gotten it to the point where it bombs out on the undefined function TRIM-FONT-
;; STRING.  Probably, the person who wrote the stuff in the toshiba-font file
;; (who understands the specific format of a "font string", which is a highly internal
;; representation of a font and how it looks on a Lisp Machine window) is the only one
;; who could define trim-font-string or otherwise make :download-font work.  There is
;; no documentation whatsoever of what it is doing.  There is, of course, Toshiba
;; documentation; but someone who was going to decifer the Toshiba programming protocol
;; might as well sit down and write the driver over from scratch, which I would probably
;; choose to do.  See the file toshiba-fonts for further code but no documentation.
;; -mhd, 1/18/86