;;; -*- Mode:Common-Lisp; Package:PRINTER; Base:10; Fonts:(COURIER TR12I TR12BI TR12 MEDFNTB); Patch-file:T -*-

;1 File name: POSTSCRIPT-PRINTER-REL6.LISP*
;1 Redefines functions and methods associated with postscript printers.     2**** This version of this file for TI Release 6. ******
;1 Started 3-11-1989 by Eric Karlson, UC-Berkeley under Robert Wilensky*
;1 Phone: (415) 642-9076, E-mail Address: karlson@ucbarpa.berkeley.edu*
;
;1 27 sep 89  Jamie Zawinski*	1This version created for Rel6 compatibility.*
;1  3 oct 89  Jamie Zawinski*	1Added 2:form* method, and 2LFpad*/2FFpad* tweaking to lose the garbage characters on the front of the file.*
; 16 Feb 90* 1Jamie Zawinski *	1Changed 2(:method postscript-printer :lpd-control-string)* to explicitly write 2(int-char 10)* instead of*
;			1just including that character (Symbol-Shift-D) in the 2lpd-control-string*.  When this file was copied to*
;			1a unix host, that LF character was being turned into a CR, which is wrong!*

;1 The LPD Protocol requires a few extra methods from the Printer objects:*
;1 2:LPD-Control-String* and 2:Initialize-Vars*.*

;1 Other methods in this file were redefined to not include Control-D characters (to reset the printer) in their output.*
;1 If a Control-D is embedded in a PostScript program, the Unix LPD server will not print it, saying ``Spooled binary file rejected.''*
;1 These changes may have broken printing to a PostScript printer attached to a machine not using LPD, but I can't test that.*


(defmethod 4(postscript-printer :after :init)* (ignore)
  "2Set LFpad and FFpad to zero so that nulls don't get written out to the PS file (very bad).*"
  (send self :set-lfpad 0)
  (send self :set-ffpad 0))

(defmethod 4(postscript-printer :form)* ()
  "2Do nothing.  PS printers don't need this, and if it is around, a superflouous character gets written before the ``%ps''.*"
  nil)

;1;; Modified to use the :initialize-vars method instead of duplicating the code.  Not really necessary.*
;1;;*
(defmethod 4(postscript-printer :start-document*) (header-name user-name ignore)
"2Initialize the printer and some instance variables in this instance.*"
   (send self :initialize-vars header-name user-name))

;1;; This is called by LPD and by :start-document (defined above).*
;1;;*
(defmethod 4(postscript-printer :initialize-vars*) (header-name user-name)
"2Initialize the Header Name and User Name for this print job.*"
  (declare (function (:METHOD postscript-printer :initialize-vars) (T T) NULL)
	   (values NIL))
   (send self :set-title-name header-name)
  (send self :set-user-machine-id user-name)
  (send self :set-font-list (append ps-font-map *EXPLORER-POSTSCRIPT-FONT-MAP*)))

;1;; This is called by LPD only.*
;1;;*
(defmethod 4(postscript-printer :lpd-control-string*) (data-name header host user file-name copies)
"2Returns the string to be used as a control file for the LPD protocol.*"
  (declare (function (:METHOD postscript-printer :lpd-control-string)
		     (STRING STRING STRING STRING STRING FIXNUM)
		     STRING)
	   (values CONTROL-STRING))
  (let* ((lf-char (int-char 10)))  ;1 We must use LFs instead of CRs!  Unix-land...*
    (format nil "3J~A~cH~A~cP~A~c~{~A~}~:[~*~;W132~c~]U~A~cN~A~c*"
	    header lf-char
	    host lf-char
	    user lf-char
	    (make-list copies :initial-element (format nil "3l~A~c*" data-name lf-char))
	    print-wide lf-char
	    data-name lf-char
	    (send (send file-name :truename) :string-for-nfs)
	    lf-char)
      ))


