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

; 2 Don't load this file if you are running release 6 or newer!*
; 2 The file *POSTSCRIPT-PRINTER-REL6.LISP2 obsoletes this one.*

;1 File name: POSTSCRIPT-PRINTER.LISP*
;1 Redefines functions and methods associated with postscript printers.*
;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 The LPD Protocol requires a few extra methods from the Printer objects:*
;1 :Dump-Printer-Forms.*

;1 Also, the Build-Postscript-Source-Variable function didn't handle the special*
;1 structuring comments correctly, this is fixed here.*

;1----------------------------*
;1 Define some global variables*
;1----------------------------*

(defvar 4*EXPLORER-POSTSCRIPT-FONT-MAP**
	'(("35X5*" ("3Courier*" 5))
	  ("3BIGFNT*" ("3Helvetica*" 15 ))
	  ("3CMB8*" ("3Times-Bold*" 22))
	  ("3CMDUNH*" ("3Times-Roman*" 28))
	  ("3CMOLD*" ("3Times-Bold*" 28))
	  ("3CMR10*" ("3Times-Roman*" 10))
	  ("3CMR18*" ("3Times-Bold*" 32))
	  ("3COURIER*" ("3Courier*" 11))
	  ("3CPTFONT*" ("3Courier*" 10))
	  ("3CPTFONTB*" ("3Courier-Bold*" 10))
	  ("3CPTFONTBI*" ("3Courier-BoldOblique*" 10))
	  ("3CPTFONTI*" ("3Courier-Oblique*" 10))
	  ("3DEFAULT*" ("3Courier*" 10))
	  ("3HIGHER-MEDFNB*" ("3Courier-Bold*" (10 14)))
	  ("3HIGHER-TR8*" ("3Times-Roman*" (8 10)))
	  ("3HL10*" ("3Helvetica*" 9))
	  ("3HL10B*" ("3Helvetica-Bold*" 9))
	  ("3HL12*" ("3Helvetica*" 10))
	  ("3HL12B*" ("3Helvetica-Bold*" 10))
	  ("3HL12BI*" ("3Helvetica-BoldOblique*" 10))
	  ("3HL12I*" ("3Helvetica-Oblique*" 10))
	  ("3HL6*" ("3Helvetica*" 6))
	  ("3HL7*" ("3Helvetica*" 7))
	  ("3MEDFNB*" ("3Courier-Bold*" (11 10)))
	  ("3MEDFNT*" ("3Courier*" (11 10)))
	  ("3MEDFNTB*" ("3Courier-Bold*" (11 10)))
	  ("3MEDFNTBI*" ("3Courier-BoldOblique*" (11 10)))
	  ("3MEDFNTI*" ("3Courier-Oblique*" (11 10)))
	  ("3METS*" ("3Times-Roman*" 16))
	  ("3METSB*" ("3Times-Bold*" 16))
	  ("3METSBI*" ("3Times-BoldItalic*" 16))
	  ("3METSI*" ("3Times-Italic*" 16))
	  ("3SYM10*" ("3Symbol*" 10))
	  ("3SYM12*" ("3Symbol*" 12))
	  ("3TINY*" ("3Helvetica*" 5))
	  ("3TR10*" ("3Times-Roman*" 9))
	  ("3TR10B*" ("3Times-Bold*" 9))
	  ("3TR10BI*" ("3Times-BoldItalic*" 9))
	  ("3TR10I*" ("3Times-Italic*" 9))
	  ("3TR12*" ("3Times-Roman*" 10))
	  ("3TR12B*" ("3Times-Bold*" 10))
	  ("3TR12BI*" ("3Times-BoldItalic*" 10))
	  ("3TR12I*" ("3Times-Italic*" 10))
	  ("3TR18*" ("3Times-Roman*" 18))
	  ("3TR18B*" ("3Times-Bold*" 18))
	  ("3TR8*" ("3Times-Roman*" 8))
	  ("3TR8B*" ("3Times-Bold*" 8))
	  ("3TR8I*" ("3Times-Italic*" 8))
	  ("3TVFONT*" ("3Courier*" 7))
	  ("3WIDER-FONT*" ("3Helvetica*" (18 16)))
	  ("3WIDER-MEDFNT*" ("3Courier*" (14 10))))
  "2The default mapping from Explorer fonts to PostScript fonts.*")

;1-----------------------------------------------*
;1 Build the postscript program buffer CORRECTLY*
;1-----------------------------------------------*

