;; -*- Mode:common-lisp; Package:Imagen; Base:10; fonts:(Courier Hl12b Hl12bi) -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; COPYRIGHT (C) 1984-1989 Texas Instruments INCORPORATED. ALL RIGHTS RESERVED. ;;; ;;; This file contains the definition of the Imagen printer device flavor and its methods... ;;; ;;; CHANGE HISTORY ;;; 01-25-89 DAB Added support for specifing tab-width. Tab-width can bne specified in the argument list ;;; or in the mode line of the file, otherwise printer:*default-tab-width* is used. ;;; 08-18-88 DAB Added additional font mappings to *LISP-TO-IMAGEN-FONT-MAPPING*. ;;; 06-01-88 DAB Changes to IMAGEN:OUTPUT-MAGNIFIED-BITMAP-TO-PRINTER to ;;; create a significant (about 2x for average screens) performance ;;; improvements for bitmap printing to Imagen printers. DAB for RA. ;;; 04-06-87 LCO Changed defparameter *IMAGEN-FONT-DIRECTORY-NAME* from ;;; (LIST "imagen-fonts") to (LIST "imagen" "fonts") ;;; ;;; ********************************************************************************* ;;; ;;; Global constants in the Imagen package ;;; ;;; ********************************************************************************* ;;; (DEFPARAMETER *PRINTABLE-PIXELS-ACROSS-A-PAGE* 2299 "# of printable pixels across a page.") (DEFPARAMETER *PRINTABLE-PIXELS-DOWN-A-PAGE* 3250 "# of printable pixels down a page.") (DEFPARAMETER *PIXELS-IN-A-LINE* 2250 "7.5 inches of horizontal pixels.") (DEFPARAMETER *PIXELS-DOWN-A-PAGE* 3000 "10 inches of vertical pixels.") (DEFPARAMETER *TOP-MARGIN-HEIGHT* 150 "0.5 inch top margin.") (DEFPARAMETER *LEFT-MARGIN-WIDTH* 150 "0.5 inch left margin.") (DEFPARAMETER *IMAGEN-FONT-DIRECTORY-HOST-NAME* "sys" "The host on which loadable Imagen fonts are stored.") (DEFPARAMETER *IMAGEN-FONT-DIRECTORY-NAME* (LIST "imagen" "fonts") ;; lco 04-06-87 "The directory where loadable Imagen fonts are stored.") (DEFPARAMETER *LISP-TO-IMAGEN-FONT-MAPPING* '(("CPTFONT" . "CMASC10") ("COURIER" . "CMASC10") ("MEDFNT" . "CMASC10") ("HL12B" . "CMB10") ("HL12BI" . "CMBTI") ("MEDFNB" . "CMB10") ("TR12BI" . "CMBTI") ("TR12" . "CMRMN10") ("TR12I" . "CMTI10") ("TR12B" . "CMB10") ("HL12" . "CMSS10") ;08-18-88 DAB ("TR10" . "CMSC10")) "The table of (Lisp-font-name . Imagen-font-name) associations.") ;;; ********************************************************************************* ;;; ;;; Global variables in the Imagen package ;;; ;;; ********************************************************************************* ;;; (DEFVAR *EXPAND-BY-2-TABLE* (MAKE-ARRAY 256 :ELEMENT-TYPE '(UNSIGNED-BYTE 16)) "The binary patterns of 0-255 with each bit doubled.") (DEFVAR *FLIPPED-BITS-TABLE* (MAKE-ARRAY 256 :ELEMENT-TYPE '(UNSIGNED-BYTE 8)) "The binary patterns of 0-255 with the bit order reversed.") (DEFVAR *EXPAND-BY-3-TABLE* (MAKE-ARRAY 256 :ELEMENT-TYPE 'T) "The binary patterns of 0-255 with each bit tripled.") (DEFVAR *WYSIWYG-DEFAULT* () "Print everything using wysiwyg fonts if T.") (DEFVAR *PARALLEL-PORT-NOT-RESET-SINCE-BOOT* T "Turned off the first time the parallel port is reset.") ;;; ********************************************************************************* ;;; ;;; The Imagen Font Descriptor ;;; ;;; ********************************************************************************* ;;; (DEFSTRUCT (IMAGEN-FONT (:CONC-NAME NIL) (:CALLABLE-CONSTRUCTORS NIL) (:ALTERANT ALTER-IMAGEN-FONT) (:PREDICATE NIL) (:COPIER NIL) (:TYPE :NAMED-ARRAY-LEADER)) IMAGEN-FONT-NAME; Name of loadable Imagen font file ; or printer-resident Imagen font. LISP-FONT-NAME; Name of corresponding Lisp font ; (NIL or T if printer-resident). IMAGEN-FAMILY; Font's Imagen family-number. SPACE-SIZE; Pixel-width of a good looking space. INTERLINE-SPACING; Pixels between baselines. DESIGN-SIZE; Points to which the font was designed. MAGNIFICATION; (SEND-GLYPH-TO-IMAGEN; T iff glyph must be downloaded to printer. (MAKE-ARRAY 128 :ELEMENT-TYPE 'BIT)); * (CHAR-WIDTH; Width of I-th character in pixels. (MAKE-ARRAY 128 :ELEMENT-TYPE '(UNSIGNED-BYTE 8))); * (GLYPH-MAP (MAKE-ARRAY 128))) ; Bit-map for each glyph in this font. ;;; ********************************************************************************* ;;; ;;; The basic Imagen-printer flavor ;;; ;;; ********************************************************************************* ;;; (defflavor PRINTER::IMAGEN-PRINTER ((OUTPUT-STRING (MAKE-ARRAY 200 :TYPE 'ART-8B :FILL-POINTER 0)) (USERNAME USER-ID); Should always be correct. (FILENAME "SCREEN"); Default if nothing explicitly set. (PRINT-HEADER-PAGE-P NIL); Print the job header page iff T. (DOCUMENT-STRING-ALREADY-SENT-P T); Don't send it again if T. (LAST-CHAR #\PAGE); The character last sent to the Imagen. (ROTATED-PAGE-IMAGE NIL); True if landscape page image. TRUE-PRINT-STREAM; Save "printer-stream" here while buffering to a file. (PAGE-START-LIST NIL); List of positions of pages in buffered raw file. (CURRENT-FONT-FAMILY -1); The Imagen font family # currently in use. (CURRENT-FONT-DESCRIPTOR NIL); Descriptor for current font family. (HORIZONTAL-POSITION 0); Horizontal pixel where next character goes. (VERTICAL-POSITION 0); Vertical pixel where next line goes. (START-OF-TEXT 0); Vertical pixel where printing begins (top-of-form). (ADVANCE-HEIGHT 0); # of pixels between baselines. (TAB-WIDTH-PIXELS 0); # of pixels to advance per tab stop. (FONT-NUMBER-MAP; I-th entry is Imagen font-family # corresponding to (MAKE-ARRAY 5 :FILL-POINTER 0)); Zmacs font # "I". (PREVIOUS-FONTS NIL); A list of fonts previously used. (WYSIWYG-P NIL); Always Imagenize Lisp fonts if T. (NCOPIES 1); # of copies of this file to print. ) (PRINTER::BASIC-PRINTER); Base flavors. :SETTABLE-INSTANCE-VARIABLES :GETTABLE-INSTANCE-VARIABLES) ;;; ;;; Externally referenced methods of this flavor... ;;; ;;; :print-bitmap ;;; :screen-image-file-p ;;; :print-raw-file ;;; :print-text-file ;;; :setup-normal-mode ;;; :cr ;;; ;;; ********************************************************************************* ;;; ;;; Constructors of our translation tables ;;; ;;; ********************************************************************************* ;;; (DEFUN BUILD-EXPAND-BY-2-TABLE (&AUX INBIT OUTVALUE) "Build a 256-entry art-16b array, the i-th entry of which contains the binary value of i with each bit repeated twice." (DECLARE (SPECIAL *EXPAND-BY-2-TABLE*)) (DOTIMES (I 256) (SETQ OUTVALUE 0) (DOTIMES (J 8) (SETQ INBIT (LDB (BYTE 1 (- 7 J)) I)) (SETQ OUTVALUE (+ (LSH OUTVALUE 2) (LSH INBIT 1) INBIT))) (SETF (AREF *EXPAND-BY-2-TABLE* I) OUTVALUE))) (DEFUN BUILD-EXPAND-BY-3-TABLE (&AUX INBIT OUTVALUE) "Build a 256-entry art-q array, the i-th entry of which contains the binary value of i with each bit repeated thrice." (DECLARE (SPECIAL *EXPAND-BY-3-TABLE*)) (DOTIMES (I 256) (SETQ OUTVALUE 0) (DOTIMES (J 8) (SETQ INBIT (LDB (BYTE 1 (- 7 J)) I)) (SETQ OUTVALUE (+ (LSH OUTVALUE 3) (LSH INBIT 2) (LSH INBIT 1) INBIT))) (SETF (AREF *EXPAND-BY-3-TABLE* I) OUTVALUE))) (DEFUN BUILD-FLIPPED-BITS-TABLE (&AUX OUTVALUE) "Build a 256-entry art-8b table, the i-th entry of which contains the binary value of i with the bits reversed." (DECLARE (SPECIAL *FLIPPED-BITS-TABLE*)) (DOTIMES (I 256) (SETQ OUTVALUE 0) (DOTIMES (J 8) (SETQ OUTVALUE (DPB (LDB (BYTE 1 J) I) (BYTE 1 (- 7 J)) OUTVALUE))) (SETF (AREF *FLIPPED-BITS-TABLE* I) OUTVALUE))) ;;; ********************************************************************************* ;;; ;;; Document start & finish ;;; ;;; ********************************************************************************* ;;; (DEFMETHOD (PRINTER::IMAGEN-PRINTER :AFTER :INIT) (IGNORE) "Start the table of fonts in-use with COUR12, the page-heading font." (DECLARE (SPECIAL IMAGEN-FONTS::COUR12)) (VECTOR-PUSH IMAGEN-FONTS::COUR12 FONT-NUMBER-MAP) (SETF (IMAGEN-FAMILY IMAGEN-FONTS::COUR12) 1)) (DEFMETHOD (PRINTER::IMAGEN-PRINTER :SETUP-NORMAL-MODE) () ()) (DEFMETHOD (PRINTER::IMAGEN-PRINTER :START-DOCUMENT) (FILE-NAME USER-NAME N-COPIES-TO-PRINT) "Accepts the server's file name, user name, and # of copies to print." (SETQ FILENAME FILE-NAME) (SETQ PRINT-HEADER-PAGE-P FILE-NAME); NIL if no header page to be printed... (SETQ USERNAME USER-NAME) (SETQ NCOPIES N-COPIES-TO-PRINT) (SETQ DOCUMENT-STRING-ALREADY-SENT-P ())) (DEFMETHOD (PRINTER::IMAGEN-PRINTER :END-DOCUMENT) () (SETQ DOCUMENT-STRING-ALREADY-SENT-P T)) (DEFMETHOD (PRINTER::IMAGEN-PRINTER :START-IMAGEN-DOCUMENT) () "Send the Imagen the strings that define a new document to it." (UNLESS DOCUMENT-STRING-ALREADY-SENT-P (SEND SELF :STRING-OUT-RAW (STRING-APPEND "@document(language IMPRESS, jobheader " (IF PRINT-HEADER-PAGE-P "on" "off") ", " (FORMAT () "owner \"~A\"" USERNAME) ", " (FORMAT () "printed-on \"~A\"" PRINTER::CURRENT-TIME) ", " (FORMAT () "name \"~A\"" FILENAME) (FORMAT () "~@[, created \"~A\"~])" (IF (TYPEP FILENAME 'PATHNAME) (TIME:PRINT-UNIVERSAL-TIME (GET (SEND FILENAME :PROPERTIES) :CREATION-DATE) ()))))) (SEND SELF :DOWNLOAD-GLYPHS); Download all needed glyphs. (SETQ DOCUMENT-STRING-ALREADY-SENT-P T))) (DEFMETHOD (PRINTER::IMAGEN-PRINTER :FINISH-IMAGEN-DOCUMENT) () (SEND PRINTER::PRINTER-STREAM :TYO 4) (SETQ DOCUMENT-STRING-ALREADY-SENT-P ())) (DEFMETHOD (PRINTER::IMAGEN-PRINTER :SCREEN-IMAGE-FILE-P) (FILE-NAME) (LET ((FILE-TYPE (SEND FILE-NAME :TYPE))) (OR (EQUAL "IMAGEN" FILE-TYPE) (EQUAL "IMG" FILE-TYPE) ;08-18-88 DAB ))) (DEFMETHOD (PRINTER::IMAGEN-PRINTER :PRINTS-MULTIPLE-COPIES-P) () "Tells the server we want to handle multiple-copy prints internally." T) ;;; ********************************************************************************* ;;; ;;; Our :print-bitmap method ;;; ;;; ********************************************************************************* ;;; (DEFMETHOD (PRINTER::IMAGEN-PRINTER :PRINT-BITMAP) (BITMAP-ARRAY &OPTIONAL WIDTH HEIGHT (START-X 0) (START-Y 0) (ROTATION NIL) IGNORE &AUX MAGNIFICATION POWER-OF-TWO (MAXIMUM-MAGNIFICATION 6)) "Copy the bitmap array to an Imagen print stream. Since the Imagen printer can only process an area whose dimensions are a multiple of 32 pixels, we must fill out the data given the Imagen with zero bits to the next multiple of 32 bits in both directions." (IF (NULL width) (SETQ width (array-dimension bitmap-array 1))) (IF (NULL height) (SETQ height (array-dimension bitmap-array 0))) (DOTIMES (COPY NCOPIES) (SEND SELF :START-IMAGEN-DOCUMENT) ;; Put on a page heading if that's wise... ;; (IF printer:page-heading ;; (SEND self :print-page-heading)) ;; Calculate magnification, top/bottom margins, and left/right margines based on rotation and the ;; size of the area to be printed... (COND ((IF (SYMBOLP ROTATION) (EQ ROTATION :LANDSCAPE) ROTATION) (SETQ MAGNIFICATION (MIN MAXIMUM-MAGNIFICATION (FLOOR *PRINTABLE-PIXELS-ACROSS-A-PAGE* HEIGHT) (FLOOR *PRINTABLE-PIXELS-DOWN-A-PAGE* WIDTH))) (SEND SELF :STRING-OUT-RAW (STRING-APPEND (IMPRESS-SET-HV-SYSTEM :ORIGIN 2 ; top-left origin after rotation. :AXES 2 ; clockwise axes. :ORIENTATION 5) ; Rotate 90 degress. (IMPRESS-SET-ABS-H :NEW-H (+ 30 (QUOTIENT (- *PRINTABLE-PIXELS-DOWN-A-PAGE* (* MAGNIFICATION WIDTH)) 2))) (IMPRESS-SET-ABS-V :NEW-V (+ 144 (QUOTIENT (- *PRINTABLE-PIXELS-ACROSS-A-PAGE* (* MAGNIFICATION HEIGHT)) 2)))))) (T (SETQ MAGNIFICATION (MIN MAXIMUM-MAGNIFICATION (FLOOR *PRINTABLE-PIXELS-DOWN-A-PAGE* HEIGHT) (FLOOR *PRINTABLE-PIXELS-ACROSS-A-PAGE* WIDTH))) (SEND SELF :STRING-OUT-RAW (STRING-APPEND (IMPRESS-SET-ABS-H :NEW-H (QUOTIENT (- *PRINTABLE-PIXELS-ACROSS-A-PAGE* (* MAGNIFICATION WIDTH)) 2)) (IMPRESS-SET-ABS-V :NEW-V (QUOTIENT (- *PRINTABLE-PIXELS-DOWN-A-PAGE* (* MAGNIFICATION HEIGHT)) 2)))))) (COND ((SETQ POWER-OF-TWO ; If the magnification can be done (NTH MAGNIFICATION (LIST () 0 1 () 2))) ; by the Imagen, (SEND SELF :STRING-OUT-RAW ; tell the Imagen to do it (IMPRESS-SET-MAGNIFICATION :POWER POWER-OF-TWO)) (IF (AND (ZEROP (REM START-X 8)) ; then send the bitmap. (ZEROP (REM WIDTH 8))) (OUTPUT-ALIGNED-BITMAP-TO-PRINTER BITMAP-ARRAY HEIGHT WIDTH START-X START-Y) (OUTPUT-UNALIGNED-BITMAP-TO-PRINTER BITMAP-ARRAY HEIGHT WIDTH START-X START-Y))) (T ; Otherwise, we do the magnification. (OUTPUT-MAGNIFIED-BITMAP-TO-PRINTER BITMAP-ARRAY HEIGHT WIDTH START-X START-Y MAGNIFICATION)));; ;; Terminate the document with an End-of-Document command... ;; (SEND SELF :FINISH-IMAGEN-DOCUMENT))) ;;; ********************************************************************************* ;;; ;;; Output a not-byte-aligned bitmap ;;; ;;; ********************************************************************************* ;;; (DEFUN OUTPUT-UNALIGNED-BITMAP-TO-PRINTER (BITMAP-ARRAY HEIGHT WIDTH START-X START-Y &AUX (IMAGEN-HEIGHT (CEILING HEIGHT 32)) (IMAGEN-WIDTH (CEILING WIDTH 32))) (DECLARE (:SELF-FLAVOR PRINTER::IMAGEN-PRINTER)) ;; ;; Send out the BITMAP command and its initial arguments... ;; (SEND SELF :STRING-OUT-RAW (IMPRESS-BITMAP :OPERATION-TYPE 7 ; "OR" operation. :HSIZE IMAGEN-WIDTH ; # of patches wide. :VSIZE IMAGEN-HEIGHT)) ; # of patches high. ;; ;; Actually output the bitmap to the printer... ;; (LOOP FOR I FROM 0 TO (1- (* 32 IMAGEN-HEIGHT)) BY 32 DO (LOOP FOR J FROM 0 TO (1- (* 32 IMAGEN-WIDTH)) BY 32 DO ;; Build a 1024-bit "patch" (SETF (FILL-POINTER OUTPUT-STRING) 0) (LOOP FOR K FROM 0 TO 31 BY 1 DO (LOOP FOR L FROM 0 TO 31 BY 8 DO (VECTOR-PUSH (LOOP FOR M FROM 0 TO 7 SUMMING (LSH (IF (AND (< (+ I K) HEIGHT) (< (+ J L M) WIDTH)) (AREF BITMAP-ARRAY (+ START-Y I K) (+ START-X J L M)) 0) (- 7 M))) OUTPUT-STRING))) ;; Send the 1024-bit "patch". (SEND SELF :STRING-OUT-RAW OUTPUT-STRING)))) ;;; ********************************************************************************* ;;; ;;; Output a byte-aligned bitmap ;;; ;;; ********************************************************************************* ;;; (DEFUN OUTPUT-ALIGNED-BITMAP-TO-PRINTER (BITMAP-ARRAY HEIGHT WIDTH START-X START-Y &AUX (BITMAP-ARRAY8 (MAKE-ARRAY (LIST (ARRAY-DIMENSION BITMAP-ARRAY 0) (QUOTIENT (ARRAY-DIMENSION BITMAP-ARRAY 1) 8)) :ELEMENT-TYPE '(UNSIGNED-BYTE 8) :DISPLACED-TO BITMAP-ARRAY)) (START-X8 (QUOTIENT START-X 8)) (WIDTH-8 (QUOTIENT WIDTH 8)) (IMAGEN-HEIGHT (CEILING HEIGHT 32)) (IMAGEN-WIDTH (CEILING WIDTH 32))) (DECLARE (:SELF-FLAVOR PRINTER::IMAGEN-PRINTER)) ;; ;; Send out the BITMAP command and its initial arguments... ;; (SEND SELF :STRING-OUT-RAW (IMPRESS-BITMAP :OPERATION-TYPE 7 ; "OR" operation. :HSIZE IMAGEN-WIDTH ; # of patches wide. :VSIZE IMAGEN-HEIGHT)) ; # of patches high. ;; ;; Actually output the bitmap to the printer... ;; (LOOP FOR I FROM 0 TO (1- (* 32 IMAGEN-HEIGHT)) BY 32 DO (LOOP FOR J FROM 0 TO (1- (* 4 IMAGEN-WIDTH)) BY 4 DO ;; Build a 1024-bit (32 x 32) "patch"... (SETF (FILL-POINTER OUTPUT-STRING) 0) (LOOP FOR K FROM 0 TO 31 BY 1 DO (LOOP FOR L FROM 0 TO 3 BY 1 DO (VECTOR-PUSH (AREF *FLIPPED-BITS-TABLE* (IF (AND (< (+ I K) HEIGHT) (< (+ J L) WIDTH-8)) (AREF BITMAP-ARRAY8 (+ START-Y I K) (+ START-X8 J L)) 0)) OUTPUT-STRING))) ;; Send the 1024-bit "patch" we just built... (SEND SELF :STRING-OUT-RAW OUTPUT-STRING)))) ;;; ********************************************************************************* ;;; ;;; Magnification of any image ;;; ;;; ********************************************************************************* ;;; (DEFUN output-magnified-bitmap-to-printer (bitmap-array height width start-x start-y magnification &AUX source-bit (magnified-height (* height magnification)) (magnified-width (* width magnification)) magnified-bitmap-height magnified-bitmap-width) (DECLARE (:self-flavor printer:imagen-printer)) (SETQ magnified-bitmap-height (* 32 (CEILING magnified-height 32))) (SETQ magnified-bitmap-width (* 32 (CEILING magnified-width 32))) (USING-RESOURCE (magnified-bitmap-array printer:screen-image-bit-array magnified-bitmap-width magnified-bitmap-height) ;; RDA:- First, zero out the entire magnified bitmap array... (BITBLT tv:alu-setz (ARRAY-DIMENSION magnified-bitmap-array 1) ;06-01-88 (ARRAY-DIMENSION magnified-bitmap-array 0) magnified-bitmap-array 0 0 magnified-bitmap-array 0 0) ;; Then build a magnified version of the given array... ;; RDA:- move two "+"s out of the loop. (LOOP FOR i FROM start-y TO (+ start-y -1 height) ;RDA:-06-01-88 AND iii FROM 0 TO (1- magnified-height) BY magnification DO (LOOP FOR j FROM start-x TO (+ start-x -1 width) ;RDA:-06-01-88 AND jjj FROM 0 TO (1- magnified-width) BY magnification DO (SETQ source-bit (AREF bitmap-array i j)) ;RDA:-06-01-88 ;; RDA:- Since we've zero'ed the array, only do this if we need to. (unless (zerop source-bit) (DOTIMES (ii magnification) (DOTIMES (jj magnification) (SETF (AREF MAGNIFIED-BITMAP-ARRAY (+ III II) (+ JJJ JJ)) SOURCE-BIT) ))))) ;; Finally, actually output the bitmap to the printer... (output-aligned-bitmap-to-printer magnified-bitmap-array magnified-bitmap-height magnified-bitmap-width 0 0))) ;;; ********************************************************************************* ;;; ;;; Make an Imagen font descriptor from a FED font descriptor ;;; ;;; ********************************************************************************* ;;; (DEFUN FONT-DESCRIPTOR-INTO-IMAGEN-FONT (FONTNAME &AUX FED-FD IMAGEN-FD TOP-MARGIN BOTTOM-MARGIN LEFT-MARGIN RIGHT-MARGIN (BGLY-STRING NIL) BYTE BGLY-HEIGHT BGLY-WIDTH RASTER-HEIGHT RASTER-WIDTH) "Create and return an Imagen font-descriptor containing the data from the font descriptor associated with the font name FONTNAME." (OR (SYMBOLP FONTNAME) (SETQ FONTNAME (TV:FONT-NAME FONTNAME))) (SETQ FED-FD (GET FONTNAME 'FED::FONT-DESCRIPTOR)) (IF (NULL FED-FD) (FERROR () "~A has no font descriptor." (STRING-UPCASE FONTNAME))) (SETQ IMAGEN-FD (MAKE-IMAGEN-FONT :IMAGEN-FONT-NAME (SUBSTRING-AFTER-CHAR #\- (STRING (FED::FD-NAME FED-FD))) :SPACE-SIZE (FED::FD-SPACE-WIDTH FED-FD) :INTERLINE-SPACING (CEILING (* 11 (FED::FD-LINE-SPACING FED-FD)) 10))) (DOTIMES (CHAR-CODE 128) ;; Ignore unspecified characters and SPACE... (UNLESS (OR (NULL (AREF FED-FD CHAR-CODE)) (eql (int-char CHAR-CODE) #\SPACE)) ;; Make the Imagen descriptor's character width that used by the Explorer... (SETF (AREF (CHAR-WIDTH IMAGEN-FD) CHAR-CODE) (FED::CD-CHAR-WIDTH (AREF FED-FD CHAR-CODE))) ;; Get the height & width of the Explorer's bitmap for this character... (SETQ RASTER-HEIGHT (ARRAY-DIMENSION (AREF FED-FD CHAR-CODE) 0)) (SETQ RASTER-WIDTH (ARRAY-DIMENSION (AREF FED-FD CHAR-CODE) 1)) ;; Find the first non-zero pixel coming into the Explorer's bitmap from ;; all 4 directions... (SETQ TOP-MARGIN (BLOCK OUTER (DO ((I 0 (1+ I))) ((>= I RASTER-HEIGHT) 0) (DOTIMES (J RASTER-WIDTH) (IF (NOT (ZEROP (AREF (AREF FED-FD CHAR-CODE) I J))) (RETURN-FROM OUTER I)))))) (SETQ BOTTOM-MARGIN (BLOCK OUTER (DO ((I 0 (1+ I))) ((>= I RASTER-HEIGHT) 0) (DOTIMES (J RASTER-WIDTH) (IF (NOT (ZEROP (AREF (AREF FED-FD CHAR-CODE) (- RASTER-HEIGHT I 1) J))) (RETURN-FROM OUTER I)))))) (SETQ LEFT-MARGIN (BLOCK OUTER (DO ((J 0 (1+ J))) ((>= J RASTER-WIDTH) 0) (DOTIMES (I RASTER-HEIGHT) (IF (NOT (ZEROP (AREF (AREF FED-FD CHAR-CODE) I J))) (RETURN-FROM OUTER J)))))) (SETQ RIGHT-MARGIN (BLOCK OUTER (DO ((J 0 (1+ J))) ((>= J RASTER-WIDTH) 0) (DOTIMES (I RASTER-HEIGHT) (IF (NOT (ZEROP (AREF (AREF FED-FD CHAR-CODE) I (- RASTER-WIDTH J 1)))) (RETURN-FROM OUTER J)))))) ;; Calculate the height & width of the Imagen bitmap... (SETQ BGLY-HEIGHT (- RASTER-HEIGHT TOP-MARGIN BOTTOM-MARGIN)) (SETQ BGLY-WIDTH (- RASTER-WIDTH LEFT-MARGIN RIGHT-MARGIN)) ;; Create the Imagen bgly header for this character... (SETQ BGLY-STRING (STRING-NCONC (MAKE-ARRAY 10 :ELEMENT-TYPE '(UNSIGNED-BYTE 8) :FILL-POINTER 0) (IMPRESS-OUTPUT-16 ; Advance width. (AREF (CHAR-WIDTH IMAGEN-FD) CHAR-CODE)) (IMPRESS-OUTPUT-16 BGLY-WIDTH) ; Character-box width. (IMPRESS-OUTPUT-16 ; Left-offset. (- (FED::CD-CHAR-LEFT-KERN (AREF FED-FD CHAR-CODE)) LEFT-MARGIN)) (IMPRESS-OUTPUT-16 BGLY-HEIGHT) ; Character-box height. (IMPRESS-OUTPUT-16 ; Top-offset. (- (FED::FD-BASELINE FED-FD) TOP-MARGIN)))) ;; Append the Imagen bitmap... (DOTIMES (I BGLY-HEIGHT) (DOTIMES (J (CEILING BGLY-WIDTH 8)) (SETQ BYTE 0) (DOTIMES (K 8) (SETQ BYTE (+ BYTE (IF (>= (+ (* 8 J) K) BGLY-WIDTH) 0 (LSH (AREF (AREF FED-FD CHAR-CODE) (+ TOP-MARGIN I) (+ LEFT-MARGIN (* 8 J) K)) (- 7 K)))))) (VECTOR-PUSH-EXTEND BYTE BGLY-STRING))) ;; Put the completed bgly string into the font descriptor... (SETF (AREF (GLYPH-MAP IMAGEN-FD) CHAR-CODE) BGLY-STRING))) ;; Make sure #\SP's width and the font's space-width agree... (SETF (AREF (CHAR-WIDTH IMAGEN-FD) #\SPACE) (SPACE-SIZE IMAGEN-FD)) IMAGEN-FD) ;;; ********************************************************************************* ;;; ;;; Create a FED font descriptor for a font N-times the size of a given one ;;; ;;; ********************************************************************************* ;;; (DEFUN EXPAND-FONT-DESCRIPTOR (FD EXPANSION-FACTOR &OPTIONAL NEW-NAME &AUX LEN NFD) "Given font-descriptor FD, make a new one whose characters are taller and wider by EXPANSION-FACTOR. This must be an integer. NEW-NAME specifies the name to give the new font-descriptor; the new font descriptor is returned, and the new name is not actually defined." (IF (STRINGP NEW-NAME) (SETQ NEW-NAME (INTERN (STRING-UPCASE NEW-NAME) 'FONTS))) (SETQ LEN (ARRAY-ACTIVE-LENGTH FD) NFD (FED::MAKE-FONT-DESCRIPTOR :MAKE-ARRAY (:TYPE 'ART-Q :LENGTH LEN) FED::FD-FILL-POINTER (FED::FD-FILL-POINTER FD) FED::FD-NAME NEW-NAME FED::FD-LINE-SPACING (* EXPANSION-FACTOR (FED::FD-LINE-SPACING FD)) FED::FD-BASELINE (* EXPANSION-FACTOR (FED::FD-BASELINE FD)) FED::FD-BLINKER-HEIGHT (* EXPANSION-FACTOR (FED::FD-BLINKER-HEIGHT FD)) FED::FD-BLINKER-WIDTH (* EXPANSION-FACTOR (FED::FD-BLINKER-WIDTH FD)) FED::FD-SPACE-WIDTH (* EXPANSION-FACTOR (FED::FD-SPACE-WIDTH FD)))) (DO ((I 0 (1+ I)) (CD) (NCD)) ((>= I LEN)) (AND (SETQ CD (AREF FD I)) (LET* ((OLD-WIDTH (ARRAY-DIMENSION CD 1)) (OLD-HEIGHT (ARRAY-DIMENSION CD 0)) (NEW-WIDTH (* EXPANSION-FACTOR OLD-WIDTH)) (NEW-HEIGHT (* EXPANSION-FACTOR OLD-HEIGHT)) NEW-I NEW-J OLD-VALUE) (SETQ NCD (FED::MAKE-CHAR-DESCRIPTOR :MAKE-ARRAY (:TYPE 'ART-4B :LENGTH (LIST NEW-HEIGHT NEW-WIDTH)) FED::CD-CHAR-WIDTH (* EXPANSION-FACTOR (FED::CD-CHAR-WIDTH CD)) FED::CD-CHAR-LEFT-KERN (* EXPANSION-FACTOR (FED::CD-CHAR-LEFT-KERN CD)))) (COPY-ARRAY-CONTENTS CD NCD) (SETQ NEW-J (- EXPANSION-FACTOR)) (DOTIMES (J OLD-HEIGHT) (SETQ NEW-J (+ EXPANSION-FACTOR NEW-J)) (SETQ NEW-I (- EXPANSION-FACTOR)) (DOTIMES (I OLD-WIDTH) (SETQ NEW-I (+ EXPANSION-FACTOR NEW-I)) (SETQ OLD-VALUE (AREF CD J I)) (DOTIMES (JJ EXPANSION-FACTOR) (DOTIMES (II EXPANSION-FACTOR) (SETF (AREF NCD (+ NEW-J JJ) (+ NEW-I II)) OLD-VALUE))))) (SETF (AREF NFD I) NCD)))) NFD) ;;; ********************************************************************************* ;;; ;;; Process a list of font names ;;; ;;; ********************************************************************************* ;;; (DEFUN SETUP-IMAGEN-FONTS (FONT-LIST) "Loads the Imagen font descriptors corresponding to the Lisp fonts named in font-list." (DECLARE (:SELF-FLAVOR PRINTER::IMAGEN-PRINTER)) ;; ;; Process each font in the font list... ;; (UNLESS (NULL (FIRST FONT-LIST)); Nothing to do if no fonts... (LOOP FOR FONT-NAME IN FONT-LIST WITH (LISP-FONT IMAGEN-FONT IMAGEN-FED-FONT) DO ;; ;; Get the name of the corresponding Imagen font. If specified font cannot be recognized as ;; a Lisp font, try to recognize it as an Imagen font. If both fail, create an Imagen font ;; descriptor for a 3x enlarged version of the specified Lisp machine font... ;; (SETQ FONT-NAME (STRING-UPCASE (STRING FONT-NAME))) (SETQ LISP-FONT (FIND-SYMBOL FONT-NAME 'FONTS)) (SETQ IMAGEN-FONT (FIND-SYMBOL FONT-NAME 'IMAGEN-FONTS)) ;; If there is neither an Explorer font nor an Imagen font loaded named FONT-NAME, ;; check for files defining either. If either is found, then load that file, otherwise complain ;; and abort... (UNLESS (OR LISP-FONT IMAGEN-FONT) (COND ((PROBE-FILE (MAKE-PATHNAME :HOST "SYS" :DIRECTORY "FONTS" :NAME FONT-NAME :TYPE "XLD")) (FASLOAD (MAKE-PATHNAME :HOST "SYS" :DIRECTORY "FONTS" :NAME FONT-NAME :TYPE "XLD") 'FONTS T) (SETQ LISP-FONT (FIND-SYMBOL FONT-NAME 'FONTS))) ((PROBE-FILE (MAKE-PATHNAME :HOST *IMAGEN-FONT-DIRECTORY-HOST-NAME* :DIRECTORY *IMAGEN-FONT-DIRECTORY-NAME* :NAME FONT-NAME :TYPE "XLD")) (FASLOAD (MAKE-PATHNAME :HOST *IMAGEN-FONT-DIRECTORY-HOST-NAME* :DIRECTORY *IMAGEN-FONT-DIRECTORY-NAME* :NAME FONT-NAME :TYPE "XLD") 'IMAGEN-FONTS T) (SETQ IMAGEN-FONT (FIND-SYMBOL FONT-NAME 'IMAGEN-FONTS)) ;; A non-NIL/non-T lisp-font-name causes download of Imagen font descriptor (SETF (LISP-FONT-NAME (SYMBOL-VALUE IMAGEN-FONT)) 1)) (T ;;else (FERROR () "~A is neither a good Explorer font name nor a good Imagen font name." FONT-NAME)))) ;; If FONT-NAME now specifies a good Lisp font, try to use the associated Imagen font... (WHEN (AND LISP-FONT (SYMBOLP LISP-FONT) (BOUNDP LISP-FONT) (TYPEP (SYMBOL-VALUE LISP-FONT) 'FONT)) (SETQ IMAGEN-FONT (GET LISP-FONT 'FED::IMAGEN-FONT)) ;; If there is no associated Imagen font, look for a WYSIWYG image... (WHEN (OR WYSIWYG-P (NULL IMAGEN-FONT)) (SETQ IMAGEN-FONT (GET LISP-FONT 'FED::IMAGEN-WYSIWYG-FONT)) ;; If no WYSIWYG image exists, create one... (WHEN (NULL IMAGEN-FONT) (SETQ IMAGEN-FONT (INTERN (STRING-APPEND "EXP-" FONT-NAME) 'IMAGEN-FONTS)) (SETQ IMAGEN-FED-FONT (INTERN (STRING-APPEND "IMAGEN-" FONT-NAME) 'FONTS)) (SETF (GET IMAGEN-FED-FONT 'FED::FONT-DESCRIPTOR) (EXPAND-FONT-DESCRIPTOR (FED::FONT-NAME-FONT-DESCRIPTOR LISP-FONT) 3 IMAGEN-FED-FONT)) (SET IMAGEN-FONT (FONT-DESCRIPTOR-INTO-IMAGEN-FONT IMAGEN-FED-FONT)) (SETF (LISP-FONT-NAME (SYMBOL-VALUE IMAGEN-FONT)) (STRING LISP-FONT))) ;; Link the LISP-FONT & this WYSIWYG Imagen font by properties... (SETF (GET IMAGEN-FONT 'LISP-FONT) LISP-FONT) (SETF (GET LISP-FONT 'FED::IMAGEN-WYSIWYG-FONT) IMAGEN-FONT))) ;; If FONT-NAME now specifies a good Imagen font, but it has no descriptor, load one... (WHEN (AND IMAGEN-FONT (NULL (BOUNDP IMAGEN-FONT))) (FASLOAD (MAKE-PATHNAME :HOST *IMAGEN-FONT-DIRECTORY-HOST-NAME* :DIRECTORY *IMAGEN-FONT-DIRECTORY-NAME* :NAME (STRING IMAGEN-FONT)) 'IMAGEN T) ;; Associate the Imagen descriptor with the Lisp font so it''ll get downloaded... (SETF (LISP-FONT-NAME (SYMBOL-VALUE IMAGEN-FONT)) (STRING LISP-FONT))) ;; ;; Initialize the selected Imagen font descriptor for this file... ;; (SETF (IMAGEN-FAMILY (SYMBOL-VALUE IMAGEN-FONT)) (1+ (FILL-POINTER FONT-NUMBER-MAP))) (ARRAY-INITIALIZE (SEND-GLYPH-TO-IMAGEN (SYMBOL-VALUE IMAGEN-FONT)) 0) (VECTOR-PUSH-EXTEND (SYMBOL-VALUE IMAGEN-FONT) FONT-NUMBER-MAP))) ;; ;; Calculate this document's advance height = maximum interline spacing of fonts used... ;; (SETQ ADVANCE-HEIGHT (LOOP FOR FONT-NUMBER FROM 0 TO (1- (FILL-POINTER FONT-NUMBER-MAP)) MAXIMIZE (INTERLINE-SPACING (AREF FONT-NUMBER-MAP FONT-NUMBER)))) (SETQ PREVIOUS-FONTS ()); Erase any history of previously used fonts. (SEND SELF :SET-CURRENT-FONT-FAMILY #\0)) ;;; ********************************************************************************* ;;; ;;; ********************************************************************************* ;;; (DEFMETHOD (PRINTER::IMAGEN-PRINTER :CHECK-PRINTABILITY) (CHAR) "Returns NIL unless the specified character char is printable in the current font family. Sets the char's send-glyph-to-imagen flag to '1' to force downloading if downloadable." (COND ;; Anything over 127. is unprintable. ((< 127 CHAR) NIL) ;; Pure printer-resident fonts can print anything... ((NULL (LISP-FONT-NAME CURRENT-FONT-DESCRIPTOR)) T) ;; Mixed downloaded/printer resident fonts can print anything but mark glyph for download if it exists... ((EQ (LISP-FONT-NAME CURRENT-FONT-DESCRIPTOR) T) (IF (AREF (GLYPH-MAP CURRENT-FONT-DESCRIPTOR) CHAR) (SETF (AREF (SEND-GLYPH-TO-IMAGEN CURRENT-FONT-DESCRIPTOR) CHAR) 1)) T) ;; "Space" is always printable... ((eql (int-char CHAR) #\SPACE) T) ;; If a glyph exists for this character in the current font, then ;; mark it for later download... ((AREF (GLYPH-MAP CURRENT-FONT-DESCRIPTOR) CHAR) (SETF (AREF (SEND-GLYPH-TO-IMAGEN CURRENT-FONT-DESCRIPTOR) CHAR) 1)))) (DEFMETHOD (PRINTER::IMAGEN-PRINTER :SET-CURRENT-FONT-FAMILY) (IN-CHAR &AUX (LAST-FONT-DESCRIPTOR CURRENT-FONT-DESCRIPTOR) (VALUE T)) "Handles changes in the current font per the value of in-char. Returns NIL if the character following the epsilon was not a valid font specifier." (DECLARE (SPECIAL IMAGEN-FONTS::COUR10)) (COND ;; Set to Nth Zmacs font if in-char is N<26 characters beyond #/0... ((<= #\0 (int-char IN-CHAR) #\K) (SETQ PREVIOUS-FONTS (CONS CURRENT-FONT-DESCRIPTOR PREVIOUS-FONTS)) ;; Force font changes to fonts beyond the # of fonts specified to the last one specified... (SETQ CURRENT-FONT-DESCRIPTOR (AREF FONT-NUMBER-MAP (MIN (1+ (- IN-CHAR #\0)) (1- (FILL-POINTER FONT-NUMBER-MAP))))) ;; Truncate previous font history if it is getting too long... (IF (> (LENGTH PREVIOUS-FONTS) 20) (SETQ PREVIOUS-FONTS (FIRSTN 10 PREVIOUS-FONTS)))) ;; Set to font previously in effect if in-char is #/*... ((eql (int-char IN-CHAR) #\*) (SETQ CURRENT-FONT-DESCRIPTOR (FIRST PREVIOUS-FONTS)) (SETQ PREVIOUS-FONTS (REST PREVIOUS-FONTS))) ;; Return NIL if IN-CHAR not a legal font specifier... (T (SETQ VALUE ()))) ;; Use user's initial font if unable to select one from in-char... (IF (NULL CURRENT-FONT-DESCRIPTOR) (SETQ CURRENT-FONT-DESCRIPTOR (AREF FONT-NUMBER-MAP 1))) ;; Make sure the daemon's state and the printer's state agree... (UNLESS (EQ CURRENT-FONT-DESCRIPTOR LAST-FONT-DESCRIPTOR) (SETQ TAB-WIDTH-PIXELS (* printer:TAB-width (SPACE-SIZE CURRENT-FONT-DESCRIPTOR))) ; DAB 01-25-89 (SEND SELF :SWITCH-PRINTER-TO-FONT CURRENT-FONT-DESCRIPTOR)) VALUE) (DEFMETHOD (PRINTER::IMAGEN-PRINTER :DOWNLOAD-GLYPHS) () "Downloads all glyphs used in this file before printing pages in page-reversed order." (LOOP FOR FONT-NUMBER FROM 0 TO (1- (FILL-POINTER FONT-NUMBER-MAP)) DO (LET ((DESCRIPTOR (AREF FONT-NUMBER-MAP FONT-NUMBER))) ;; If not a pure printer-resident font, download the glyphs... (IF (LISP-FONT-NAME DESCRIPTOR) (LOOP FOR CHARACTER-CODE FROM 0 TO 127 DO (UNLESS (ZEROP (AREF (SEND-GLYPH-TO-IMAGEN DESCRIPTOR) CHARACTER-CODE)) (SEND SELF :STRING-OUT-RAW (IMPRESS-BGLY-PREFIX :FAMILY (IMAGEN-FAMILY DESCRIPTOR) :MEMBER CHARACTER-CODE)) (SEND SELF :STRING-OUT-RAW (AREF (GLYPH-MAP DESCRIPTOR) CHARACTER-CODE))))) ;; Otherwise, declare a family table for this font to the Imagen... (IF (OR (NULL (LISP-FONT-NAME DESCRIPTOR)) (EQ (LISP-FONT-NAME DESCRIPTOR) T)) (SEND SELF :STRING-OUT-RAW (IMPRESS-CREATE-FAMILY-TABLE :FAMILY (IMAGEN-FAMILY DESCRIPTOR) :FONT-NAME (IMAGEN-FONT-NAME DESCRIPTOR)))) )) (SEND SELF :STRING-OUT-RAW (IMPRESS-SET-IL :INTER-LINE ADVANCE-HEIGHT))) (DEFMETHOD (PRINTER::IMAGEN-PRINTER :SWITCH-PRINTER-TO-FONT) (IMAGEN-FONT) "Send the commands to the printer to switch it to IMAGEN-FONT's font-family." (SEND SELF :STRING-OUT-RAW (STRING-APPEND (IMPRESS-SET-FAMILY :FAMILY (IMAGEN-FAMILY IMAGEN-FONT)) (IMPRESS-SET-SP :SPACE-SIZE (SPACE-SIZE IMAGEN-FONT))))) ;;; ********************************************************************************* ;;; ;;; Replacements for basic-printer's methods ;;; ;;; ********************************************************************************* ;;; (DEFMETHOD (PRINTER::IMAGEN-PRINTER :STRING-OUT-RAW) (STRING) "Send out a string of non-text bytes (don't count or translate)." (LOOP FOR I FROM 0 BELOW (LENGTH STRING) DO (SEND SELF :TYO-RAW (AREF STRING I)))) (DEFMETHOD (PRINTER::IMAGEN-PRINTER :TYO-RAW) (CHAR) "Quote any Imagen EOD or 'quote' character before sending." (COND ((eql (char-int CHAR) 2) (SEND PRINTER::PRINTER-STREAM :TYO 2) (SEND PRINTER::PRINTER-STREAM :TYO #\0) (SEND PRINTER::PRINTER-STREAM :TYO #\2)) ((eql (char-int CHAR) 4) (SEND PRINTER::PRINTER-STREAM :TYO 2) (SEND PRINTER::PRINTER-STREAM :TYO #\0) (SEND PRINTER::PRINTER-STREAM :TYO #\4)) (T (SEND PRINTER::PRINTER-STREAM :TYO CHAR)))) (DEFMETHOD (PRINTER::IMAGEN-PRINTER :TYO-CHAR) (CHAR &AUX PRINTABLE) "Implement end-of-line wraparound, turn SPACE character into the Imagen command 'SP'." (WHEN (OR (AND (SETQ PRINTABLE (SEND SELF :CHECK-PRINTABILITY CHAR)); If printable, (< *PIXELS-IN-A-LINE*; and there is no more room on the line. (SETQ HORIZONTAL-POSITION (+ HORIZONTAL-POSITION (AREF (CHAR-WIDTH CURRENT-FONT-DESCRIPTOR) CHAR))))) (AND (eql #\TAB (int-char CHAR)); OR a tab character and the next tab (< *PIXELS-IN-A-LINE*; stop is beyond the end of the line, (* TAB-WIDTH-PIXELS (CEILING (1+ HORIZONTAL-POSITION) TAB-WIDTH-PIXELS))))) (SEND SELF :TYO-RAW (char-int #\!)); then terminate the line with a "!" (IF (NOT (eql #\TAB (int-char CHAR)));2.1 fix subscript error if tab. no font for tab char (SETF (AREF (SEND-GLYPH-TO-IMAGEN CURRENT-FONT-DESCRIPTOR) #\!) 1)); (ensure glyph's download) (SEND SELF :START-NEW-LINE)); and start a new line (COND ((eql (int-char CHAR) #\SPACE); If a "space", then send (SEND SELF :STRING-OUT-RAW (IMPRESS-SP))); the Imagen @SP@ command instead. (PRINTABLE; Handle the easy stuff first. (SEND SELF :TYO-RAW CHAR)); * ((eql (int-char CHAR) #\TAB); TAB is the next most frequently used character, (SEND SELF :TAB)); so handle it next. ((OR (eql (int-char CHAR) #\NEWLINE); on Lisp Machine CR really means CR-LF. (eql (int-char CHAR) #\LINEFEED); make LF mean the same thing. (eql CHAR 13)); ^M (which means CR ONLY on 2060/VAX) gets ; interpreted on Lisp Machines as octal 15, but ; #o15 is the same as #\circle-plus on Lisp ; Machines; can't have both... (SEND SELF :START-NEW-LINE)) ((eql (int-char CHAR) #\PAGE) (SEND SELF :START-NEW-PAGE)) ((eql (int-char CHAR) #\BACKSPACE) (SEND SELF :TYO-RAW PRINTER::BACKSPACE)) (T; chars like , , etc. (SEND SELF :SIMULATE-LISPM-CHAR CHAR))) (SETQ LAST-CHAR CHAR)) ; Always remember last character printed. (DEFMETHOD (PRINTER::IMAGEN-PRINTER :TAB) () (SETQ HORIZONTAL-POSITION (* TAB-WIDTH-PIXELS (CEILING (1+ HORIZONTAL-POSITION) TAB-WIDTH-PIXELS))) (SEND SELF :STRING-OUT-RAW (IMPRESS-SET-ABS-H :NEW-H (+ *LEFT-MARGIN-WIDTH* HORIZONTAL-POSITION)))) (DEFMETHOD (PRINTER::IMAGEN-PRINTER :START-NEW-LINE) () (UNLESS (eql (int-char LAST-CHAR) #\PAGE); Suppress blank-line from FORM/CR. (IF (<= *PIXELS-DOWN-A-PAGE* VERTICAL-POSITION) (SEND SELF :START-NEW-PAGE); start a new page. (PROGN (SETQ HORIZONTAL-POSITION 0); Otherwise, start a new line. (SETQ VERTICAL-POSITION (+ VERTICAL-POSITION ADVANCE-HEIGHT)) (SEND SELF :STRING-OUT-RAW (IMPRESS-CRLF)))))) (DEFMETHOD (PRINTER::IMAGEN-PRINTER :START-NEW-PAGE) () "Send a form feed and possibly print a page heading" (WHEN (SEND PRINTER::PRINTER-STREAM :OPERATION-HANDLED-P :TRUENAME);2.1 fix Chages to the basic-printer (UNLESS (AND (= VERTICAL-POSITION START-OF-TEXT);method caused a send to start-new-page (NOT (eql (int-char LAST-CHAR) #\PAGE)));sinse IMAGEN changes printer-stream (SEND SELF :STRING-OUT-RAW (IMPRESS-ENDPAGE)); Finish this page. to a truename, we have to check (SETQ PAGE-START-LIST (CONS (SEND PRINTER::PRINTER-STREAM;tomake sure this did not come from :READ-POINTER);basic flavor. PAGE-START-LIST)) (SEND SELF :STRING-OUT-RAW; Start the next page. (STRING-APPEND (IMPRESS-SET-ABS-V :NEW-V *TOP-MARGIN-HEIGHT*); 1/2" top margin. (IMPRESS-SET-ABS-H :NEW-H *LEFT-MARGIN-WIDTH*); 1/2" left-hand (IMPRESS-SET-BOL :LINE-BEGIN *LEFT-MARGIN-WIDTH*))); * (SETQ HORIZONTAL-POSITION 0) (SETQ VERTICAL-POSITION 0) (WHEN PRINTER::PAGE-WAIT (FORMAT T "~&Type any character when ready for next page:") (TYI)) (IF PRINTER::PAGE-HEADING (SEND SELF :PRINT-PAGE-HEADING)) (SETQ START-OF-TEXT VERTICAL-POSITION) (SETQ HORIZONTAL-POSITION 0) (SEND SELF :SWITCH-PRINTER-TO-FONT CURRENT-FONT-DESCRIPTOR)))) (DEFMETHOD (PRINTER::IMAGEN-PRINTER :CR) () ()) ; Shadow basic-printer's method. ;;; ********************************************************************************* ;;; ;;; Print the page heading line(s) ;;; ;;; ********************************************************************************* ;;; (DEFMETHOD (PRINTER::IMAGEN-PRINTER :PRINT-PAGE-HEADING) (&AUX FIRST-LINE (SECOND-LINE NIL) BRULE-WIDTH FORMAT-STRING HEADING-LINE-HEIGHT) "Print page heading." (DECLARE (SPECIAL IMAGEN-FONTS::COUR12)) (SEND SELF :SWITCH-PRINTER-TO-FONT IMAGEN-FONTS::COUR12); Switch to COUR12 for page heading. (SETQ HEADING-LINE-HEIGHT; Remember COUR12's interline height. (INTERLINE-SPACING IMAGEN-FONTS::COUR12)) (SEND SELF :STRING-OUT-RAW; Use COUR12's interline height temporarily. (IMPRESS-SET-IL :INTER-LINE HEADING-LINE-HEIGHT)) ;; Get the new page's page number... (SETQ PRINTER::PAGE-COUNT (1+ PRINTER::PAGE-COUNT)) ;; If the page-heading is a list, get two lines worth of heading text, otherwise get just one... (IF (CONSP PRINTER::PAGE-HEADING) (SETQ FIRST-LINE (FIRST PRINTER::PAGE-HEADING) SECOND-LINE (SECOND PRINTER::PAGE-HEADING)) (SETQ FIRST-LINE PRINTER::PAGE-HEADING)) ;; Select brule width and the width/format of the page heading based on rotation... (COND (ROTATED-PAGE-IMAGE (SETQ BRULE-WIDTH *PIXELS-DOWN-A-PAGE* FORMAT-STRING "~98A~18A Page -~D-~@[~%~A~]")) (T (SETQ BRULE-WIDTH *PIXELS-IN-A-LINE* FORMAT-STRING "~45A~18A Page -~D-~@[~%~A~]"))) ;; Print the page heading string (one or two lines), leaving cursor at end of last line printed... (SEND SELF :STRING-OUT-CHARS (FORMAT () FORMAT-STRING FIRST-LINE PRINTER::CURRENT-TIME PRINTER::PAGE-COUNT SECOND-LINE)) ;; Print a nice underline for the page heading string, then switch back to normal interline height and ;; position the printer for the first text line... (SEND SELF :STRING-OUT-RAW (STRING-APPEND (IMPRESS-SET-ABS-H :NEW-H *LEFT-MARGIN-WIDTH*); Move back to start of line. (IMPRESS-BRULE :WIDTH BRULE-WIDTH; Print the underline. :HEIGHT 3; * :TOP-OFFSET 15); * (IMPRESS-SET-REL-V :DELTA-V 18); Make sure 1st text line clears it. (IMPRESS-CRLF); Advance COUR12-height pixels. (IMPRESS-CRLF); Twice. (IMPRESS-SET-IL :INTER-LINE ADVANCE-HEIGHT))); Switch back to text's line height. ;; Adjust our internal state to reflect the 2/3 heading-lines' just moved vertically... (SETQ VERTICAL-POSITION (+ VERTICAL-POSITION HEADING-LINE-HEIGHT HEADING-LINE-HEIGHT (IF SECOND-LINE HEADING-LINE-HEIGHT 0))) ;; Switch back to the font in which the file's text is currently being printed... (SEND SELF :SWITCH-PRINTER-TO-FONT CURRENT-FONT-DESCRIPTOR)) ;;; ********************************************************************************* ;;; ;;; Our file printing methods ;;; ;;; ********************************************************************************* ;;; (DEFMETHOD (PRINTER::IMAGEN-PRINTER :PRINT-TEXT-FILE) (FILE-STREAM &OPTIONAL FONTS &AUX BUFFER-FILE-PATHNAME LAST-PAGE-END) "Using the font information in the file attribute line, print the file looking as much as possible like the file looked on the screen. Page-reverse the printing by first creating the raw file to send the Imagen and remembering where all the page starts are, then printing that file page by page backward." ;; ;; Establish our buffer file, then "print" to it, remembering the positions of the pages' starts ;; in the list page-start-list... ;; (WITH-OPEN-FILE (TEMP-RAW-FILE ; Open up our buffer file. (SETQ BUFFER-FILE-PATHNAME (send (MAKE-PATHNAME :DIRECTORY "printer" :HOST SI:LOCAL-HOST :NAME "temp-raw-file" :TYPE "imagen" :VERSION :NEWEST) :merge-device)) ; DAB 02-01-89 :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) (SETQ TRUE-PRINT-STREAM ; Save our printer's stream. PRINTER::PRINTER-STREAM) (SETQ PRINTER::PRINTER-STREAM TEMP-RAW-FILE) ; Point all "printing" at our buffer file. ;; Setup tab-width DAB 01-25-89 (unless printer:tab-width ; DAB 01-25-89 Tab-width is an instance variable in basic-printers (setf printer:tab-width (or (PRINTER::GET-tab-width-ATTRIBUTE-LIST FILE-STREAM) printer:*default-tab-width*))) ;; Setup fonts... (UNLESS (CONSP FONTS) ; Make sure we have a list of fonts to work with. (SETF FONTS (LIST FONTS))) (SETQ WYSIWYG-P (OR *WYSIWYG-DEFAULT* ;Decide whether or not to create WYSIWYG fonts. (STRING-EQUAL (FIRST FONTS) "WYSIWYG"))) (WHEN (OR WYSIWYG-P ; Get the file's fonts if in WYSIWYG mode (NULL (FIRST FONTS))) ; or none supplied by caller. (SETF FONTS (PRINTER::GET-FONT-ATTRIBUTE-LIST FILE-STREAM))) (IF (NULL (FIRST FONTS)) ; If no font specification, (SETUP-IMAGEN-FONTS '(:CPTFONT)) ; force CPTFONT use, ;; else... (SETUP-IMAGEN-FONTS FONTS)) ; otherwise use what was specified. ;; Get on with the printing... (SEND SELF :START-NEW-PAGE) ; Setup to start the first page of printing. (LOOP FOR IN-CHAR = (TYI FILE-STREAM ()) ; Then read in the file to be printed, UNTIL (NULL IN-CHAR) DO ; character by character. (COND ((eql (int-char IN-CHAR) #\epsilon) ; If an epsilon, it might be a font switch. (SETQ IN-CHAR ; Get the character following. (SEND FILE-STREAM :TYI)) ; * (UNLESS ; If font-handling is active for this printing (AND (NOT (NULL FONTS)) ; and 'tis a good font switch, (SEND SELF :SET-CURRENT-FONT-FAMILY IN-CHAR)) ; then do it. (SEND SELF :TYO-CHAR #\epsilon) ; Otherwise print the epsilon (SEND FILE-STREAM :UNTYI IN-CHAR))) ; and let the next char be scanned again. (T (SEND SELF :TYO-CHAR IN-CHAR)))) ; Print anything else. (SEND SELF :STRING-OUT-RAW (IMPRESS-ENDPAGE)) ; Finish off the last page. (SETQ LAST-PAGE-END ; Get position of end of last page. (SEND TEMP-RAW-FILE :READ-POINTER))) ;; ;; Now copy the buffered pages to the Imagen in reverse order... ;; (LET ((PAGE-BUFFER (MAKE-ARRAY (LOOP FOR PAGE-START IN PAGE-START-LIST WITH PREVIOUS-PAGE-START = LAST-PAGE-END MAXIMIZE (- PREVIOUS-PAGE-START PAGE-START) DO (SETQ PREVIOUS-PAGE-START PAGE-START)) :ELEMENT-TYPE '(UNSIGNED-BYTE 8) :FILL-POINTER 0))) (SETQ PRINTER::PRINTER-STREAM TRUE-PRINT-STREAM) ; Now we talk to the real printer! (WITH-OPEN-FILE (TEMP-RAW-FILE ; Reopen the buffer file for input. BUFFER-FILE-PATHNAME ; * :DIRECTION :INPUT) ; * (DOTIMES (COPY NCOPIES) ; Do multiple copies -- separated by header pages. (SEND SELF :START-IMAGEN-DOCUMENT) ; Start the document. (LOOP FOR PAGE-START IN PAGE-START-LIST ; Then read the pages in in reverse order WITH PAGE-END = LAST-PAGE-END DO ; and print them. (SEND TEMP-RAW-FILE ; * :SET-POINTER PAGE-START) ; * (SEND TEMP-RAW-FILE ; * :STRING-IN () PAGE-BUFFER 0 (- PAGE-END PAGE-START)) (SEND TRUE-PRINT-STREAM ; * :STRING-OUT PAGE-BUFFER) ; * (SETQ PAGE-END PAGE-START)) ; * (SEND SELF :FINISH-IMAGEN-DOCUMENT)) ; Finish off each file copy cleanly. (DELETE-FILE TEMP-RAW-FILE)))) ; Only after printing all NCOPIES, delete the temp file. (DEFMETHOD (PRINTER::IMAGEN-PRINTER :PRINT-RAW-FILE) (FILE-STREAM) "Print a file already converted to Impress commands." (IF (NOT (eql (int-char (TYIPEEK () FILE-STREAM ())) #\@)) ; If 1st char not "@", (SEND SELF :START-IMAGEN-DOCUMENT)) ; send @document commands. (LOOP FOR IN-CHAR = (TYI FILE-STREAM ()) UNTIL (NULL IN-CHAR) DO (SEND PRINTER::PRINTER-STREAM :TYO IN-CHAR)) (SEND SELF :FINISH-IMAGEN-DOCUMENT)) ; Finish the document by sending Imagen EOD. ;;; ;;; Add IMAGEN-FONT properties to all Lisp fonts that have associated Imagen fonts... ;;; Also, load the IMAGEN-FONT descriptors for all those that have them... ;;; (LET ((list-of-imagen-fonts nil) file) (DECLARE (SPECIAL FILE)) (LOOP FOR font-pair IN *lisp-to-imagen-font-mapping* FOR lisp-font = (INTERN (FIRST font-pair) 'FONTS) FOR imagen-font = (INTERN (CDR font-pair) 'IMAGEN-FONTS) DO (UNLESS (MEMBER imagen-font list-of-imagen-fonts :TEST #'STRING-EQUAL) (PUSH imagen-font list-of-imagen-fonts)) (PUTPROP lisp-font imagen-font 'FED:imagen-font) (PUTPROP imagen-font lisp-font 'imagen:lisp-font)) (LOOP FOR imagen-font IN list-of-imagen-fonts DO (WHEN (fs:probe-file (fs:make-pathname :host *imagen-font-directory-host-name* :directory *imagen-font-directory-name* :name (STRING imagen-font) :type "XLD")) (FASLOAD (fs:make-pathname :host *imagen-font-directory-host-name* :directory *imagen-font-directory-name* :name (STRING imagen-font) :type "XLD") 'imagen-fonts t) (SETF (lisp-font-name (SYMBOL-VALUE imagen-font)) 2)))) ;;; ;;; Establish the printer-resident fonts... ;;; (prog (var1) (declare (special imagen-fonts:cour12 imagen-fonts:cour10 imagen-fonts:cour08) (ignore var1)) (SETq IMAGEN-FONTS::COUR12 ; Insert entry for COUR12 printer-resident font. (MAKE-IMAGEN-FONT LISP-FONT-NAME () IMAGEN-FONT-NAME "COUR12" SPACE-SIZE 30 INTERLINE-SPACING 51)) (SETQ IMAGEN-FONTS::COUR10 ; Insert entry for COUR10 printer-resident font. (MAKE-IMAGEN-FONT LISP-FONT-NAME () IMAGEN-FONT-NAME "COUR10" SPACE-SIZE 25 INTERLINE-SPACING 42)) (SETQ IMAGEN-FONTS::COUR08 ; Insert entry for COUR08 printer-resident font. (MAKE-IMAGEN-FONT LISP-FONT-NAME () IMAGEN-FONT-NAME "COUR08" SPACE-SIZE 20 INTERLINE-SPACING 34)) ) ;; Fix up COUR10 to use CMASC10's glyphs for codes #o000 - #0037, #0177... (prog (var1) (declare (special imagen-fonts:cmasc10 IMAGEN-FONTS::COUR10) (ignore var1)) (LET* ((FONT-TO-BE-FIXED-UP IMAGEN-FONTS::COUR10) (FIXUP-FONT IMAGEN-FONTS::CMASC10)) (DECLARE (SPECIAL IMAGEN-FONTS::COUR10 IMAGEN-FONTS::CMASC10)) (SETF (LISP-FONT-NAME FONT-TO-BE-FIXED-UP) T) ; Force download of these glyphs. (LOOP FOR CHAR-CODE FROM 0 TO 31 DO (SETF (AREF (GLYPH-MAP FONT-TO-BE-FIXED-UP) CHAR-CODE) (AREF (GLYPH-MAP FIXUP-FONT) CHAR-CODE))) (LOOP FOR CHAR-CODE FROM 127 TO 127 DO (SETF (AREF (GLYPH-MAP FONT-TO-BE-FIXED-UP) CHAR-CODE) (AREF (GLYPH-MAP FIXUP-FONT) CHAR-CODE))))) ;; For the just-declared printer-resident fonts, force character widths to space size (prog (var1) (declare (special imagen-fonts:cour12 imagen-fonts:cour10 imagen-fonts:cour08) (ignore var1)) (LOOP FOR IMAGEN-FONT IN (LIST IMAGEN-FONTS::COUR08 IMAGEN-FONTS::COUR10 IMAGEN-FONTS::COUR12) DO (DOTIMES (I 128) (SETF (AREF (CHAR-WIDTH IMAGEN-FONT) I) (SPACE-SIZE IMAGEN-FONT))))) ;;; ;;; Build our translation tables... ;;; (BUILD-FLIPPED-BITS-TABLE) (BUILD-EXPAND-BY-2-TABLE) (BUILD-EXPAND-BY-3-TABLE) (COMPILE-FLAVOR-METHODS PRINTER::IMAGEN-PRINTER) (DEFMETHOD (PRINTER::IMAGEN-PRINTER :AFTER :RESET-HARDWARE) () "Sends an Imagen EOD if (1) this is the first reset following a cold boot, (2) the Imagen printer is configured on the parallel port, and (3) the parallel port is busy." (DECLARE (SPECIAL *PARALLEL-PORT-NOT-RESET-SINCE-BOOT*)) (IF (AND *PARALLEL-PORT-NOT-RESET-SINCE-BOOT* (THE-IMAGEN-PRINTER-IS-ON-THE-PARALLEL-PORT-P)) (SI::PARALLEL-TYO 4)) (SETQ *PARALLEL-PORT-NOT-RESET-SINCE-BOOT* ())) ;1; Changed For Namespace Compatibility -- LS 10/10/86* ;1; We Now Use (List-Printers) Instead Of Si:*Printer-Devices** (DEFUN THE-IMAGEN-PRINTER-IS-ON-THE-PARALLEL-PORT-P () (LOOP FOR DESCRIPTION IN (PRINTER:LIST-PRINTERS) WHEN (AND (EQ (GET DESCRIPTION :HOST) SI:LOCAL-HOST-NAME) ;2.1 fix check if printer (EQ (GET DESCRIPTION :TYPE) 'PRINTER::IMAGEN-PRINTER) ;is on local host. (EQ (GET DESCRIPTION :STREAM) :PARALLEL)) RETURN T))