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

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

;1;; Printer stuff for the TI 855 printer*
;1;; Note that the TI855 is used in WP mode.*
;1;; The software initializes it to that mode; you don't have to set the DIP switch.*

(def-tiger-props :ti855
		 tiger-stream-flavor ti855-stream
		 default-x-scale 1
		 default-y-scale 1
		 tiger-font-type ti855-font
		 tiger-options ((:font "Font" :assoc (("Default" . nil)
						      ("Built-in" . 0)
						      (1 . 1)
						      (2 . 2)
						      (3 . 3)
						      ("Downloaded font" . 4)))
				(: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 12.)
				       (:lines-per-inch 6.)))
	 

(defun fill-part-array (array offset)
  (loop for ch from 0 to 65535.
	do (aset (loop with new-ch = 0
		       for new-bit from 0 to 7
		       for bit from offset by 2
		       do (setq new-ch (deposit-byte new-ch new-bit 1 (load-byte ch bit 1)))
		       finally (return new-ch))
		 array ch))
  array)

(defvar part-1-array)
(defvar part-2-array)

(defstruct (ti855-font :conc-name
		       (:type :named-array-leader) 
		       (:make-array (:leader-length 3 :dimensions 128.)))
  :name)

(defvar default-ti855-font-map (circular-list 1 2 3))