(defun 4build-postscript-source-variable* (&optional (source *POSTSCRIPT-DRIVER*))
"2Reads the postscript driver program source file and places it into a local buffer
after stripping out unneeded fluff to make it as compact as possible.*"
  (declare (function build-postscript-source-variable () fixnum)
	   (values length-of-program))
  (unless (or (typep source 'ARRAY) (probe-file source))
    (ferror () "3Could not find PostScript driver file ~a*" source))

  (let ((source-length (if (typep source 'ARRAY)
			   (* (array-dimension source 0) 132)
			   (file-length source)))
	(current-line "")
	(ch-cnt 0)
	(line-cnt -1)
	(fd nil)
	)
    (declare (FIXNUM source-length ch-cnt line-cnt)
	     (type (or NULL STRING) current-line)
	     (type (or NULL STREAM) fd))
    ;1 Create the buffer.*
    (setf *POSTSCRIPT-PROGRAM-IN-BUFFER* (make-array source-length :leader-length 1))

    ;1 Open the file if needed and start reading driver.*
    (unwind-protect
	(setf fd (unless (typep source 'ARRAY)
		   (open source :direction :input :if-does-not-exist :error))
	      (array-leader *POSTSCRIPT-PROGRAM-IN-BUFFER* 0)
	      (do* ((x 0)
		    (continue-read nil)
		    (paren-count 0)
		    (move-byte-to-buffer nil nil)
		    (start-newline-comment nil)
		    (forced-read nil)
		    (previous-byte (char-int #\Return) current-byte)
		    (current-byte (if (typep source 'ARRAY)
				      (if (= ch-cnt (length current-line))
					  (progn (setq ch-cnt 0
						       current-line (aref source (incf line-cnt)))
						 (if current-line
						     (char-int #\NewLine)
						     NIL))
					  (aref source (1- (incf ch-cnt))))
				      (send fd :tyi))
				  (if (typep source 'ARRAY)
				      (if (= ch-cnt (length current-line))
					  (progn (setq ch-cnt 0
						       current-line (aref source (incf line-cnt)))
						 (if current-line
						     (char-int #\NewLine)
						     NIL))
					  (aref source (1- (incf ch-cnt))))
				      (send fd :tyi))))
		    ((null current-byte) x)
		    (declare (type (or NULL FIXNUM) current-byte)
			     (FIXNUM paren-count previous-byte x)
			     (SYMBOL continue-read start-newline-comment forced-read))
		    ;1 Handle any special characters.*
		    (cond ((= current-byte 137) ())		;1 Tab - remove it.*
			  ((= current-byte 141)			;1 Newline*
			   ;1 If this is ending a comment, end comment mode.*
			   ;1 If the last line was empty, do nothing.*
			   ;1 Otherwise, copy a Newline character to the buffer.*
			   (setf move-byte-to-buffer
				 (not (and (plusp x)
					   (= 141 (aref *POSTSCRIPT-PROGRAM-IN-BUFFER* (1- x)))))
				 continue-read nil
				 forced-read nil))
			  ( forced-read (setq move-byte-to-buffer T))
			  ((= current-byte 33)			;1 !*
			   ;1 If we are reading the first line of the input and this is the second*
			   ;1 character read, then we have a `magic number' sequence here that should*
			     ;1 be copied into the program.*
			   ;1 If we are not in a comment, copy the character.*
			   (if continue-read
			       (if (and (zerop x) start-newline-comment)
				   (setf (aref *POSTSCRIPT-PROGRAM-IN-BUFFER* x) 37
					 continue-read nil
					 move-byte-to-buffer T
					 forced-read T
					 x (1+ x))
				   (setq start-newline-comment nil))
			       (setq move-byte-to-buffer T)))
			  ((= current-byte 37)			;1 %*
			   ;1 If this is a double `%%' this is a special structuring comment that shold*
			   ;1 be included in the driver program (assuming it starts at the begining of*
			   ;1 a line).*
			   (cond ( continue-read (when start-newline-comment
						   (setf (aref *POSTSCRIPT-PROGRAM-IN-BUFFER* x) 37
							 start-newline-comment nil
							 x (1+ x)
							 forced-read T
							 continue-read nil
							 move-byte-to-buffer T)))
				 ((zerop paren-count) (setf continue-read T	   ;1 Must be part of a comment*
							    start-newline-comment (= previous-byte 141)))
				 ( T (setf move-byte-to-buffer T))))	  	   ;1 Must be part of a string*
			  ( continue-read	  		;1 Continue to read from input file, must be in a comment.*
			   (setq start-newline-comment nil))
			  ((= current-byte 32)			;1 Let's do some blank suppression*
			   (setf move-byte-to-buffer (/= previous-byte 32)))
			  ((= current-byte 40)			;1 (*
			   (unless (= previous-byte 92)		;1 Back slash*
			     (setf paren-count (1+ paren-count)))
			   (setf move-byte-to-buffer T))
			  ((= current-byte 41)			;1 )*
			   (unless (= previous-byte 92)		;1 Back slash*
			     (setf paren-count (1- paren-count)))
			   (setf move-byte-to-buffer T))
			  (t (setf move-byte-to-buffer T)))
		    ;1 Put the character into the buffer if needed.*
		    (when move-byte-to-buffer
		      (setf (aref *POSTSCRIPT-PROGRAM-IN-BUFFER* x) current-byte)
		      (incf x))))
      ;1 CLose the file if needed.*
      (when fd
	(close fd)))))

;1 Build the new source variable.*
(with-open-file (s "3sys:PRINTER;POSTSCRIPT-DRIVER.TEXT#>*" :direction :input)
  (declare (STREAM s))
  (build-postscript-source-variable s))

;1-----------------------------------------------*
;1 Add some extra methods to the PostScript-Printer*
;1-----------------------------------------------*

(defmethod 4(postscript-printer :start-document*) (header-name user-name ignore)
"2Initialize the printer and some instance variables in this instance.*"
  (declare (function (:METHOD postscript-printer :start-document) (T T T) NULL)
	   (values NIL))
   (send self :initialize-vars header-name user-name)
  ;1 Now reset the printer.*
  (send self :tyo-raw (int-char 4)))

(defmethod 4(postscript-printer :end-document*) ()
"2Let the printer know that we are done.*"
  (declare (function (:METHOD postscript-printer :end-document) () NULL)
	   (values NIL))
  ;1 Reset the printer.*
  (send self :tyo-raw (int-char 4)))

(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*)))

(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))
  (format nil "3J~A
H~A
P~A
~{~A~}~:[~;W132
~]U~A
N~A
*"
	  header
	  host
	  user
	  (make-list copies :initial-element (format nil "3l~A
*" data-name))
	  print-wide
	  data-name
	  (send (send file-name :truename) :string-for-nfs)))

(defmethod 4(postscript-printer :start-new-page*) (&optional override-page-heading)
"2Called when we must start a new page. Does nothing since the postscript
driver program handles this itself.*"
  (declare (function (:METHOD postscript-printer :start-new-page) (&optional T) NULL)
	   (values NIL)
	   (ignore override-page-heading))
   nil)

(defmethod 4(postscript-printer :write-postscript-program*) ()
"2Dump the standard postcript driver file. This file can be changed by sending a new file name*"
  (declare (function (:METHOD postscript-printer :dump-posctscript-program) () NULL)
	   (values NIL))

   (unless *POSTSCRIPT-PROGRAM-IN-BUFFER*   ;1 If PS driver not in buffer, then read it*
    (build-postscript-source-variable))

  (dotimes (i (length *POSTSCRIPT-PROGRAM-IN-BUFFER*))	   ;1 Now write the buffer to the printer*
    (declare (FIXNUM i))
    (if (= (aref *POSTSCRIPT-PROGRAM-IN-BUFFER* i)	   ;1 If carriage return*
	   (char-int #\Return))
	(send self :tyo-raw (int-char 10))				   ;1 Then send LineFeed to PS printer*
	(send self :tyo-raw (aref *POSTSCRIPT-PROGRAM-IN-BUFFER* i)))))	   ;1 else send the character*

(defmethod 4(postscript-printer :print-bitmap*) (bitmap-array
						   &optional width height (start-x 0) (start-y 0) orientation
							     dots-per-inch
						   &aux picstr-width pic-width
							(default-scale .24) user-scale
							(top-margin 700.0) (rotate-angle 0)
							(scale-multiplier 2) (x-fudge 100) (y-fudge 50))
"2Copy the bitmap array to a print stream;
printer-stream could be a file stream or serial stream. It assumes 8 bit data transfer*"
  (declare (function (:METHOD postscript-printer :print-bitmap) ()))
  ;1If I am printing to a remote host, don't do :bitmap-setup*
  ;1because it will be done by :print-raw file on the server*
  (unless (typep (send self :printer-stream) 'fs:LM-CHARACTER-OUTPUT-STREAM)
    (send self :bitmap-setup))

  (when (equal orientation :LANDSCAPE)
    (setq rotate-angle 90
	  top-margin 10
	  x-fudge 50
	  scale-multiplier 3))
  (if (numberp dots-per-inch)
      (setq scale-multiplier dots-per-inch))
  (setq 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 (= width (* (quotient width 8) 8))
      (setq pic-width width)
      (setq pic-width (* 8 (+ (quotient width 8) 1))
	    width pic-width))
  (setq picstr-width (quotient pic-width 8))
 
  (format (send self :printer-stream) "3~D
~D
~D
~D
~D
~D
~D
*"
	  rotate-angle user-scale width height (- (quotient top-margin user-scale) height y-fudge)
	  picstr-width pic-width)

  ;1 Now output the bytes of the screen image.*
  (do ((y start-y (+ y 1))
       (image-bit 0)
       (image-hex 0))
      ((= y height)
       ;1 Send out the last few bits if needed*
       (unless (zerop image-bit)
	 (format (send self :printer-stream) "3~2,48X 
*" (lsh image-hex (- 8 image-bit)))))
    (declare (FIXNUM y image-bit image-hex))
    (do ((x start-x (+ x 1)))
	((= x width))
      (declare (FIXNUM x))
      ;1 Accumulate bits into a byte.*
      (setq image-hex (+ (lsh image-hex 1) (- 1 (aref bitmap-array y x)))
	    image-bit (1+ image-bit))
         ;1 Now output the byte if it is ready.*
      (when (= image-bit 8)
	(format (send self :printer-stream) "3~2,48X 
*" image-hex)
	(setq image-hex 0
	      image-bit 0)))))

(defmethod 4(postscript-printer :dump-file*) (file-stream)
"2Do raw file dump to printer.*"
  (declare (function (:METHOD postscript-printer :dump-file) (STREAM) NULL)
	   (values NIL))
  (do ((char-out (send file-stream :tyi) (send file-stream :tyi)))
      ((null char-out))
    (declare (type (or NULL CHARACTER) char-out))
    (if (char= char-out #\Return)
	(send self :tyo-raw (int-char 10))
	(send self :tyo-raw char-out))))

(defmethod 4(postscript-printer :print*) ()
"2Print the file stream.*"
  (declare (function (:METHOD postscript-printer :print) () NULL)
	   (values NIL))
  (let ((new-font (first current-font))
	(font-size (second current-font)))
    (declare (LIST font-size)
	     (SYMBOL new-font))
    ;1 Print out the header stuff.*
    (send self :header-stuff page-heading)			   ;1Send header information to the postscript printer*
    (format (send self :printer-stream) "3~:[0~;90~]
*" print-wide)	   ;1 If wide print, rotate 90 degrees*
    (send self :set-line-height)
    (send self :send-font-size font-size)			   ;1Send for initialization PS-SetPointSize*
    (format (send self :printer-stream) "3~A
*" new-font)

    ;1 Copy the File-Stream to the printer.*
    (do ((end-document nil)
	 (char-out (send input-string :tyi) (send input-string :tyi)))
	((or end-document (null char-out)))
      (declare (SYMBOL end-document)
	       (type (or NULL FIXNUM CHARACTER) char-out))
      ;1 Convert Char-Out to a character.*
      (setq char-out (int-char char-out))

      ;1 Now send the character to the printer, with filtering if needed.*
      (cond ((char= char-out #\Return)
	     (send self :tyo-raw (int-char 10))
	     (send self :tyo-raw (int-char 10))
	     (if (eql eof 0)
	       (send self :set-line-height)
	       (format (send self :printer-stream) "30
*")
	       (setq end-document T)))
	    ((char= char-out #\Tab)
	     ;1 End the string and send the Tab Function character.*
	     (format (send self :printer-stream) "3
	*"))
	    ((char= char-out #\Epsilon)
	     (let ((next-char (send input-string :tyi)))
	       (declare (type (or NULL FIXNUM) next-char))
	       (if (and next-char
			(or (char<= #\0 (int-char next-char) #\I)
			    (char= (int-char next-char) #\*)))	   ;1 Allow up to 26 fonts*
		 (progn (send self :tyo-raw (int-char 10)) ;1Send a return so they are expecting the font change*
			(send self :tyo-raw char-out)	   ;1Inform the printer of a impending font change*
			(setq current-font (send self :font-select next-char)
			      new-font (first current-font)	   ;1Set new font to first atom of list string with name*
			      font-size (second current-font))	   ;1Set point size of new font*
			(send self :send-font-size font-size)
			(format (send self :printer-stream) "3~A
*" new-font))
		 (send self :tyo-raw (int-char 10))	   ;1 End the string for postscript*
		 (send self :tyo-raw (int-char 8))	   ;1 Inform postscript of a symbol*
		 (send self :tyo-raw (int-char #o145))	   ;1 Print the epsilon character*
		 (send self :tyo-raw (int-char 10)))))	   ;1 Send the epsilon character*
	    ((or (<= #\ char-out #\) (char= char-out #\))	   ;1 Math symbol*
	     (send self :convert-char char-out))
	    ((char= char-out #\Page)
	     (format (send self :printer-stream) "3
*"))
	    ( T (send self :tyo-char char-out))))  ;1 Print the standard character
*    (close file-object)))		   ;1 Close the file object