;1;; Modified to not send Control-D's - the spooler must do that.*
;1;;*
(DEFMETHOD (PostScript-Printer :dump-file) (file-stream)
  "do raw file dump to printer"
  (LET (char-out)
;    (SEND self :tyo-raw 04)			;reset printer
    (LOOP
      (SETF char-out (SEND file-stream :tyi ))
      (COND ((EQUAL char-out nil) (RETURN))
 	    ((EQUAL (int-char char-out) #\return )
	     (SEND self :tyo-raw 10))
	    (t (SEND self :tyo-raw char-out))
	    )
      )  
;1##*    (SEND self :tyo-raw 04)			;inform printer of eof
    ))


;1;; Modified to not send Control-D's - the spooler must do that.*
;1;;*
(DEFMETHOD (PostScript-Printer :print) ()
  "print the file stream"
  
  (LET (next-char char-out font-select new-font prev-char ;???? Check for default header values ????
	font-size (end-document 0)
	(maxed-ps-buffer 0) ; The postscript driver has a finite buffer length of 255 character. 11-14-88 DAB
	)

    (SEND self :header-stuff page-heading)	  ;send header information to the postscript printer
    ;; Swapped statements 09-22-87 DAB
    (IF print-wide				  ;if wide print, rotate 90 degrees
	(FORMAT (SEND self :printer-stream) "~d" 90)
	(FORMAT (SEND self :printer-stream) "~d" 0))
    (SEND self :tyo-raw 10)

    (SETF font-size (CADR current-font))	  ;set point size of  font
    (SETF new-font (CAR current-font))		  ;set new font to first atom of list string with name
    (SEND self :set-line-height)
    ;; Swapped statements 09-22-87 DAB
    (SEND self :send-font-size font-size)	  ;send  for initialization PS-SetPointSize
    (FORMAT (SEND self :printer-stream) "~a" new-font)
    (SEND self :tyo-raw 10)
						  ;header information download complete
    (FORMAT (SEND self :printer-stream) "~d" (or tab-width   ; DAB 01-24-89
						 (getf attribute-line :tab-width)
						 *default-tab-width*))  ; DAB 01-24-89
    (send self :tyo-raw 10)  ; DAB 01-24-89

    (LOOP
      (IF (EQUAL end-document -1)(RETURN) )
      (SETF prev-char char-out)
      (SETF char-out (SEND input-string :tyi))
      (IF  (EQUAL char-out nil) (RETURN))
      (COND
	((EQUAL (INT-CHAR char-out) #\return) (PROGN
						(SEND self :tyo-raw 10)
						(SEND self :tyo-raw 10)
						(IF (EQUAL eof -1)
						    (PROGN
						      (SETF end-document -1)
						      (FORMAT (SEND self :printer-stream) "~d" 0) ;10-19-87 DAB
						      (SEND self :tyo-raw 10)
						      (RETURN)))
						(SEND self :set-line-height)
						(setf maxed-ps-buffer 0) ;11-14-88 DAB
						))
	((EQUAL (INT-CHAR char-out) #\tab) (PROGN
					     (SEND self :tyo-raw 10)	  ;end of string
					     (SEND self :tyo-raw 9)	  ;do a tab function
					     (setf maxed-ps-buffer 0) ;11-14-88 DAB
					     )
					   )
	((EQUAL (INT-CHAR char-out) #\epsilon)
	 
	 (PROGN
	   (SETF next-char  (SEND input-string :tyi))
	   (IF (OR (<= #\0 (INT-CHAR next-char) #\I)  (EQUAL (INT-CHAR next-char) #\*))
	       (PROGN 
		 (SEND self :tyo-raw 10)	  ;send a return so they are expecting the font change
		 (SEND self :tyo-raw char-out)	  ;inform the printer of a impending font change
		 (SETF font-select next-char)	  ;character after Epsilon
		 (SETF current-font (SEND self :font-select font-select))
		 (SETF new-font (CAR current-font))	  ;set new font to first atom of list string with name	       
		 (SETF font-size (CADR current-font))	  ;set point size of new font
		 (SEND self :send-font-size font-size)
		 (FORMAT (SEND self :printer-stream) "~a" new-font)
		 (SEND self :tyo-raw 10)
		 (setf maxed-ps-buffer 0) ;11-14-88 DAB
		 
		 )
	       
	       (SEND self :tyo-raw 10)		  ;end the string for postscript
	       (SEND self :tyo-raw 8)		  ;inform postscript of a symbol
	       (SEND self :tyo-raw #o316)	  ;print the epsilon character
	       (SEND self :tyo-raw 10)		  ;send the epsilon character
	       (setf maxed-ps-buffer 0) ;11-14-88 DAB
	       )
	   )
	 )
	
	((OR (<= 0 char-out 31)			  ;math symbol
	     (CHAR-EQUAL (INT-CHAR char-out) #\Integral))
	 (SEND self :convert-char (INT-CHAR char-out))
	 (setf maxed-ps-buffer 0) ;11-14-88 DAB
	 )
	
	((EQUAL (INT-CHAR char-out) #\page)
	 (PROGN
	   (SEND self :tyo-raw 10)		  ;send a return so they are expecting page change
	   (SEND self :tyo-raw 12)		  ;send the formfeed character
	   (setf maxed-ps-buffer 0) ;11-14-88 DAB
	   )
	 )
	
	
	(t
	 (if (>= maxed-ps-buffer 255.)  ;check to make sure we are not over filling the PS buffer.
	     (progn (SEND self :tyo-raw 10)  ;terminate readline
		    (SEND self :tyo-raw 0))  ;this is a dummy statement but it gets the PS driver back to readline.
	     (setf maxed-ps-buffer (1+ maxed-ps-buffer))) ;11-14-88 DAB
 	 (SEND self :tyo-char char-out)	  ;print the standard character
   
	   )
	)
      )
;1##*    (SEND self :tyo-raw 4)			  ;inform %stdin of Postscript the end of a file

    )						  ;end of let
  )


;1;; Modified to not send Control-D's - the spooler must do that.*
;1;;*
(DEFMETHOD (PostScript-Printer :write-postscript-program) ()
  "Write the standard postcript driver file. This file can be changed by sending a new file name"
  (declare (special  *postscript-driver* *postscript-program-in-buffer*))
  (UNLESS *postscript-program-in-buffer*
    (FERROR () "Could not find PostScript driver file ~a" *postscript-driver*))
;1##*  (SEND self :tyo-raw 4)			;reset the printer
  ;1;*
  ;1; ## Make sure the first line is a magic number. -- jwz.*
  (dolist (x '(#\% #\! #\p #\s))
    (send self :tyo-char x))
  (send self :tyo-raw 10)
  
  (DOTIMES (i (array-leader *postscript-program-in-buffer* 0))  ;10-22-87 DAB       ;now write the buffer to the printer
    (IF (EQUAL (AREF *postscript-program-in-buffer* i)	        ;if carriage return
	       (CHAR-INT #\return))			                
	(SEND self :tyo-raw 10)                                       ; then send CR to PS printer
	(SEND self :tyo-raw (AREF *postscript-program-in-buffer* i))  ; else send the character
	  ))
  )
   

;1;; Modified to not send Control-D's - the spooler must do that.*
;1;;*
(DEFMETHOD (postscript-printer :print-bitmap) 
	   (bitmap-array
	    &OPTIONAL width height (start-x 0) (start-y 0) orientation dots-per-inch
	    &AUX picstr-width (image-hex 0) (image-bit 0) pic-width (default-scale .24)
	         user-scale bit-add (top-margin 700.0) (rotate-angle 0) (scale-multiplier 2)
	         (x-fudge 100) (y-fudge 50)
	     )
  "Copy the bitmap array to a print stream;
printer-stream could be a file stream or serial stream. It assumes 8 bit data transfer"

						  ;if I am printing to a remote host, don't do :bitmap-setup
						  ; because it will be done by :print-raw file on the server
  (UNLESS  (member (intern-local (TYPE-OF (SEND self :printer-stream)) 'printer)  ;08-19-88 DAB
		       '(lm-character-output-stream
			  nfs-buffered-output-character-stream)	;07-18-88 DAB Added for screen prints on a MX.
		   :test #'equal)
    (SEND self :bitmap-setup))

  (IF (EQUAL orientation :landscape )
      (PROGN (SETQ rotate-angle 90)
	     (SETQ top-margin 10)
	     (SETF x-fudge 50)
	     (SETF y-fudge 50)
	     (SETQ scale-multiplier 3)))
  (IF (NUMBERP dots-per-inch)
      (SETQ scale-multiplier dots-per-inch))
  (SETF user-scale (* default-scale scale-multiplier))
  (unless width
    (setq width (ARRAY-DIMENSION bitmap-array 1)))
  (unless height
    (setq height (ARRAY-DIMENSION bitmap-array 0)))

  (IF (EQUAL   width  (* (quotient  width  8) 8))
      (SETF pic-width  width )
      (PROGN
	(SETF pic-width (* 8 (+ (quotient width 8) 1)) )
	(SETF width pic-width)))
  (SETF picstr-width (quotient pic-width 8))
 
  (FORMAT (SEND self :printer-stream) "~d" rotate-angle )
  (SEND self :tyo-raw 10)
  (FORMAT (SEND self :printer-stream) "~d" user-scale)
  (SEND self :tyo-raw 10)
  (FORMAT (SEND self :printer-stream) "~d" width)
  (SEND self :tyo-raw 10)  
  (FORMAT (SEND self :printer-stream) "~d" height)
  (SEND self :tyo-raw 10)
;  (FORMAT (SEND self :printer-stream) "~d" x-fudge)
;  (SEND self :tyo-raw 10)
  (FORMAT (SEND self :printer-stream) "~d" (- (- (quotient top-margin user-scale)  height) y-fudge))
  (SEND self :tyo-raw 10)
  (FORMAT (SEND self :printer-stream) "~d" picstr-width)
  (SEND self :tyo-raw 10)
  (FORMAT (SEND self :printer-stream) "~d" pic-width)
  (SEND self :tyo-raw 10)
  (LET ((*print-base* 16))

    (DO (( y  start-y  (+ y 1))) ((EQUAL y    height  )  ()) 
      (DO (( x  start-x  (+ x 1))) ((= x    width ) ())
	(SETF bit-add (AREF bitmap-array y x))
	(IF (= bit-add 0)(SETF bit-add 1)(SETF bit-add 0))
	(SETF image-hex (+ image-hex  bit-add ))
	(SETF image-bit (+ image-bit 1))
	(IF (EQUAL image-bit 8) (PROGN
				  (IF (< image-hex 16)(PRINC "0" (SEND self :printer-stream)))
				  (SETF image-bit 0)
				  (princ image-hex (SEND self :printer-stream ))
				  (princ " " (SEND self :printer-stream ))
				  (SEND self :tyo-raw 10)
				  (SETF image-hex 0)
				  )
	    )
	(SETF image-hex (LSH image-hex 1))
	)
      ))
  (FORMAT (SEND self :printer-stream) "showpage")(SEND self :tyo-raw 10)
;1##*  (SEND self :tyo-raw 04)
  )