(defflavor ti855-stream ((temporary-bit-graphics-array
			   (make-array 1200. :type 'art-string :fill-pointer 0))
			 (temporary-bit-graphics-array-2
			   (make-array 1200. :type 'art-string :fill-pointer 0))
			 (temporary-bit-graphics-array-3
			   (make-array 1200. :type 'art-string :fill-pointer 0))
			 (horizontal-position 0)
			 (whitespace-threshold 128.))
	   (basic-printer-stream-mixin)
  (:default-init-plist :name :ti855
		       :font 0
		       :dots-per-line 16.
		       :characters-per-inch 12.
		       :discard-font-changes t
		       :process-font-changes t))


(defmethod (ti855-stream :setup-normal) ()
  (escape-sequence (ascii-code :sub) #/I)
  (send self :set-characters-per-inch 12.)
  (send self :set-tab-stops))

(defmethod (ti855-stream :set-characters-per-inch) (cpi)
  (setq characters-per-inch (or cpi 12.))
  (selectq characters-per-inch
    (10. (escape-sequence #/y))
    (12. (escape-sequence #/z))
    (t (when (> cpi 15.) (send self :set-compressed-printing))
       (escape-sequence (ascii-code :us))
       (send destination :tyo (1+ (round 120. characters-per-inch))))))

(defmethod (ti855-stream :set-lines-per-inch) (lpi)
  (setq lines-per-inch (or lpi 6))
  (escape-sequence (ascii-code :fs))
  (send destination :tyo (1+ (round 144. lines-per-inch))))

(defmethod (ti855-stream :set-compressed-printing) (&optional (compressed-p t))
  (send destination :tyo (if compressed-p (ascii-code :si) (ascii-code :dc2))))

;1;; Elongated printing leads to excessively long lines on an 855, so don't try.*
;(defmethod (ti855-stream :set-elongated-printing) (elongated-p)
;  (cond (elongated-p (send destination :tyo (ascii-code :so)))
;	(t (send destination :tyo (ascii-code :dc4))
;	   (send self :set-characters-per-inch characters-per-inch))))

(defmethod (ti855-stream :set-boldface) (bold-p)
  (escape-sequence #/K (if bold-p 2 1)))

(defmethod (ti855-stream :set-shadow-printing) (shadow-p)
  (escape-sequence (if shadow-p #/Q #/R)))

(defmethod (ti855-stream :set-quality) (quality-p)
  (escape-sequence (if quality-p #/q #/d)))

(defmethod (ti855-stream :set-tab-stops) (&optional (n-columns 8.))
  (escape-sequence #/2)
  (loop for n-stops to 16
	for col from (1+ n-columns) by n-columns below (* characters-per-inch 8.)
	do (escape-sequence (ascii-code :ht))
	   (send destination :tyo col)
	   (escape-sequence #/1))
  (send destination :tyo (ascii-code #\return)))

;1;; Notes on font specifications for the TI855:*
;1;; 1.  Font 0 is the internal font; font number 1 is the font in slot 1; font 2 is in slot 2; font 3 is in slot 3;*
;1;;     font 4 is the Extended Character Set font.*
;1;; 2.  Bit 4 of the font number selects boldface printing.  (I.e.: to get a boldface version of a font, add 16.*
;1;;     to the number given above.)*
;1;; 3.  Bit 5 of the font number selects shadow printing.  (I.e.: to get a shadow version of a font, add 32.*
;1;;     to the number given above.)*
;1;; 4.  Setting bits 4 and 5 (adding 48.) will indeed set both boldface and shadow printing.*
;1;; 5.  The default font map for the TI855 is set up so fonts 1, 2, and 3 will be used cyclically.  The internal*
;1;;     font and the Extended Character Set font will not be used at all.  Specifying a font map of NIL*
;1;;     actually gets you the default font map.*

;;; If using font 0, avoid calling lookup-font.  It returns 1 (which is wrong)
;;; because font 0 isn't on the default font map.

(defmethod (ti855-stream :set-font) (&optional font-spec (literal-p nil) (push-p t))
  push-p
  (unless font-spec (setq font-spec 0))
  (if (zerop font-spec) (setq literal-p t))
  (let ((new-font (if literal-p font-spec (lookup-font font-spec font-list 'ti855-font))))
    (cond ((eq font new-font) nil)		;1Don't bother emitting a change if we really didn't*
	  ((fixnump new-font)
	   (setq font new-font)
	   (send self :set-boldface (bit-test 20 font))
	   (send self :set-shadow-printing (bit-test 40 font))
	   (escape-sequence #/f (logand font 17)))
	  (t (ferror nil "Invalid TI855 font spec ~A encountered." new-font)))
    ;1; This must be done because the printer changes this back to the hardware default after a font change*
    (send self :set-characters-per-inch characters-per-inch)))

(defmethod (ti855-stream :set-font-list) (map)
  (setq font-list (if map map default-ti855-font-map)))

;1;; Bit graphics methods*

(defmethod (ti855-stream :set-up-for-graphics) (ignore)
  (send self :set-lines-per-inch 9.)
  (send self :set-characters-per-inch 12.)
  (setf (fill-pointer temporary-bit-graphics-array) 0))

(defmethod (ti855-stream :print-bit-graphics) (character)
  (incf horizontal-position)
  (array-push temporary-bit-graphics-array (aref part-1-array character))
  (array-push temporary-bit-graphics-array-2 (aref part-2-array character)))

(defmethod (ti855-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.*
	  ((and (not (zerop horizontal-position)) (< delta-x whitespace-threshold))
	   (push-graphic-blanks delta-x)
	   (push-graphic-blanks delta-x temporary-bit-graphics-array-2))
	  (t (multiple-value-bind (column leftover)
		 (floor new-position 12.)
	       (force-ti855-graphics-output)
	       (escape-sequence (ascii-code #\tab))
	       (array-push temporary-bit-graphics-array-3 (ascii-code :escape))
	       (array-push temporary-bit-graphics-array-3 (ascii-code #\tab))
	       (send destination :tyo (1+ column))
	       (array-push temporary-bit-graphics-array-3 (1+ column))
	       (push-graphic-blanks leftover)
	       (push-graphic-blanks leftover temporary-bit-graphics-array-2)))))
  (setq horizontal-position new-position))

(defmethod (ti855-stream :new-graphics-line) ()
  (force-ti855-graphics-output)
  (escape-sequence (ascii-code :fs))			;1Set up for 1/144 inch line space*
  (send destination :tyo 2)
  (send destination :tyo (ascii-code #\return))
  (send destination :tyo (ascii-code #\line))
  (send destination :string-out temporary-bit-graphics-array-3)
  (escape-sequence (ascii-code :fs))			;1Set up for 15/144 inch line space*
  (send destination :tyo 16.)
  (send destination :tyo (ascii-code #\return))
  (send destination :tyo (ascii-code #\line))
  (setq horizontal-position 0)
  (setf (fill-pointer temporary-bit-graphics-array-3) 0))

(defsubst ti855-graphics-number (amount stream)
  (multiple-value-bind (high-byte low-byte)
      (floor amount 256.)
    (send stream :tyo low-byte)
    (send stream :tyo high-byte)))

(defun force-ti855-graphics-output ()
  (declare (:self-flavor ti855-stream))
  (escape-sequence #/o)
  (ti855-graphics-number (array-active-length temporary-bit-graphics-array) destination)
  (send destination :string-out temporary-bit-graphics-array)
  (array-push temporary-bit-graphics-array-3 (ascii-code :escape))
  (array-push temporary-bit-graphics-array-3 #/o)
  (multiple-value-bind (high-byte low-byte)
      (floor (array-active-length temporary-bit-graphics-array-2) 256.)
    (array-push temporary-bit-graphics-array-3 low-byte)
    (array-push temporary-bit-graphics-array-3 high-byte))
  (string-nconc temporary-bit-graphics-array-3 temporary-bit-graphics-array-2)
  (setf (fill-pointer temporary-bit-graphics-array) 0)
  (setf (fill-pointer temporary-bit-graphics-array-2) 0))

(compile-flavor-methods ti855-stream)