;;; -*-Mode:LISP; Package:FED; Base:8; readtable: ZL-*- ;;; * (c) Copyright 1980 Massachusetts Institute of Technology ** ;The functions in this file ;are used to convert between the various formats for fonts as used on the LISP ;Machine. These are the formats currently supported in some way: ; KST format is used for communication with the PDP-10. ; FD (or Font Descriptor) Format is used as a machine resident format ; which is easily manipulated. The format consists of a 200 ; or more element array with a leader. The elements of this array are ; themselves two dimensional arrays which contain the actual ; pixel values for the character. ; FONT (or internal) Format is the format actually used by the tv display ; routines. The format is fairly complicated and its direct ; use is not recommended when a conversion to FD format would ; be better. ; AL format is used for ALTO fonts. ; AC another xerox format. ; KS kerned strike xerox format. ; AST stars and spaces. ;Conversion functions: ; FONT-INTO-FONT-DESCRIPTOR FONTNAME => FONT-DESCRIPTOR ; (you might really want FONT-NAME-FONT-DESCRIPTOR, which remembers the FONT-DESCRIPTOR) ; FONT-DESCRIPTOR-INTO-FONT FONT-DESCRIPTOR => FONTNAME ; READ-X-INTO-FONT FILENAME &OPTIONAL FONTNAME => FONTNAME ; READ-X-INTO-FONT-DESCRIPTOR FILENAME &OPTIONAL FONTNAME => FONT-DESCRIPTOR ; WRITE-FONT-INTO-X FONTNAME &OPTIONAL FILENAME => OUTPUT-TRUENAME ; WRITE-FONT-DESCRIPTOR-INTO-X FONT-DESCRIPTOR &OPTIONAL FILENAME => OUTPUT-TRUENAME ;Other useful functions in here: ; THICKEN-FONT[-DESCRIPTOR], makes B(old) fonts. ; ROTATE-FONT[-DESCRIPTOR], makes R(otated) fonts. I.e. landscape from portrait. ; CD-RASTER-RANGE CHAR-DESCRIPTOR => MINX MINY MAXX MAXY ; CD-UNUSED-RASTER-HEIGHT CHAR-DESCRIPTOR => BOTTOM TOP ;First some helping functions: (DEFUN MAX-RASTER-WIDTH (FONT-DESCRIPTOR &AUX (GUESS 0) TEMP) "Return the maximum raster width of all characters in FONT-DESCRIPTOR." (DO ((CHAR-CODE 0 (1+ CHAR-CODE)) (FONT-LENGTH (ARRAY-ACTIVE-LENGTH FONT-DESCRIPTOR))) (( CHAR-CODE FONT-LENGTH) GUESS) (COND ((SETQ TEMP (AREF FONT-DESCRIPTOR CHAR-CODE)) (SETQ GUESS (MAX GUESS (ARRAY-DIMENSION TEMP 1))))))) (DEFUN MAX-RASTER-HEIGHT (FONT-DESCRIPTOR &AUX (GUESS 0) TEMP) "Return the maximum raster height of all characters in FONT-DESCRIPTOR." (DO ((CHAR-CODE 0 (1+ CHAR-CODE)) (FONT-LENGTH (ARRAY-ACTIVE-LENGTH FONT-DESCRIPTOR))) (( CHAR-CODE FONT-LENGTH) GUESS) (COND ((SETQ TEMP (AREF FONT-DESCRIPTOR CHAR-CODE)) (SETQ GUESS (MAX GUESS (ARRAY-DIMENSION TEMP 0))))))) ;;; Memoizing version of FONT-INTO-FONT-DESCRIPTOR ;;; that wants a font name (symbol in FONTS:) rather than the font itself. ;;; The FONT-DESCRIPTOR property of the symbol holds the descriptor. ;;; The FONT-DESCRIBED property holds the font itself which the descriptor matches. ;;; If anyone changes the font, we can see that the old descriptor is no good. (DEFUN FONT-NAME-FONT-DESCRIPTOR (FONTNAME &AUX FD) "Return a font-descriptor whose data is equivalent to font FONTNAME. If we computed one previously, we return it; otherwise, we create one. This assumes that anyone who alters the contents of the font also alters the corresponding font descriptor." (OR (SYMBOLP FONTNAME) (SETQ FONTNAME (FONT-NAME FONTNAME))) (SETQ FD (GET FONTNAME 'FONT-DESCRIPTOR)) (COND ((AND FD (EQ (GET FONTNAME 'FONT-DESCRIBED) (SYMEVAL FONTNAME)))) (T (SETQ FD (FONT-INTO-FONT-DESCRIPTOR (SYMEVAL FONTNAME))) (PUTPROP FONTNAME (SYMEVAL FONTNAME) 'FONT-DESCRIBED) (PUTPROP FONTNAME FD 'FONT-DESCRIPTOR))) FD) ;;; Set a font given a font descriptor. Keep the descriptor around. ;;; Forward the old definition of the font to the new one. (DEFUN FONT-NAME-SET-FONT-AND-DESCRIPTOR (FONTNAME FONT-DESCRIPTOR) "Define or redefine a font named FONTNAME from data in FONT-DESCRIPTOR." (LET ((OLDFONT (AND (BOUNDP FONTNAME) (SYMEVAL FONTNAME)))) (SET FONTNAME (FONT-DESCRIPTOR-INTO-FONT FONT-DESCRIPTOR)) (AND OLDFONT (STRUCTURE-FORWARD OLDFONT (SYMEVAL FONTNAME))) (PUTPROP FONTNAME FONT-DESCRIPTOR 'FONT-DESCRIPTOR) (PUTPROP FONTNAME (SYMEVAL FONTNAME) 'FONT-DESCRIBED) FONT-DESCRIPTOR)) (DEFUN FONT-NAME-STORE-CD (FONTNAME CD CHAR-CODE &AUX FONT) "Store character CHAR-CODE in font named FONTNAME from data in CD. CD should be a CHARACTER-DESCRIPTOR. Both the font itself and any remembered font-descriptor are modified. A new font array is constructed if the new character's raster size is too big for the old one." (LET ((WIDTH (ARRAY-DIMENSION CD 1)) (HEIGHT (ARRAY-DIMENSION CD 0)) TEM FD) (SETQ FD (FONT-NAME-FONT-DESCRIPTOR FONTNAME)) (FD-STORE-CD FD CD CHAR-CODE) (AND (= CHAR-CODE #\SP) (SETF (FD-SPACE-WIDTH FD) (CD-CHAR-WIDTH CD))) (COND ((OR (NOT (BOUNDP FONTNAME)) (NULL (SETQ FONT (SYMEVAL FONTNAME))) ( CHAR-CODE (MAX (OR (FONT-FILL-POINTER FONT) 200) 200)) (> WIDTH (COND ((SETQ TEM (FONT-INDEXING-TABLE FONT)) (* (FONT-RASTER-WIDTH FONT) (- (AREF TEM (1+ CHAR-CODE)) (AREF TEM CHAR-CODE)))) (T (FONT-RASTER-WIDTH FONT)))) (> HEIGHT (FONT-RASTER-HEIGHT FONT))) (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME FD)) (T (STORE-CD-IN-FONT CD FONT CHAR-CODE NIL))))) (DEFUN FD-STORE-CD (FD CD CH) "Store character-descriptor CD as character CH in font descriptor FD." (AND ( CH (ARRAY-LENGTH FD)) (ADJUST-ARRAY-SIZE FD (+ CH 100))) (AND ( CH (FD-FILL-POINTER FD)) (SETF (FD-FILL-POINTER FD) (1+ CH))) (ASET CD FD CH)) ;Functions for referring to specified pixels of characters in an internal format font. ;ROW and COL are measured from top/left as usual. An alternative would be: ; COL is measured from the left, with Kerning hacked. ; ROW is positive above the baseline and negative below. ; (SETQ ROW (- (FONT-BASELINE FONT) ROW)) ; (AND (SETQ TEM (FONT-LEFT-KERN-TABLE FONT)) ; (SETQ COL (+ COL (AREF TEM CHAR)))) ;However it looks like this would cause more trouble than it would save. ;Attempts to reference outside of the raster return 0, or barf if storing. ;Conceivably it might be good to not barf at attempts to store 0 out of bounds? (DEFUN FONT-GET-PIXEL (FONT CHAR ROW COL &AUX TEM (NEXTCHAR (1+ CHAR))) "Get the pixel at position ROW, COL in character CHAR of FONT. FONT should be a font array, not a name." (COND ((OR (< ROW 0) ( ROW (FONT-RASTER-HEIGHT FONT)) (< COL 0) (COND ((SETQ TEM (FONT-INDEXING-TABLE FONT)) (SETQ CHAR (+ (AREF TEM CHAR) (TRUNCATE COL (FONT-RASTER-WIDTH FONT)))) (SETQ COL (\ COL (FONT-RASTER-WIDTH FONT))) ( CHAR (AREF TEM NEXTCHAR))) (( COL (FONT-RASTER-WIDTH FONT))))) 0) ;out of bounds, return 0 (T (DO ((FONT FONT (FONT-NEXT-PLANE FONT)) (PIXEL 0) (PLANENUM 0 (1+ PLANENUM))) ((NULL FONT) PIXEL) (SETQ PIXEL (+ PIXEL (LSH (AREF FONT (+ (* 32. (+ (* (FONT-WORDS-PER-CHAR FONT) CHAR) (TRUNCATE ROW (FONT-RASTERS-PER-WORD FONT)))) (+ (* (FONT-RASTER-WIDTH FONT) (\ ROW (FONT-RASTERS-PER-WORD FONT))) COL))) PLANENUM))))))) (DEFUN FONT-SET-PIXEL (PIXEL FONT CHAR ROW COL &AUX TEM (NEXTCHAR (1+ CHAR))) "Set the pixel at position ROW, COL in character CHAR of font FONT to PIXEL. FONT should be a font array, not a name." (COND ((OR (< ROW 0) ( ROW (FONT-RASTER-HEIGHT FONT)) (< COL 0) (COND ((SETQ TEM (FONT-INDEXING-TABLE FONT)) (SETQ CHAR (+ (AREF TEM CHAR) (TRUNCATE COL (FONT-RASTER-WIDTH FONT)))) (SETQ COL (\ COL (FONT-RASTER-WIDTH FONT))) ( CHAR (AREF TEM NEXTCHAR))) (( COL (FONT-RASTER-WIDTH FONT))))) (FERROR NIL "Store of ~C in ~S at ~O,~O out of character bounds" CHAR FONT ROW COL)) (T (DO ((FONT FONT (FONT-NEXT-PLANE FONT)) (BIT PIXEL (LSH BIT -1))) ((NULL FONT) PIXEL) (ASET BIT FONT (+ (* 32. (+ (* (FONT-WORDS-PER-CHAR FONT) CHAR) (TRUNCATE ROW (FONT-RASTERS-PER-WORD FONT)))) (+ (* (FONT-RASTER-WIDTH FONT) (\ ROW (FONT-RASTERS-PER-WORD FONT))) COL))))))) ;This function takes an FD format font and creates an internal format ; font from it. All of the hairy formats of the stored font ; are taken care of by this function so the user doesn't have ; to worry about them. (DEFUN FONT-DESCRIPTOR-INTO-FONT (FONT-DESCRIPTOR &OPTIONAL (NBR-PLANES-OUT NIL) &AUX (FONT-OUT NIL) (FONT-DESCRIPTOR-LENGTH (ARRAY-ACTIVE-LENGTH FONT-DESCRIPTOR)) (FONT-LENGTH (MAX FONT-DESCRIPTOR-LENGTH 200)) (COL-INCR (COND ((FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR) 2) (T 1))) (SPACE-WIDTH (OR (FIX (+ (FD-SPACE-WIDTH FONT-DESCRIPTOR) 0.5)) 0)) (WIDTH (TRUNCATE SPACE-WIDTH COL-INCR)) (HEIGHT (FD-LINE-SPACING FONT-DESCRIPTOR)) (BASELINE (FD-BASELINE FONT-DESCRIPTOR)) (RASTER-WIDTH (MAX 1 (CEILING (MAX-RASTER-WIDTH FONT-DESCRIPTOR) COL-INCR))) (RASTER-HEIGHT (MAX-RASTER-HEIGHT FONT-DESCRIPTOR)) (RASTERS-PER-WORD (TRUNCATE 32. (MIN 32. RASTER-WIDTH))) (WORDS-PER-RASTER-ELEMENT (CEILING RASTER-HEIGHT RASTERS-PER-WORD)) (TOTAL-RASTER-ELEMENTS FONT-LENGTH) (BLINKER-WIDTH (FLOOR (FD-BLINKER-WIDTH FONT-DESCRIPTOR) COL-INCR)) (BLINKER-HEIGHT (FD-BLINKER-HEIGHT FONT-DESCRIPTOR)) (INDEXING-TABLE NIL) (CHARS-EXIST-TABLE (MAKE-ARRAY FONT-LENGTH ':TYPE 'ART-1B)) TEMP ;General temporary ) "Create a font-array from font-descriptor FONT-DESCRIPTOR. Its name is set from that in FONT-DESCRIPTOR." ;;Set up NBR-PLANES-OUT if defaulted (COND ((NULL NBR-PLANES-OUT) (SETQ NBR-PLANES-OUT COL-INCR))) ;;Create INDEXING-TABLE if needed (COND ((> RASTER-WIDTH 32.) (SETQ INDEXING-TABLE (MAKE-ARRAY (1+ FONT-LENGTH) ':TYPE 'ART-16B)) (ASET 0 INDEXING-TABLE 0) (DO ((CHAR-CODE 0 (1+ CHAR-CODE))) (( CHAR-CODE FONT-LENGTH) (SETQ TOTAL-RASTER-ELEMENTS (AREF INDEXING-TABLE FONT-LENGTH))) (SETQ TEMP (AND (< CHAR-CODE FONT-DESCRIPTOR-LENGTH) (AREF FONT-DESCRIPTOR CHAR-CODE))) (ASET (+ (AREF INDEXING-TABLE CHAR-CODE) (COND ((NULL TEMP) 0) (T (CEILING (ARRAY-DIMENSION TEMP 1) 32.)))) INDEXING-TABLE (1+ CHAR-CODE))) (SETQ RASTER-WIDTH 32.))) ;;set up all the planes of the font (DO ((I NBR-PLANES-OUT (1- I))) ((ZEROP I)) ;;Make up a (one-plane) font and make it's next plane be the last one we made (SETQ TEMP (TV:MAKE-FONT :MAKE-ARRAY (:TYPE 'ART-1B :LENGTH (* TOTAL-RASTER-ELEMENTS WORDS-PER-RASTER-ELEMENT 32.)))) (SETF (FONT-NEXT-PLANE TEMP) FONT-OUT) (SETQ FONT-OUT TEMP) ;;Now set all the other fields in the leader (SETF (FONT-NAME FONT-OUT) (FD-NAME FONT-DESCRIPTOR)) (SETF (FONT-CHAR-WIDTH FONT-OUT) WIDTH) (SETF (FONT-CHAR-HEIGHT FONT-OUT) HEIGHT) (SETF (FONT-RASTER-WIDTH FONT-OUT) RASTER-WIDTH) (SETF (FONT-RASTER-HEIGHT FONT-OUT) RASTER-HEIGHT) (SETF (FONT-RASTERS-PER-WORD FONT-OUT) RASTERS-PER-WORD) (SETF (FONT-WORDS-PER-CHAR FONT-OUT) WORDS-PER-RASTER-ELEMENT) (SETF (FONT-BASELINE FONT-OUT) BASELINE) (SETF (FONT-BLINKER-WIDTH FONT-OUT) BLINKER-WIDTH) (SETF (FONT-BLINKER-HEIGHT FONT-OUT) BLINKER-HEIGHT) (SETF (FONT-NAME FONT-OUT) (FD-NAME FONT-DESCRIPTOR)) (SETF (FONT-CHARS-EXIST-TABLE FONT-OUT) CHARS-EXIST-TABLE) (SETF (FONT-INDEXING-TABLE FONT-OUT) INDEXING-TABLE) (SETF (FONT-FILL-POINTER FONT-OUT) FONT-LENGTH)) (DO ((CHAR-CODE 0 (1+ CHAR-CODE))) (( CHAR-CODE FONT-LENGTH)) (SETQ TEMP (AND (< CHAR-CODE FONT-DESCRIPTOR-LENGTH) (AREF FONT-DESCRIPTOR CHAR-CODE))) (COND (TEMP (STORE-CD-IN-FONT TEMP FONT-OUT CHAR-CODE (FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR))))) FONT-OUT) ;Store the data in CD into character number CHAR-CODE of FONT. ;It is assumed that the dimensions of the CD fit within the raster dimensions of the font. ;This is not recommended for users to call. (DEFUN STORE-CD-IN-FONT (CD FONT CHAR-CODE &OPTIONAL (DOUBLE-WIDTH-P NIL) &AUX (FONT-LENGTH (FONT-FILL-POINTER FONT)) (WIDTH (ARRAY-DIMENSION CD 1)) (HEIGHT (ARRAY-DIMENSION CD 0)) (FONT-HEIGHT (FONT-RASTER-HEIGHT FONT)) (FONT-WIDTH (FONT-RASTER-WIDTH FONT)) PIXEL (LOSING-KERN 0) (COL-INCR (COND (DOUBLE-WIDTH-P 2) (T 1)))) (OR (AND FONT-LENGTH ( FONT-LENGTH 200)) (SETQ FONT-LENGTH 200)) ;; Update the font's char-width-table, creating one if necessary. (LET ((CW (CEILING (ROUND (CD-CHAR-WIDTH CD)) COL-INCR)) (FCW (FONT-CHAR-WIDTH FONT)) (FCWT (FONT-CHAR-WIDTH-TABLE FONT))) (COND (FCWT (ASET CW FCWT CHAR-CODE)) ((NOT (= CW FCW)) (SETF (FONT-CHAR-WIDTH-TABLE FONT) (SETQ FCWT (MAKE-ARRAY FONT-LENGTH))) (AND DOUBLE-WIDTH-P (SETF (FONT-CHAR-WIDTH-TABLE (FONT-NEXT-PLANE FONT)) FCWT)) (DO I 0 (1+ I) (= I FONT-LENGTH) (ASET FCW FCWT I)) (ASET CW FCWT CHAR-CODE))) (AND (= CHAR-CODE #\SP) (SETF (FONT-CHAR-WIDTH FONT) CW))) ;; Update the font's left-kern table, creating one if necessary. (LET ((CK (CD-CHAR-LEFT-KERN CD)) (FCKT (FONT-LEFT-KERN-TABLE FONT))) ;;this is to prevent lossage with this function making left kern tables unnecessarily. ;; the problem is that a character with a blank left column gets a kern of -1, regardless ;; of whether it would fit into the raster regardless. (AND (MINUSP CK) ( (CD-CHAR-WIDTH CD) (- WIDTH CK)) (SETQ LOSING-KERN (- CK) CK 0)) (COND (FCKT (ASET CK FCKT CHAR-CODE)) ((NOT (ZEROP CK)) (SETF (FONT-LEFT-KERN-TABLE FONT) ;Must be ART-INUM since left-kern can be -ve (SETQ FCKT (MAKE-ARRAY FONT-LENGTH ':TYPE ART-INUM))) (AND DOUBLE-WIDTH-P (SETF (FONT-LEFT-KERN-TABLE (FONT-NEXT-PLANE FONT)) FCKT)) (ASET CK FCKT CHAR-CODE)))) ;; Tell the font this char exists. (ERRSET (ASET 1 (FONT-CHARS-EXIST-TABLE FONT) CHAR-CODE) NIL) ;; In wide fonts, the raster width depends on the character, and is a multiple of 32. (COND ((FONT-INDEXING-TABLE FONT) (SETQ FONT-WIDTH (* (CEILING (ARRAY-DIMENSION CD 1) 32.) 32.)))) ;; Now copy the data. (DO ((ROW 0 (1+ ROW)) (ONE-BIT-FONT (NULL (FONT-NEXT-PLANE FONT))) (RASTER-WIDTH (FONT-RASTER-WIDTH FONT))) (( ROW FONT-HEIGHT)) (DO ( ;; Count columns in font descriptor. (COL 0 (IF (< PIXEL-COL LOSING-KERN) COL (+ COL COL-INCR))) ;; Count columns in font. (PIXEL-COL 0 (1+ PIXEL-COL)) ;; for one-bit fonts this is index in font itself of start of row. ;; For multi-bit fonts it is not used. (NEXT-BIT-FONT-INDEX (+ (* 32. (+ (* (FONT-WORDS-PER-CHAR FONT) (IF (FONT-INDEXING-TABLE FONT) (AREF (FONT-INDEXING-TABLE FONT) CHAR-CODE) CHAR-CODE)) (FLOOR ROW (FONT-RASTERS-PER-WORD FONT)))) (* RASTER-WIDTH (\ ROW (FONT-RASTERS-PER-WORD FONT)))) (1+ NEXT-BIT-FONT-INDEX))) (( PIXEL-COL FONT-WIDTH)) ;; Get pixel out of font descriptor. ;; If font is "double width", two pixels of font descriptor ;; are combined into one pixel for the font itself. (SETQ PIXEL (COND ((< PIXEL-COL LOSING-KERN) 0) ((OR ( COL WIDTH) ( ROW HEIGHT)) 0) (DOUBLE-WIDTH-P (+ (COND (( (1+ COL) WIDTH) 0) (T (AREF CD ROW (1+ COL)))) (* 2 (AREF CD ROW COL)))) (T (AREF CD ROW COL)))) ;; Store pixel into font. ;; If pixels are only one bit and chars not too wide, use a short cut. (COND (ONE-BIT-FONT ;; In wide font, notice when our horizontal advance ;; carries us into the "next character" of the many characters ;; in the font which actually represent vertical strips of one character. (AND (ZEROP (\ PIXEL-COL RASTER-WIDTH)) (NOT (ZEROP PIXEL-COL)) (SETQ NEXT-BIT-FONT-INDEX (+ NEXT-BIT-FONT-INDEX (* 32. (FONT-WORDS-PER-CHAR FONT)) (- RASTER-WIDTH)))) (ASET PIXEL FONT NEXT-BIT-FONT-INDEX)) (T (FONT-SET-PIXEL PIXEL FONT CHAR-CODE ROW PIXEL-COL)))))) ;Create an FD format font from an internal format font (DEFUN FONT-INTO-FONT-DESCRIPTOR (FONT &OPTIONAL (DBL-WIDTH-P NIL) &AUX FONT-DESCRIPTOR (FONT-LENGTH (FONT-FILL-POINTER FONT)) (LINE-SPACING (FONT-CHAR-HEIGHT FONT)) (RASTER-HEIGHT (FONT-RASTER-HEIGHT FONT)) (BASELINE (FONT-BASELINE FONT)) (BLINKER-HEIGHT (FONT-BLINKER-HEIGHT FONT)) (BLINKER-WIDTH (FONT-BLINKER-WIDTH FONT)) (SPACE-WIDTH (FONT-CHAR-WIDTH FONT)) FONT-CHARS-EXIST-TABLE TEMP RASTER-WIDTH CHARACTER-WIDTH LEFT-KERN PIXEL ) "Create an return a font-descriptor containing the data from FONT." (ERRSET (SETQ FONT-CHARS-EXIST-TABLE (FONT-CHARS-EXIST-TABLE FONT)) NIL) ;; Correct for old fonts that may not have valid fill pointers. (OR (AND FONT-LENGTH ( FONT-LENGTH 200)) (SETQ FONT-LENGTH 200)) (SETQ FONT-DESCRIPTOR (MAKE-FONT-DESCRIPTOR :MAKE-ARRAY (:LENGTH FONT-LENGTH) FD-FILL-POINTER FONT-LENGTH)) (SETF (FD-NAME FONT-DESCRIPTOR) (FONT-NAME FONT)) (SETF (FD-LINE-SPACING FONT-DESCRIPTOR) LINE-SPACING) (SETF (FD-BASELINE FONT-DESCRIPTOR)BASELINE) (SETF (FD-BLINKER-HEIGHT FONT-DESCRIPTOR) BLINKER-HEIGHT) (SETF (FD-BLINKER-WIDTH FONT-DESCRIPTOR) BLINKER-WIDTH) (SETF (FD-SPACE-WIDTH FONT-DESCRIPTOR) SPACE-WIDTH) (SETF (FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR) DBL-WIDTH-P) (DO ((CHAR-CODE 0 (1+ CHAR-CODE))) (( CHAR-CODE FONT-LENGTH)) (AND FONT-CHARS-EXIST-TABLE (ZEROP (AREF FONT-CHARS-EXIST-TABLE CHAR-CODE)) (GO SKIP-CHAR)) (SETQ CHARACTER-WIDTH (COND ((SETQ TEMP (FONT-CHAR-WIDTH-TABLE FONT)) (AREF TEMP CHAR-CODE)) (T (FONT-CHAR-WIDTH FONT)))) (SETQ RASTER-WIDTH (FONT-CHAR-MIN-RASTER-WIDTH FONT CHAR-CODE)) ;; If we don't know for sure which chars exist, ;; discard chars containing no information. (AND (NULL FONT-CHARS-EXIST-TABLE) (ZEROP RASTER-WIDTH) ( CHAR-CODE #\SPACE) (= CHARACTER-WIDTH (FONT-CHAR-WIDTH FONT)) (GO SKIP-CHAR)) (SETQ LEFT-KERN (COND ((SETQ TEMP (FONT-LEFT-KERN-TABLE FONT)) (AREF TEMP CHAR-CODE)) (T 0))) (SETQ TEMP (MAKE-CHAR-DESCRIPTOR :MAKE-ARRAY (:TYPE 'ART-4B :LENGTH (LIST RASTER-HEIGHT RASTER-WIDTH)) CD-CHAR-WIDTH CHARACTER-WIDTH CD-CHAR-LEFT-KERN LEFT-KERN)) (ASET TEMP FONT-DESCRIPTOR CHAR-CODE) (COND (DBL-WIDTH-P (DO ((ROW 0 (1+ ROW))) (( ROW RASTER-HEIGHT)) (DO ((COLI 0 (1+ COLI)) (COL 0 (+ 2 COL))) (( COL RASTER-WIDTH)) (SETQ PIXEL (FONT-GET-PIXEL FONT CHAR-CODE ROW COLI)) (ASET PIXEL TEMP ROW COL) (ASET (LSH PIXEL -1) TEMP ROW (1+ COL))))) (T (DO ((ROW 0 (1+ ROW))) (( ROW RASTER-HEIGHT)) (DO ((COL 0 (1+ COL))) (( COL RASTER-WIDTH)) (ASET (FONT-GET-PIXEL FONT CHAR-CODE ROW COL) TEMP ROW COL))))) SKIP-CHAR) FONT-DESCRIPTOR) ;;; Some useful font munging functions (DEFUN THICKEN-FONT-DESCRIPTOR (FD &OPTIONAL NEW-NAME &AUX LEN NFD) "Given font-descriptor FD, make a new one whose characters are /"thicker/". NEW-NAME specifies the name to give the new font-descriptor; by default, a /"B/" is appended to the old name. The new font descriptor is returned, and the new name is not actually defined." (OR NEW-NAME (SETQ NEW-NAME (INTERN (STRING-APPEND (FD-NAME FD) #/B) "FONTS"))) (SETQ LEN (ARRAY-ACTIVE-LENGTH FD) NFD (MAKE-FONT-DESCRIPTOR :MAKE-ARRAY (:TYPE 'ART-Q :LENGTH LEN) FD-FILL-POINTER (FD-FILL-POINTER FD) FD-NAME NEW-NAME FD-LINE-SPACING (FD-LINE-SPACING FD) FD-BASELINE (FD-BASELINE FD) FD-BLINKER-HEIGHT (FD-BLINKER-HEIGHT FD) FD-BLINKER-WIDTH (1+ (FD-BLINKER-WIDTH FD)) FD-SPACE-WIDTH (1+ (FD-SPACE-WIDTH FD)))) (DO ((I 0 (1+ I)) (CD) (NCD)) (( I LEN)) (AND (SETQ CD (AREF FD I)) (LET ((WIDTH (ARRAY-DIMENSION CD 1)) (HEIGHT (ARRAY-DIMENSION CD 0))) (SETQ NCD (MAKE-CHAR-DESCRIPTOR :MAKE-ARRAY (:TYPE 'ART-4B :LENGTH (LIST HEIGHT (1+ WIDTH))) CD-CHAR-WIDTH (1+ (CD-CHAR-WIDTH CD)) CD-CHAR-LEFT-KERN (CD-CHAR-LEFT-KERN CD))) (DOTIMES (J HEIGHT) (DOTIMES (I WIDTH) (SETF (AREF NCD J I) (LOGIOR (AREF CD J I) (AREF NCD J I))) (SETF (AREF NCD J (1+ I)) (AREF CD J I)))) (ASET NCD NFD I)))) NFD) (DEFUN THICKEN-FONT (FONT-SYMBOL &AUX FD NFD NFS) "Create a thicker (bolder) version of font named FONT-SYMBOL. The new font is given a name which is /"B/" appended to the old name." (SETQ FD (FONT-NAME-FONT-DESCRIPTOR FONT-SYMBOL) NFD (THICKEN-FONT-DESCRIPTOR FD) NFS (FD-NAME NFD)) (FONT-NAME-SET-FONT-AND-DESCRIPTOR NFS NFD) NFS) (DEFUN UNTHICKEN-FONT-DESCRIPTOR (FD NEW-NAME &AUX LEN NFD) "Given font-descriptor FD, make a new one whose characters are less thick. 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." (SETQ LEN (ARRAY-ACTIVE-LENGTH FD) NFD (MAKE-FONT-DESCRIPTOR :MAKE-ARRAY (:TYPE 'ART-Q :LENGTH LEN) FD-FILL-POINTER (FD-FILL-POINTER FD) FD-NAME NEW-NAME FD-LINE-SPACING (FD-LINE-SPACING FD) FD-BASELINE (FD-BASELINE FD) FD-BLINKER-HEIGHT (FD-BLINKER-HEIGHT FD) FD-BLINKER-WIDTH (FD-BLINKER-WIDTH FD) FD-SPACE-WIDTH (FD-SPACE-WIDTH FD))) (DO ((I 0 (1+ I)) (CD) (NCD)) (( I LEN)) (AND (SETQ CD (AREF FD I)) (LET ((WIDTH (ARRAY-DIMENSION CD 1)) (HEIGHT (ARRAY-DIMENSION CD 0))) (SETQ NCD (MAKE-CHAR-DESCRIPTOR :MAKE-ARRAY (:TYPE 'ART-4B :LENGTH (LIST HEIGHT WIDTH)) CD-CHAR-WIDTH (CD-CHAR-WIDTH CD) CD-CHAR-LEFT-KERN (CD-CHAR-LEFT-KERN CD))) ;110  100 (DOTIMES (J HEIGHT) (DO* ((I (1- WIDTH) (1- I)) (RIGHT 0 THIS) (THIS (AREF CD J I) LEFT) LEFT) ((= I 0)) (SETQ LEFT (AREF CD J (1- I))) (IF (AND ( LEFT 0) ( THIS 0) (= RIGHT 0)) (ASET 0 NCD J I) (ASET (AREF CD J I) NCD J I)))) (ASET NCD NFD I)))) NFD) (DEFUN UNTHICKEN-FONT (FONT-SYMBOL NFS &AUX FD NFD) "Create a less thick (bold) version of font named FONT-SYMBOL. NFS is the name for the new font." (SETQ FD (FONT-NAME-FONT-DESCRIPTOR FONT-SYMBOL) NFD (UNTHICKEN-FONT-DESCRIPTOR FD NFS)) (FONT-NAME-SET-FONT-AND-DESCRIPTOR NFS NFD) NFS) (DEFUN ROTATE-FONT-DESCRIPTOR (FD &AUX LENGTH NFD) (SETQ LENGTH (ARRAY-ACTIVE-LENGTH FD) NFD (MAKE-FONT-DESCRIPTOR :MAKE-ARRAY (:LENGTH LENGTH) FD-FILL-POINTER (FD-FILL-POINTER FD) FD-NAME (INTERN (STRING-APPEND (FD-NAME FD) #/R) "FONTS") FD-BASELINE (FD-SPACE-WIDTH FD) FD-LINE-SPACING (FD-SPACE-WIDTH FD) FD-BLINKER-HEIGHT (FD-BLINKER-WIDTH FD) FD-BLINKER-WIDTH (FD-BLINKER-HEIGHT FD) FD-SPACE-WIDTH (FD-LINE-SPACING FD) FD-ROTATION 90.)) (LOOP FOR CH FROM 0 BELOW LENGTH AS CD = (AREF FD CH) WHEN CD DO (ASET (ROTATE-CHAR-DESCRIPTOR CD) NFD CH)) NFD) (DEFUN ROTATE-CHAR-DESCRIPTOR (CD) (LET* ((HEI (ARRAY-DIMENSION CD 0)) (WID (ARRAY-DIMENSION CD 1)) (typ (array-type cd)) (NCD (MAKE-CHAR-DESCRIPTOR :MAKE-ARRAY (:LENGTH (LIST WID HEI) :TYPE typ) ;(ARRAY-TYPE CD)) CD-CHAR-LEFT-KERN 0 CD-CHAR-WIDTH HEI))) (LOOP FOR X FROM 0 BELOW WID DO (LOOP FOR Y FROM 0 BELOW HEI DO (ASET (AREF CD Y X) NCD (- WID X 1) Y))) NCD)) (DEFUN ROTATE-FONT (FONT-SYMBOL &AUX FD NFD NFS) "Create a rotated version of font named FONT-SYMBOL. The new font is given a name which is /"R/" appended to the old name." (SETQ FD (FONT-NAME-FONT-DESCRIPTOR FONT-SYMBOL) NFD (ROTATE-FONT-DESCRIPTOR FD) NFS (FD-NAME NFD)) (FONT-NAME-SET-FONT-AND-DESCRIPTOR NFS NFD) NFS) ;; KST files ;; Given filename and fontname from filename &optional fontname, canonicalize them (DEFUN GET-INPUT-FILENAME-AND-FONTNAME (FILENAME FONTNAME FILE-TYPE) (DECLARE (RETURN-LIST FILENAME FONTNAME)) (SETQ FILENAME (FS:MERGE-PATHNAME-DEFAULTS FILENAME (PATHNAME-DEFAULTS) FILE-TYPE)) (OR FONTNAME (SETQ FONTNAME (FUNCALL FILENAME ':NAME))) (AND (STRINGP FONTNAME) (SETQ FONTNAME (INTERN (STRING-UPCASE FONTNAME) "FONTS"))) (VALUES FILENAME FONTNAME)) ;; Read in a kst file and make and return a FONT-DESCRIPTOR, ;; which is an alternate convenient representation for a font. (DEFUN READ-KST-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME &AUX FD) (MULTIPLE-VALUE (FILENAME FONTNAME) (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "KST")) (WITH-OPEN-FILE (STREAM FILENAME '(:FIXNUM :IN :BYTE-SIZE 9.)) (SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME :MAKE-ARRAY (:LENGTH 200))) ;; Discard KSTID. (DOTIMES (I 4) (FUNCALL STREAM ':TYI)) ;; Discard column position adjust until I find out what it means. (OR (ZEROP (FUNCALL STREAM ':TYI)) (FERROR NIL "Nonzero column-position-adjust in font ~A -- what does that mean?" FONTNAME)) (SETF (FD-SPACE-WIDTH FD) 0) ;Just in case no space character. (SETF (FD-BASELINE FD) (FUNCALL STREAM ':TYI)) (SETF (FD-LINE-SPACING FD) (READ-KST-HALFWORD STREAM)) (SETF (FD-BLINKER-HEIGHT FD) (FD-LINE-SPACING FD)) (SETF (FD-NAME FD) FONTNAME) (LET (KERN CHAR-CODE RASTER-WIDTH CHAR-WIDTH BYTE-LIST BYTE-LIST-HEAD CD TEM (LINE-HEIGHT (FD-LINE-SPACING FD))) (LOOP AS HEADER = (LOGIOR (ASH (READ-KST-HALFWORD STREAM) 18.) (READ-KST-HALFWORD STREAM)) UNTIL (= HEADER -1) UNLESS (= HEADER 1) DO (FERROR NIL "~O where character header expected; KST file misformatted" HEADER) DO (SETQ KERN (READ-KST-HALFWORD STREAM)) (SETQ CHAR-CODE (READ-KST-HALFWORD STREAM)) (SETQ RASTER-WIDTH (READ-KST-HALFWORD STREAM)) (SETQ CHAR-WIDTH (READ-KST-HALFWORD STREAM)) (SETQ CD (MAKE-CHAR-DESCRIPTOR :MAKE-ARRAY (:TYPE ART-1B :LENGTH (LIST LINE-HEIGHT RASTER-WIDTH)))) (SETF (CD-CHAR-WIDTH CD) CHAR-WIDTH) (SETF (CD-CHAR-LEFT-KERN CD) KERN) (FD-STORE-CD FD CD CHAR-CODE) (AND (= CHAR-CODE #\SP) (SETF (FD-SPACE-WIDTH FD) CHAR-WIDTH)) ;; read in the bits of the character (SETQ BYTE-LIST NIL BYTE-LIST-HEAD (LIST NIL NIL NIL NIL)) (DOTIMES (VPOS LINE-HEIGHT) ;; Read in the next row. (DOTIMES (HPOS RASTER-WIDTH) ;; If byte is exhausted, get next byte into (car byte-list) (COND ((ZEROP (\ HPOS 8)) (SETQ BYTE-LIST (READ-KST-BYTES STREAM BYTE-LIST BYTE-LIST-HEAD)))) (SETQ TEM (LOGAND 1 (LSH (CAR BYTE-LIST) (- (\ HPOS 8))))) (ASET TEM CD VPOS HPOS))))) ;; Truncate fd to discard unused elements at the end. (DO ((I (1- (ARRAY-LENGTH FD)) (1- I))) ((OR (MINUSP I) (AREF FD I)) (ADJUST-ARRAY-SIZE FD (1+ I)))) (SETF (FD-FILL-POINTER FD) (ARRAY-LENGTH FD)) ;; Set width of blinker and space fields from the space character. (SETF (FD-BLINKER-WIDTH FD) (FD-SPACE-WIDTH FD))) FD) ;; Read in a kst file and define a font. ;; The font name defaults from the file name. ;;;??? This still assumes that the font length is no more than 200! ;;; It seems hard to fix this. (DEFUN READ-KST-INTO-FONT (FILENAME &OPTIONAL FONTNAME &AUX FONT CHARS-EXIST-TABLE RASTER-WIDTH RASTER-HEIGHT RASTERS-PER-WORD WORDS-PER-CHAR) (MULTIPLE-VALUE (FILENAME FONTNAME) (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "KST")) ;; Read file once to determine font parameters. (MULTIPLE-VALUE (RASTER-WIDTH RASTER-HEIGHT) (READ-KST-MAX-RASTER-WIDTH FILENAME)) ;; If this is a hairy wide font, then instead of writing it directly ;; make a font-descriptor and turn it into a font. (COND ((> RASTER-WIDTH 32.) (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME (READ-KST-INTO-FONT-DESCRIPTOR FILENAME FONTNAME)) FONTNAME) (T (SETQ RASTERS-PER-WORD (FLOOR 32. RASTER-WIDTH)) (SETQ WORDS-PER-CHAR (CEILING RASTER-HEIGHT RASTERS-PER-WORD)) ;; Now that we know the parameters, allocate the font. (SETQ FONT (TV:MAKE-FONT :MAKE-ARRAY (:TYPE 'ART-1B :LENGTH (* WORDS-PER-CHAR 32. 200)))) (SETF (FONT-RASTERS-PER-WORD FONT) RASTERS-PER-WORD) (SETF (FONT-WORDS-PER-CHAR FONT) WORDS-PER-CHAR) (SETF (FONT-RASTER-WIDTH FONT) RASTER-WIDTH) (SETF (FONT-RASTER-HEIGHT FONT) RASTER-HEIGHT) (SETF (FONT-CHAR-HEIGHT FONT) RASTER-HEIGHT) (SETF (FONT-BLINKER-HEIGHT FONT) RASTER-HEIGHT) (SETF (FONT-NAME FONT) FONTNAME) (SETQ CHARS-EXIST-TABLE (MAKE-ARRAY 200 ':TYPE 'ART-1B)) (SETF (FONT-CHARS-EXIST-TABLE FONT) CHARS-EXIST-TABLE) ;; Now actually read in the data of the font. (WITH-OPEN-FILE (STREAM FILENAME '(:FIXNUM :IN :BYTE-SIZE 9.)) ;; Discard KSTID. (DOTIMES (I 4) (FUNCALL STREAM ':TYI)) ;; Discard column position adjust until I find out what it means. (OR (ZEROP (FUNCALL STREAM ':TYI)) (FERROR NIL "Nonzero column-position-adjust in font ~A -- what does that mean?" FONTNAME)) (SETF (FONT-BASELINE FONT) (FUNCALL STREAM ':TYI)) ;; Discard line height (already determined). (READ-KST-HALFWORD STREAM) (LET (KERN CHAR-CODE CHAR-WIDTH CHAR-RASTER-WIDTH BYTE-LIST BYTE-LIST-HEAD TEM BIT-POS WORD-POS (LINE-HEIGHT RASTER-HEIGHT)) (LOOP AS HEADER = (LOGIOR (ASH (READ-KST-HALFWORD STREAM) 18.) (READ-KST-HALFWORD STREAM)) UNTIL (= HEADER -1) UNLESS (= HEADER 1) DO (FERROR NIL "~O where character header expected; KST file misformatted" HEADER) DO (SETQ KERN (READ-KST-HALFWORD STREAM)) (SETQ CHAR-CODE (READ-KST-HALFWORD STREAM)) ;; While all chars have the same raster width in the lisp machine font, ;; we need the raster width stored in the kst file to read the kst file. (SETQ CHAR-RASTER-WIDTH (READ-KST-HALFWORD STREAM)) (SETQ CHAR-WIDTH (READ-KST-HALFWORD STREAM)) (ASET 1 CHARS-EXIST-TABLE CHAR-CODE) ;; Now store the char width and left kern, creating the tables if nec. (COND ((NULL (FONT-CHAR-WIDTH FONT)) (SETF (FONT-CHAR-WIDTH FONT) CHAR-WIDTH)) ((FONT-CHAR-WIDTH-TABLE FONT) (ASET CHAR-WIDTH (FONT-CHAR-WIDTH-TABLE FONT) CHAR-CODE)) ((= CHAR-WIDTH (FONT-CHAR-WIDTH FONT))) (T (SETF (FONT-CHAR-WIDTH-TABLE FONT) (MAKE-ARRAY 200)) (ASET CHAR-WIDTH (FONT-CHAR-WIDTH-TABLE FONT) CHAR-CODE))) (AND (= CHAR-CODE #\SP) (SETF (FONT-CHAR-WIDTH FONT) CHAR-WIDTH)) (COND ((NOT (ZEROP KERN)) (OR (FONT-LEFT-KERN-TABLE FONT) (SETF (FONT-LEFT-KERN-TABLE FONT) ;; Use art-32b so can hold both signs. (MAKE-ARRAY 200 ':TYPE 'ART-INUM))) (ASET KERN (FONT-LEFT-KERN-TABLE FONT) CHAR-CODE))) ;; read in the bits of the character (SETQ BYTE-LIST NIL BYTE-LIST-HEAD (LIST NIL NIL NIL NIL)) (SETQ WORD-POS (* CHAR-CODE WORDS-PER-CHAR) BIT-POS 0) (DOTIMES (VPOS LINE-HEIGHT) ;; Find next row in font - advance to word boundary if nec. (AND (> (+ BIT-POS RASTER-WIDTH) 32.) (SETQ BIT-POS 0 WORD-POS (1+ WORD-POS))) ;; Read in that row. (DOTIMES (HPOS CHAR-RASTER-WIDTH) ;; If byte is exhausted, get next byte into (car byte-list) (COND ((ZEROP (\ HPOS 8)) (SETQ BYTE-LIST (READ-KST-BYTES STREAM BYTE-LIST BYTE-LIST-HEAD)))) (SETQ TEM (LOGAND 1 (LSH (CAR BYTE-LIST) (- (\ HPOS 8))))) (ASET TEM FONT (+ (LSH WORD-POS 5) BIT-POS HPOS))) ;; Advance past this row in the font. (SETQ BIT-POS (+ BIT-POS RASTER-WIDTH))) ))) ;; Set width of blinker and space fields from the space character. (SETF (FONT-BLINKER-WIDTH FONT) (FONT-CHAR-WIDTH FONT)) (SET FONTNAME FONT) (PUTPROP FONTNAME FILENAME 'KST-FILE) FONTNAME))) ;; Scan a kst file and return two values which are the ;; raster width and raster height needed in a TV format font to contain that font. (DEFUN READ-KST-MAX-RASTER-WIDTH (FILENAME &AUX RASTER-HEIGHT (RASTER-WIDTH 0) CHAR-RASTER-WIDTH) (SETQ FILENAME (FS:MERGE-PATHNAME-DEFAULTS FILENAME (PATHNAME-DEFAULTS) "KST")) (WITH-OPEN-FILE (STREAM FILENAME '(:FIXNUM :IN :BYTE-SIZE 9.)) ;; Discard KSTID. (DOTIMES (I 4) (FUNCALL STREAM ':TYI)) ;; Discard column-position-adjust (FUNCALL STREAM ':TYI) ;; Discard baseline. (FUNCALL STREAM ':TYI) ;; Remember font line height as raster height. (SETQ RASTER-HEIGHT (READ-KST-HALFWORD STREAM)) ;; Keep maxing raster widths of characters into raster-width (SETQ RASTER-WIDTH 0) (LOOP AS HEADER = (LOGIOR (ASH (READ-KST-HALFWORD STREAM) 18.) (READ-KST-HALFWORD STREAM)) UNTIL (= HEADER -1) UNLESS (= HEADER 1) DO (FERROR NIL "~O where character header expected; KST file misformatted" HEADER) DO ;; Ignore char's left kern. (READ-KST-HALFWORD STREAM) ;; Ignore its character code. (READ-KST-HALFWORD STREAM) ;; Max in its raster width (SETQ CHAR-RASTER-WIDTH (READ-KST-HALFWORD STREAM)) (SETQ RASTER-WIDTH (MAX RASTER-WIDTH CHAR-RASTER-WIDTH)) ;; Ignore its character width. (READ-KST-HALFWORD STREAM) ;; Skip the bits of the character (LET ((BYTES (* RASTER-HEIGHT (CEILING CHAR-RASTER-WIDTH 8)))) (SETQ BYTES (* 4 (CEILING BYTES 4))) (DOTIMES (I BYTES) (FUNCALL STREAM ':TYI))))) (VALUES RASTER-WIDTH RASTER-HEIGHT)) ;; Fetch the next 8-bit byte where stream is a 9-bit byte stream. ;; byte-list-head should be a list of 4 things we can clobber. ;; byte-list is a tail of it. ;; We advance it, and if it is empty we fill byte-list-head ;; with four more 8-bit bytes and return that. ;; The car of our value is the next byte. ;; Save the value for the byte-list arg next time. (DEFUN READ-KST-BYTES (STREAM BYTE-LIST BYTE-LIST-HEAD) (OR (CDR BYTE-LIST) ;; Exhausted the word - read another. (LET ((HWD1 (READ-KST-HALFWORD STREAM)) (HWD2 (READ-KST-HALFWORD STREAM))) (SETQ BYTE-LIST BYTE-LIST-HEAD) ;; Turn it into 4 8-bit bytes in byte-list. (RPLACA BYTE-LIST (LDB 1210 HWD1)) (RPLACA (CDR BYTE-LIST) (LDB 0210 HWD1)) (RPLACA (CDDR BYTE-LIST) (+ (LSH (LDB 0002 HWD1) 6) (LDB 1406 HWD2))) (RPLACA (CDDDR BYTE-LIST) (LDB 0410 HWD2)) BYTE-LIST))) ;; Read two 9-bit bytes from stream, make an 18-bit halfword, ;; and sign-extend it. (DEFUN READ-KST-HALFWORD (STREAM &AUX HWD) (SETQ HWD (DPB (FUNCALL STREAM ':TYI) 1111 (FUNCALL STREAM ':TYI))) (COND ((BIT-TEST HWD 400000) (LOGIOR HWD -400000)) (T HWD))) ;; Writing KST files ;;; Given FONTNAME and FILENAME from FONTNAME &OPTIONAL FILENAME, canonicalize them. (DEFUN GET-OUTPUT-FILENAME-AND-FONTNAME (FONTNAME FILENAME FILE-TYPE) (DECLARE (RETURN-LIST FONTNAME FILENAME)) (AND (STRINGP FONTNAME) (SETQ FONTNAME (INTERN (STRING-UPCASE FONTNAME) "FONTS"))) (OR FILENAME (SETQ FILENAME (STRING FONTNAME))) (SETQ FILENAME (FS:MERGE-PATHNAME-DEFAULTS FILENAME (PATHNAME-DEFAULTS) FILE-TYPE)) (VALUES FONTNAME FILENAME)) (DEFUN GET-OUTPUT-FILENAME-FROM-FONT-DESCRIPTOR (FONT-DESCRIPTOR FILENAME FILE-TYPE) (OR FILENAME (SETQ FILENAME (STRING (FD-NAME FONT-DESCRIPTOR)))) (FS:MERGE-PATHNAME-DEFAULTS FILENAME (PATHNAME-DEFAULTS) FILE-TYPE)) ;; It would be good to check for chars that are all zero and ;; flush them, and also to compute the actual needed raster width and use it. (DEFUN WRITE-FONT-INTO-KST (FONTNAME &OPTIONAL FILENAME &AUX FONT FONT-LENGTH) (MULTIPLE-VALUE (FONTNAME FILENAME) (GET-OUTPUT-FILENAME-AND-FONTNAME FONTNAME FILENAME "KST")) (SETQ FONT (SYMEVAL FONTNAME)) (SETQ FONT-LENGTH (FONT-FILL-POINTER FONT)) (OR (AND FONT-LENGTH ( FONT-LENGTH 200)) (SETQ FONT-LENGTH 200)) (COND ((FONT-INDEXING-TABLE FONT) (LET ((FD (FONT-NAME-FONT-DESCRIPTOR FONTNAME))) (WRITE-FONT-DESCRIPTOR-INTO-KST FD FILENAME))) (T (AND (> (FONT-RASTER-HEIGHT FONT) (FONT-CHAR-HEIGHT FONT)) (FORMAT T "Warning: font raster height exceeds line height")) (WITH-OPEN-FILE (STREAM FILENAME '(:FIXNUM :OUT :BYTE-SIZE 9.)) ;; Write KSTID as 0. (DOTIMES (I 4) (FUNCALL STREAM ':TYO 0)) ;; Write column position adjust as 0. (FUNCALL STREAM ':TYO 0) ;; Write baseline and height into second header word. (FUNCALL STREAM ':TYO (FONT-BASELINE FONT)) (WRITE-KST-HALFWORD STREAM (FONT-CHAR-HEIGHT FONT)) ;; Then write out all the characters. (LET (KERN-TABLE CHAR-WIDTH-TABLE CHARS-EXIST-TABLE WORD-POS BIT-POS BYTE-COUNT BYTE CHAR-RASTER-WIDTH BYTE-LIST BYTE-LIST-HEAD) (SETQ KERN-TABLE (FONT-LEFT-KERN-TABLE FONT) CHAR-WIDTH-TABLE (FONT-CHAR-WIDTH-TABLE FONT)) (ERRSET (SETQ CHARS-EXIST-TABLE (FONT-CHARS-EXIST-TABLE FONT)) NIL) (DOTIMES (CHAR-CODE FONT-LENGTH) (AND CHARS-EXIST-TABLE (ZEROP (AREF CHARS-EXIST-TABLE CHAR-CODE)) (GO SKIP-CHAR)) ;; Each char must start with a word containing a 1. (WRITE-KST-HALFWORD STREAM 0) (WRITE-KST-HALFWORD STREAM 1) ;; left kern and char code fill the next word. (WRITE-KST-HALFWORD STREAM (OR (AND KERN-TABLE (AREF KERN-TABLE CHAR-CODE)) 0)) (WRITE-KST-HALFWORD STREAM CHAR-CODE) ;; Raster width and char width are the next word. (SETQ CHAR-RASTER-WIDTH (MAX 1 (FONT-CHAR-MIN-RASTER-WIDTH FONT CHAR-CODE))) (WRITE-KST-HALFWORD STREAM CHAR-RASTER-WIDTH) (WRITE-KST-HALFWORD STREAM (COND (CHAR-WIDTH-TABLE (OR (AREF CHAR-WIDTH-TABLE CHAR-CODE) 0)) (T (FONT-CHAR-WIDTH FONT)))) ;; Write out the bits of the character ;; Word-pos and bit-pos are used to point at a bit in the font. (SETQ WORD-POS (* (FONT-WORDS-PER-CHAR FONT) CHAR-CODE)) (SETQ BIT-POS 0 BYTE-COUNT 0) ;; Byte-list and its head are used to accumulate 4 bytes ;; and then output them at once as a word. ;; This is needed because the stream wants 9-bit bytes. (SETQ BYTE-LIST-HEAD (LIST NIL NIL NIL NIL)) (SETQ BYTE-LIST BYTE-LIST-HEAD) (COND ((NOT (ZEROP CHAR-RASTER-WIDTH)) (DOTIMES (VPOS (FONT-CHAR-HEIGHT FONT)) ;; Prepare to extract next row of char from font. (AND (> (+ BIT-POS (FONT-RASTER-WIDTH FONT)) 32.) (SETQ WORD-POS (1+ WORD-POS) BIT-POS 0)) (SETQ BYTE 0) ;; Get the row a bit at a time and fill up 8-bit bytes. ;; Output the bytes when full. Output the excess at the end. ;; Count the bytes output with byte-count (DOTIMES (HPOS CHAR-RASTER-WIDTH) (COND ((AND (= (\ HPOS 8) 0) (NOT (ZEROP HPOS))) (SETQ BYTE-COUNT (1+ BYTE-COUNT)) (SETQ BYTE-LIST (WRITE-KST-BYTE STREAM BYTE BYTE-LIST BYTE-LIST-HEAD)) (SETQ BYTE 0))) (OR ( VPOS (FONT-RASTER-HEIGHT FONT)) (SETQ BYTE (+ BYTE (LSH (AREF FONT (+ (* 32. WORD-POS) HPOS BIT-POS)) (\ HPOS 8)))))) (SETQ BYTE-LIST (WRITE-KST-BYTE STREAM BYTE BYTE-LIST BYTE-LIST-HEAD)) (SETQ BYTE-COUNT (1+ BYTE-COUNT)) (SETQ BIT-POS (+ BIT-POS (FONT-RASTER-WIDTH FONT)))) ;; Pad to a word boundary. (DO () ((ZEROP (\ BYTE-COUNT 4))) (SETQ BYTE-LIST (WRITE-KST-BYTE STREAM 0 BYTE-LIST BYTE-LIST-HEAD)) (SETQ BYTE-COUNT (1+ BYTE-COUNT))))) SKIP-CHAR) ;; Mark end of file with two -1 words. (DOTIMES (I 8) (FUNCALL STREAM ':TYO 777))) (FUNCALL STREAM ':CLOSE) (FUNCALL STREAM ':TRUENAME))))) (DEFUN WRITE-FONT-DESCRIPTOR-INTO-KST (FD &OPTIONAL FILENAME &AUX (FONT-LENGTH (ARRAY-ACTIVE-LENGTH FD))) (SETQ FILENAME (GET-OUTPUT-FILENAME-FROM-FONT-DESCRIPTOR FD FILENAME "KST")) (WITH-OPEN-FILE (STREAM FILENAME '(:FIXNUM :OUT :BYTE-SIZE 9.)) ;; Write KSTID as 0. (DOTIMES (I 4) (FUNCALL STREAM ':TYO 0)) ;; Write column position adjust as 0. (FUNCALL STREAM ':TYO 0) ;; Write baseline and height into second header word. (FUNCALL STREAM ':TYO (FD-BASELINE FD)) (WRITE-KST-HALFWORD STREAM (FD-LINE-SPACING FD)) ;; Then write out all the characters. (LET (CD CHAR-HEIGHT BYTE-COUNT BYTE BYTE-LIST BYTE-LIST-HEAD) (DOTIMES (CHAR-CODE FONT-LENGTH) (COND ((AND (SETQ CD (AREF FD CHAR-CODE)) ;; Wide fonts without chars-exist-tables can have 0-width chars. (OR (NOT (ZEROP (ARRAY-DIMENSION CD 1))) (NOT (ZEROP (CD-CHAR-WIDTH CD))))) ;; Each char must start with a word containing a 1. (WRITE-KST-HALFWORD STREAM 0) (WRITE-KST-HALFWORD STREAM 1) ;; left kern and char code fill the next word. (WRITE-KST-HALFWORD STREAM (CD-CHAR-LEFT-KERN CD)) (WRITE-KST-HALFWORD STREAM CHAR-CODE) ;; Raster width and char width are the next word. (WRITE-KST-HALFWORD STREAM (ARRAY-DIMENSION CD 1)) (WRITE-KST-HALFWORD STREAM (CD-CHAR-WIDTH CD)) ;; Write out the bits of the character ;; Byte-list and its head are used to accumulate 4 bytes ;; and then output them at once as a word. ;; This is needed because the stream wants 9-bit bytes. (SETQ BYTE-LIST-HEAD (LIST NIL NIL NIL NIL)) (SETQ BYTE-LIST BYTE-LIST-HEAD) (SETQ BYTE-COUNT 0) (SETQ CHAR-HEIGHT (ARRAY-DIMENSION CD 0)) (AND (> CHAR-HEIGHT (FD-LINE-SPACING FD)) (FERROR NIL "Character ~C height exceeds font line height in KST file" CHAR-CODE)) (COND ((NOT (ZEROP (ARRAY-DIMENSION CD 1))) (DOTIMES (VPOS (FD-LINE-SPACING FD)) ;; Prepare to extract next row of char from font. (SETQ BYTE 0) ;; Get the row a bit at a time and fill up 8-bit bytes. ;; Output the bytes when full. Output the excess at the end. ;; Count the bytes output with byte-count (DOTIMES (HPOS (ARRAY-DIMENSION CD 1)) (COND ((AND (= (\ HPOS 8) 0) (NOT (ZEROP HPOS))) (SETQ BYTE-COUNT (1+ BYTE-COUNT)) (SETQ BYTE-LIST (WRITE-KST-BYTE STREAM BYTE BYTE-LIST BYTE-LIST-HEAD)) (SETQ BYTE 0))) (OR ( VPOS CHAR-HEIGHT) (SETQ BYTE (+ BYTE (LSH (AREF CD VPOS HPOS) (\ HPOS 8)))))) (SETQ BYTE-LIST (WRITE-KST-BYTE STREAM BYTE BYTE-LIST BYTE-LIST-HEAD)) (SETQ BYTE-COUNT (1+ BYTE-COUNT))) ;; Pad to a word boundary. (DO () ((ZEROP (\ BYTE-COUNT 4))) (SETQ BYTE-LIST (WRITE-KST-BYTE STREAM 0 BYTE-LIST BYTE-LIST-HEAD)) (SETQ BYTE-COUNT (1+ BYTE-COUNT)))))))) ;; Mark end of file with two -1 words. (DOTIMES (I 8) (FUNCALL STREAM ':TYO 777))) (FUNCALL STREAM ':CLOSE) (FUNCALL STREAM ':TRUENAME))) ;; Write an 8-bit byte to the kst file. We pack 4 bytes per word. ;; The stream is assumed to want 9-bit bytes. ;; Byte-list-head should be a list of length 4 we can clobber. ;; byte-list should initially be the same thing; we return a new value to set it to. (DEFUN WRITE-KST-BYTE (STREAM BYTE BYTE-LIST BYTE-LIST-HEAD) (RPLACA BYTE-LIST BYTE) (POP BYTE-LIST) (COND ((NULL BYTE-LIST) (SETQ BYTE-LIST BYTE-LIST-HEAD) (WRITE-KST-HALFWORD STREAM (+ (LSH (FIRST BYTE-LIST) 10.) (LSH (SECOND BYTE-LIST) 2.) (LDB 0602 (THIRD BYTE-LIST)))) (WRITE-KST-HALFWORD STREAM (+ (LSH (LDB 0006 (THIRD BYTE-LIST)) 12.) (LSH (FOURTH BYTE-LIST) 4))))) BYTE-LIST) (DEFUN WRITE-KST-HALFWORD (STREAM HALFWORD) (FUNCALL STREAM ':TYO (LDB 1111 HALFWORD)) (FUNCALL STREAM ':TYO (LDB 0011 HALFWORD))) ;; Compute the smallest raster width needed to store the specified char ;; as defined by the specified font. ;; low-level means we are looking at one sub-character in a wide font. (DEFUN FONT-CHAR-MIN-RASTER-WIDTH (FONT CHAR-CODE &OPTIONAL LOW-LEVEL &AUX BIT-POS WORD-POS TEM MIN-RASTER-WIDTH F-RASTER-WIDTH RASTER-HEIGHT) (COND ((AND (NOT LOW-LEVEL) (SETQ TEM (FONT-INDEXING-TABLE FONT))) ;; If it's a wide font, go by the number of vertical stripes, ;; but also see how wide the rightmost stripe really needs to be. (LET ((START-IDX (AREF TEM CHAR-CODE)) (END-IDX (AREF TEM (1+ CHAR-CODE)))) (IF (= START-IDX END-IDX) 0 (MAX 0 (+ (* 32. (- END-IDX START-IDX)) -32. (FONT-CHAR-MIN-RASTER-WIDTH FONT (1- END-IDX) T)))))) (T (SETQ WORD-POS (* CHAR-CODE (FONT-WORDS-PER-CHAR FONT)) BIT-POS 0 MIN-RASTER-WIDTH 0 F-RASTER-WIDTH (FONT-RASTER-WIDTH FONT) RASTER-HEIGHT (FONT-RASTER-HEIGHT FONT)) (DOTIMES (VPOS RASTER-HEIGHT) (AND (> (+ BIT-POS F-RASTER-WIDTH) 32.) (SETQ BIT-POS 0 WORD-POS (1+ WORD-POS))) (DO ((HPOS 0 (1+ HPOS)) (INDEX (+ BIT-POS (LSH WORD-POS 5)) (1+ INDEX))) ((= HPOS F-RASTER-WIDTH)) (OR (ZEROP (AREF FONT INDEX)) (SETQ MIN-RASTER-WIDTH (MAX (1+ HPOS) MIN-RASTER-WIDTH)))) (SETQ BIT-POS (+ F-RASTER-WIDTH BIT-POS))) MIN-RASTER-WIDTH))) ;; ALTO .AL format ;;;??? Not yet converted to load more than 200 chars into a font. ;; Load an ALTO font file into a font, the easy way, via a font descriptor (DEFUN READ-AL-INTO-FONT (FILENAME &OPTIONAL FONTNAME) (MULTIPLE-VALUE (FILENAME FONTNAME) (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AL")) (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME (READ-AL-INTO-FONT-DESCRIPTOR FILENAME FONTNAME)) FONTNAME) ;; Load an ALTO font file into a font descriptor (DEFUN READ-AL-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME &AUX FD ARRAY LINE-HEIGHT PROPORTIONAL MAX-WIDTH) (MULTIPLE-VALUE (FILENAME FONTNAME) (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AL")) (SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME)) (SETF (FD-NAME FD) FONTNAME) (WITH-OPEN-FILE (STREAM FILENAME '(:IN :FIXNUM)) (SETQ LINE-HEIGHT (FUNCALL STREAM ':TYI)) (SETF (FD-LINE-SPACING FD) LINE-HEIGHT) (SETF (FD-BLINKER-HEIGHT FD) LINE-HEIGHT) (LET ((BASELINE-AND-MAX-WIDTH (FUNCALL STREAM ':TYI))) (SETQ PROPORTIONAL (LDB-TEST 1701 BASELINE-AND-MAX-WIDTH)) (SETF (FD-BASELINE FD) (LDB 1007 BASELINE-AND-MAX-WIDTH)) (SETF (FD-SPACE-WIDTH FD) (SETQ MAX-WIDTH (LDB 0010 BASELINE-AND-MAX-WIDTH)))) (SETQ ARRAY (MAKE-ARRAY 1000. ':TYPE 'ART-16B ':LEADER-LIST '(0))) (DO CH (FUNCALL STREAM ':TYI) (FUNCALL STREAM ':TYI) (NULL CH) (ARRAY-PUSH-EXTEND ARRAY CH))) (DO ((CH 0 (1+ CH)) (CD) (CHAR-WIDTH)) (( CH 200)) ;Alto font could have 400 characters, our fonts don't yet (SETQ CHAR-WIDTH 0) (DO ((IDX CH) (XW)) (NIL) (SETQ IDX (+ IDX (AREF ARRAY IDX))) (SETQ XW (AREF ARRAY IDX)) (IF (ZEROP (PROG1 (LOGAND XW 1) (SETQ XW (FLOOR XW 2)))) (SETQ CHAR-WIDTH (+ CHAR-WIDTH 16.) IDX XW) (RETURN (SETQ CHAR-WIDTH (+ CHAR-WIDTH XW))))) (SETQ CD (MAKE-CHAR-DESCRIPTOR :MAKE-ARRAY (:TYPE ART-1B :LENGTH (LIST LINE-HEIGHT CHAR-WIDTH)))) (SETF (CD-CHAR-WIDTH CD) CHAR-WIDTH) (AND (= CH #\SP) (SETF (FD-SPACE-WIDTH FD) CHAR-WIDTH)) (SETF (CD-CHAR-LEFT-KERN CD) 0) (FD-STORE-CD FD CD CH) (READ-AL-INTO-FONT-DESCRIPTOR-1 CD ARRAY CH 0)) (SETF (FD-FILL-POINTER FD) 200) ;; Set width of blinker and space fields from the space character. (SETF (FD-BLINKER-WIDTH FD) (FD-SPACE-WIDTH FD)) FD) ;;;IDX is the address of the character-pointer (DEFUN READ-AL-INTO-FONT-DESCRIPTOR-1 (CD ARRAY IDX XOFF &AUX XW HD-AND-XH) (SETQ IDX (+ IDX (AREF ARRAY IDX))) (SETQ XW (AREF ARRAY IDX) HD-AND-XH (AREF ARRAY (1+ IDX))) (DO ((I (- IDX (LDB 0010 HD-AND-XH)) (1+ I)) (Y (LDB 1010 HD-AND-XH) (1+ Y))) ((= I IDX)) (DO ((BITS (AREF ARRAY I) (LSH BITS 1)) (X XOFF (1+ X)) (CW (CD-CHAR-WIDTH CD))) ((OR (ZEROP BITS) ( X CW))) ;Can be garbage to right of raster (AND (BIT-TEST 100000 BITS) (ASET 1 CD Y X)))) (OR (BIT-TEST 1 XW) (READ-AL-INTO-FONT-DESCRIPTOR-1 CD ARRAY (FLOOR XW 2) (+ XOFF 16.)))) (DEFUN WRITE-FONT-INTO-AL (FONTNAME &OPTIONAL FILENAME) (MULTIPLE-VALUE (FONTNAME FILENAME) (GET-OUTPUT-FILENAME-AND-FONTNAME FONTNAME FILENAME "AL")) (LET ((FD (FONT-NAME-FONT-DESCRIPTOR FONTNAME))) (WRITE-FONT-DESCRIPTOR-INTO-AL FD FILENAME))) ;I don't think this does the desired thing for variable-width ("proportional") fonts (DEFUN WRITE-FONT-DESCRIPTOR-INTO-AL (FD &OPTIONAL FILENAME &AUX ARRAY CARRAY LINE-HEIGHT) (SETQ FILENAME (GET-OUTPUT-FILENAME-FROM-FONT-DESCRIPTOR FD FILENAME "AL")) (WITH-OPEN-FILE (STREAM FILENAME '(:OUT :FIXNUM)) (FUNCALL STREAM ':TYO (SETQ LINE-HEIGHT (FD-LINE-SPACING FD))) (FUNCALL STREAM ':TYO (DPB (FD-BASELINE FD) 1007 (FD-SPACE-WIDTH FD))) (SETQ ARRAY (MAKE-ARRAY 1000. ':TYPE 'ART-16B ':LEADER-LIST '(0)) ;Data array CARRAY (MAKE-ARRAY 400 ':TYPE 'ART-16B ':LEADER-LIST '(400))) ;Non self-rel chars ;; Store dummy (ARRAY-PUSH-EXTEND ARRAY 1) (ARRAY-PUSH-EXTEND ARRAY 0) (LOOP FOR CH FROM 0 BELOW (LENGTH FD) AS CD = (AREF FD CH) WHEN CD DO (LOOP WITH CH = CH WITH (XW HD-XH) WITH CHAR-WIDTH = (CD-CHAR-WIDTH CD) FOR XOFF FROM 0 BY 16. BELOW CHAR-WIDTH DO (SETQ HD-XH (WRITE-AL-COLUMN CD XOFF ARRAY)) (ASET (ARRAY-LEADER ARRAY 0) CARRAY CH) (SETQ XW (IF (> (- CHAR-WIDTH XOFF) 16.) (* (SETQ CH (PROG1 (ARRAY-LEADER CARRAY 0) (ARRAY-PUSH-EXTEND CARRAY 0))) 2) (1+ (* (- CHAR-WIDTH XOFF) 2)))) (ARRAY-PUSH-EXTEND ARRAY XW) (ARRAY-PUSH-EXTEND ARRAY HD-XH)) ELSE DO (ASET 0 CARRAY CH)) (LOOP FOR I FROM 0 BELOW (ARRAY-ACTIVE-LENGTH CARRAY) ;Make self-relative DO (ASET (- (+ (AREF CARRAY I) (ARRAY-ACTIVE-LENGTH CARRAY)) I) CARRAY I)) (FUNCALL STREAM ':STRING-OUT CARRAY) (FUNCALL STREAM ':STRING-OUT ARRAY) (FUNCALL STREAM ':CLOSE) (FUNCALL STREAM ':TRUENAME))) (DEFUN WRITE-AL-COLUMN-ROW (CD XOFF Y) (LOOP WITH STUFF = 0 FOR X FROM (+ XOFF (CD-CHAR-LEFT-KERN CD)) BELOW (ARRAY-DIMENSION CD 1) AS MASK = 100000 THEN (LSH MASK -1) UNTIL (ZEROP MASK) WHEN (AND (NOT (MINUSP X)) (NOT (ZEROP (AREF CD Y X)))) DO (SETQ STUFF (LOGIOR STUFF MASK)) FINALLY (RETURN STUFF))) (DEFUN WRITE-AL-COLUMN (CD XOFF ARRAY &AUX (HD 0) (XC 0)) (LOOP FOR Y FROM 0 TO (LOOP FOR Y FROM (1- (ARRAY-DIMENSION CD 0)) DOWNTO 0 WHILE (ZEROP (WRITE-AL-COLUMN-ROW CD XOFF Y)) FINALLY (RETURN Y)) AS ROW = (WRITE-AL-COLUMN-ROW CD XOFF Y) DO (IF (AND (ZEROP ROW) (ZEROP XC)) (SETQ HD (1+ HD)) (ARRAY-PUSH-EXTEND ARRAY ROW) (SETQ XC (1+ XC)))) (DPB HD 1010 XC)) ;;;; ALTO .KS format ;;; Load a kerned-strike file into a font (DEFUN READ-KS-INTO-FONT (FILENAME &OPTIONAL FONTNAME) (MULTIPLE-VALUE (FILENAME FONTNAME) (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "KS")) (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME (READ-KS-INTO-FONT-DESCRIPTOR FILENAME FONTNAME)) FONTNAME) ;;; Load a kerned-strike font file into a font descriptor (DEFUN READ-KS-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME &AUX FD LINE-HEIGHT MAX-WIDTH WD FIXED-WIDTH MIN-CHAR MAX-CHAR STRIKE-NWDS FBBOX ASCENT DESCENT WORDS-PER-RASTER BITMAP BITMAP16 INDEX) (MULTIPLE-VALUE (FILENAME FONTNAME) (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "KS")) (SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME)) (SETF (FD-NAME FD) FONTNAME) (WITH-OPEN-FILE (STREAM FILENAME '(:IN :FIXNUM)) (SETQ WD (FUNCALL STREAM ':TYI)) (OR (BIT-TEST #o100000 WD) (FERROR NIL "Not /"new format/"")) (AND (BIT-TEST #o40000 WD) (FERROR NIL "StrikeIndex format not understood")) (SETQ FIXED-WIDTH (BIT-TEST 20000 WD)) (OR (BIT-TEST #o10000 WD) (FERROR NIL "PlainStrike format not understood")) (SETQ MIN-CHAR (SEND STREAM ':TYI) MAX-CHAR (SEND STREAM ':TYI)) (SETQ MAX-WIDTH (SEND STREAM ':TYI)) (SETQ FBBOX (SEND STREAM ':TYI)) ;Font bounding-box X-offset (IF (BIT-TEST #o100000 FBBOX) (SETQ FBBOX (- FBBOX #o200000))) ;signed (DOTIMES (I 3) (SEND STREAM ':TYI)) ;Ignore rest of font bounding box (SETQ STRIKE-NWDS (SEND STREAM ':TYI) ASCENT (SEND STREAM ':TYI) DESCENT (SEND STREAM ':TYI)) (SETQ LINE-HEIGHT (+ ASCENT DESCENT)) (FUNCALL STREAM ':TYI) ;Ignore xoffset (SETQ WORDS-PER-RASTER (FUNCALL STREAM ':TYI)) (SETF (FD-LINE-SPACING FD) LINE-HEIGHT) (SETF (FD-BLINKER-HEIGHT FD) LINE-HEIGHT) (SETF (FD-BASELINE FD) ASCENT) (SETF (FD-SPACE-WIDTH FD) MAX-WIDTH) ;; Now copy the bitmap (the goddamn words are bit-reversed!) (SETQ BITMAP16 (MAKE-ARRAY (LIST WORDS-PER-RASTER LINE-HEIGHT) ':TYPE 'ART-16B) BITMAP (MAKE-ARRAY (LIST (* WORDS-PER-RASTER 16.) LINE-HEIGHT) ':TYPE 'ART-1B ':DISPLACED-TO BITMAP16)) (DOTIMES (Y LINE-HEIGHT) (DOTIMES (X WORDS-PER-RASTER) (ASET (FUNCALL STREAM ':TYI) BITMAP16 (- WORDS-PER-RASTER X 1) Y))) ;; Copy the index segment (SETQ INDEX (MAKE-ARRAY (+ (- MAX-CHAR MIN-CHAR) 3) ':TYPE 'ART-16B)) (DOTIMES (I (ARRAY-LENGTH INDEX)) (ASET (FUNCALL STREAM ':TYI) INDEX I)) ;; Read the width table and make the characters (LOOP FOR CH FROM MIN-CHAR TO (MIN (1+ MAX-CHAR) #o177) WITH CD AS XLEFT = (AREF INDEX (- CH MIN-CHAR)) AS XRIGHT = (AREF INDEX (1+ (- CH MIN-CHAR))) AS WDE = (FUNCALL STREAM ':TYI) UNLESS (= WDE #o177777) ;Nonexistent character DO (SETQ CD (MAKE-CHAR-DESCRIPTOR :MAKE-ARRAY (:TYPE ART-1B :LENGTH (LIST LINE-HEIGHT (- XRIGHT XLEFT))))) (SETF (CD-CHAR-WIDTH CD) (LDB 0010 WDE)) (AND (= CH #\SP) (SETF (FD-SPACE-WIDTH FD) (CD-CHAR-WIDTH CD))) (SETF (CD-CHAR-LEFT-KERN CD) (- (+ (LDB #o1010 WDE) FBBOX))) (ASET CD FD CH) (LOOP FOR Y FROM 0 BELOW LINE-HEIGHT DO (LOOP FOR X FROM 0 BELOW (- XRIGHT XLEFT) AS BMX DOWNFROM (- (ARRAY-DIMENSION BITMAP 0) XLEFT 1) DO (ASET (AREF BITMAP BMX Y) CD Y X)))) (SETF (FD-FILL-POINTER FD) 200) ;; Set width of blinker and space fields from the space character. (SETF (FD-BLINKER-WIDTH FD) (FD-SPACE-WIDTH FD)) FD)) ;; AC files (DEFMACRO SIGN-EXTEND (16BIT-WORD) `(LET ((WORD ,16BIT-WORD)) (IF ( WORD #o100000) (- WORD #o200000) WORD))) (DEFMACRO HIGH-BYTE (WORD) `(LSH ,WORD -8)) (DEFMACRO LOW-BYTE (WORD) `(BOOLE 1 #o377 ,WORD)) ;;; Get next 16-bit word from input-file (DEFUN NEXT-WORD () (DECLARE (SPECIAL INPUT-FILE)) (SEND INPUT-FILE ':TYI "Unexpected EOF on AC file")) ;;; Read in an AC file as a Lisp machine font. (DEFUN READ-AC-INTO-FONT (FILENAME &OPTIONAL FONTNAME) (MULTIPLE-VALUE (FILENAME FONTNAME) (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AC")) (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME (READ-AC-INTO-FONT-DESCRIPTOR FILENAME FONTNAME)) FONTNAME) ;; Copied from LAD: RELEASE-3.IO1; FNTCNV.LISP#86 on 2-Oct-86 05:27:07 (DEFUN READ-AC-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME &AUX FAMILY-NAME FACE-CODE POINT-SIZE) (MULTIPLE-VALUE (FILENAME FONTNAME) (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AC")) (WITH-OPEN-FILE (INPUT-FILE FILENAME '(:READ :FIXNUM)) (DECLARE (SPECIAL INPUT-FILE)) (SETF (VALUES FAMILY-NAME FACE-CODE POINT-SIZE) (PRESS:DECODE-FONT-NAME (STRING FONTNAME))) (LET ((CODE-ALIST NIL) (SEGMENT-DATA NIL) FAMILY-CODE TEM SEGMENT FD (WD 0)) (SETQ WD (NEXT-WORD)) ;; Read IXN entries (type 1) (DO () ((NOT (= (LSH WD -12.) 1))) (LET ((CODE (NEXT-WORD)) (NAME (PRESS:BCPL-STRING 20. INPUT-FILE))) (PUSH (CONS CODE NAME) CODE-ALIST)) (SETQ WD (NEXT-WORD))) ;; Find out the code number for the font family to be used, ;; either the specified one or the only one. (COND (FAMILY-NAME (OR (SETQ FAMILY-CODE (CAR (RASS 'EQUALP FAMILY-NAME CODE-ALIST))) (FERROR NIL "Font family ~A not present in AC file" FAMILY-NAME))) ((CDR CODE-ALIST) (FERROR NIL "Font dictionary ~A: font family not specified" FILENAME)) (T (SETQ FAMILY-CODE (CAAR CODE-ALIST)))) ;; Read Index Entries (type 3) for AC segments. (DO () ((NOT (= (LSH WD -12.) 3))) (SETQ WD (NEXT-WORD)) ;family,,face (SETQ TEM (LIST (HIGH-BYTE WD) ;Family code number. (PRESS:DECODE-FACE (LOW-BYTE WD)) ;Face name (PROGN (SETQ WD (NEXT-WORD)) ;bc,,ec (HIGH-BYTE WD)) ;First code (LOW-BYTE WD) ;Last code (NEXT-WORD) ;Size (NEXT-WORD) ;Rotation (+ (LSH (NEXT-WORD) 16.) (NEXT-WORD)) ;Segment SA (+ (LSH (NEXT-WORD) 16.) (NEXT-WORD)) ;Segment Len (NEXT-WORD) ;horiz resolution (NEXT-WORD))) ;vert resolution (AND (= (CAR TEM) FAMILY-CODE) (PUSH TEM SEGMENT-DATA)) (SETQ WD (NEXT-WORD))) ;; Now should have type-0 entry (end of index) (SELECTQ (LSH WD -12.) (0 ) (5 (FERROR NIL "There are OrbitChars segments in this file -- I don't grok them")) (OTHERWISE (FERROR NIL "~O - Garbage in file where type 0 IX expected" WD))) ;; Now either there should be only one segment or the face code and size ;; should have been specified. (COND ((AND POINT-SIZE FACE-CODE) (DOLIST (SEG SEGMENT-DATA) (AND (STRING-EQUAL (CADR SEG) FACE-CODE) (= (ROUND (* (FIFTH SEG) 72.) 2540.) POINT-SIZE) (RETURN (SETQ SEGMENT SEG)))) (OR SEGMENT (FERROR NIL "Font ~A not found in AC file" FONTNAME))) ((CDR SEGMENT-DATA) (FERROR "Font dictionary ~A: point size or face code not specified" FILENAME)) (T (SETQ SEGMENT (CAR SEGMENT-DATA) POINT-SIZE (ROUND (* (FIFTH SEGMENT) 72.) 2540.)))) (FUNCALL INPUT-FILE ':SET-POINTER (SEVENTH SEGMENT)) (LET ((BC (THIRD SEGMENT)) (EC (FOURTH SEGMENT)) (BASELINE 0) (XWIDTHS (MAKE-ARRAY #o400)) (YWIDTHS (MAKE-ARRAY #o400)) (BOX-X-OFFSET (MAKE-ARRAY #o400)) (BOX-Y-OFFSET (MAKE-ARRAY #o400)) (BOX-X-SIZE (MAKE-ARRAY #o400)) (BOX-Y-SIZE (MAKE-ARRAY #o400)) (CHAR-DATA-POSITION (MAKE-ARRAY #o400)) LINE-HEIGHT) ;; read in the widths info from the segment. (DO ((I BC (1+ I))) ((> I EC)) (ASET (+ (SIGN-EXTEND (NEXT-WORD)) (// (NEXT-WORD) 65536.0)) XWIDTHS I) (ASET (+ (SIGN-EXTEND (NEXT-WORD)) (// (NEXT-WORD) 65536.0)) YWIDTHS I) (ASET (SIGN-EXTEND (NEXT-WORD)) BOX-X-OFFSET I) (ASET (SIGN-EXTEND (NEXT-WORD)) BOX-Y-OFFSET I) (ASET (SIGN-EXTEND (NEXT-WORD)) BOX-X-SIZE I) (ASET (SIGN-EXTEND (NEXT-WORD)) BOX-Y-SIZE I)) ;; Read relative pointers to character data beginnings ;; and convert them to absolute pointers within the file. (DO ((I BC (1+ I)) (STARTING-POSITION (FUNCALL INPUT-FILE ':READ-POINTER))) ((> I EC)) (SETF (AREF CHAR-DATA-POSITION I) (+ (LSH (NEXT-WORD) 32.) (NEXT-WORD) STARTING-POSITION))) (SETQ FONTNAME (STRING-APPEND (CDR (ASSQ FAMILY-CODE CODE-ALIST)) (FORMAT NIL "~D" POINT-SIZE) (OR (SECOND SEGMENT) ""))) (SETQ FONTNAME (INTERN (STRING-UPCASE FONTNAME) "FONTS")) (SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME :MAKE-ARRAY (:LENGTH (1+ EC)))) (SETF (FD-FILL-POINTER FD) (1+ EC)) (SETF (FD-VERT-RESOLUTION FD) (NTH 9 SEGMENT)) (SETF (FD-HORIZ-RESOLUTION FD) (NTH 8 SEGMENT)) (SETF (FD-ROTATION FD) (NTH 5 SEGMENT)) (DO ((HEIGHT 0) (I BC (1+ I))) ((> I EC) (SETQ LINE-HEIGHT (+ HEIGHT BASELINE)) (SETF (FD-LINE-SPACING FD) LINE-HEIGHT) (SETF (FD-BLINKER-HEIGHT FD) LINE-HEIGHT) (SETF (FD-BASELINE FD) (- LINE-HEIGHT BASELINE))) (COND (( (AREF BOX-Y-SIZE I) -1) (SETQ HEIGHT (MAX HEIGHT (+ (AREF BOX-Y-SIZE I) (AREF BOX-Y-OFFSET I)))))) (COND (( (AREF BOX-Y-SIZE I) -1) (SETQ BASELINE (MAX BASELINE (- (AREF BOX-Y-OFFSET I))))))) (DO ((CH BC (1+ CH)) (CHAR-WIDTH) (RASTER-HEIGHT) (RASTER-WIDTH) (CHAR-Y-OFFSET) (WD) (CD)) ((> CH EC)) (COND (( (AREF BOX-Y-SIZE CH) -1) (SETQ CHAR-WIDTH (AREF XWIDTHS CH)) (SETQ RASTER-WIDTH (AREF BOX-X-SIZE CH)) (SETQ RASTER-HEIGHT (AREF BOX-Y-SIZE CH)) (SETQ CHAR-Y-OFFSET (AREF BOX-Y-OFFSET CH)) (SETQ CD (MAKE-CHAR-DESCRIPTOR :MAKE-ARRAY (:TYPE ART-1B :LENGTH (LIST LINE-HEIGHT RASTER-WIDTH)))) (SETF (CD-CHAR-WIDTH CD) CHAR-WIDTH) (SETF (CD-CHAR-VERT-WIDTH CD) (AREF YWIDTHS CH)) (AND (= CH #\SP) (SETF (FD-SPACE-WIDTH FD) CHAR-WIDTH)) (SETF (CD-CHAR-LEFT-KERN CD) (- (AREF BOX-X-OFFSET CH))) ;; Store the CD in the font descriptor (ASET CD FD CH) ;; Verify that the relative pointer to this character's data was right. (OR (= (AREF CHAR-DATA-POSITION CH) (FUNCALL INPUT-FILE ':READ-POINTER)) (FERROR NIL "Inconsistent character data pointer for character ~C" CH)) ;; Skip a word of redundant info on raster height and width. (LET ((TEM (NEXT-WORD))) (OR (= TEM (DPB (CEILING RASTER-HEIGHT #o20) #o1206 RASTER-WIDTH)) (FERROR NIL "Inconsistent raster size data at front of character bits for character ~C" CH))) ;; Raster lines go vertically up, leftmost line first. (DOTIMES (HPOS RASTER-WIDTH) ;; Read in the next vertical scan line. (DOTIMES (VPOS RASTER-HEIGHT) ;; If wd is exhausted, get next word into wd (COND ((ZEROP (\ VPOS 16.)) (SETQ WD (NEXT-WORD)))) (SETQ TEM (LDB #o1701 (LSH WD (\ VPOS 16.)))) (OR ( (+ VPOS BASELINE CHAR-Y-OFFSET) LINE-HEIGHT) (ASET TEM CD (- LINE-HEIGHT 1 (+ VPOS BASELINE CHAR-Y-OFFSET)) HPOS))))))) ;; Set width of blinker and space fields from the space character. (SETF (FD-BLINKER-WIDTH FD) (FD-SPACE-WIDTH FD)) (OR (= (FUNCALL INPUT-FILE ':READ-POINTER) (+ (NTH 6 SEGMENT) (NTH 7 SEGMENT))) (FERROR NIL "Inconsistent data-length in index of AC file")) FD)))) ;;; This returns in array units, which are from the upper-left corner (DEFUN CD-RASTER-RANGE (CD) (DECLARE (RETURN-LIST MINX MINY MAXX MAXY)) (LOOP WITH HEIGHT = (ARRAY-DIMENSION CD 0) AND WIDTH = (ARRAY-DIMENSION CD 1) WITH MINX = WIDTH AND MINY = HEIGHT AND MAXX = 0 AND MAXY = 0 FOR X FROM 0 BELOW WIDTH DO (LOOP FOR Y FROM 0 BELOW HEIGHT WHEN (NOT (ZEROP (AREF CD Y X))) DO (SETQ MINX (MIN MINX X) MAXX (MAX MAXX (1+ X)) MINY (MIN MINY Y) MAXY (MAX MAXY (1+ Y)))) FINALLY (RETURN (VALUES (MIN MINX MAXX) (MIN MINY MAXY) MAXX MAXY)))) ;Return how many rasters are empty (all 0) ;at the bottom of the character and at the top. (DEFUN CD-UNUSED-RASTER-HEIGHT (CD) (DECLARE (RETURN-LIST BOTTOM TOP)) (LET* ((DIMS (ARRAY-DIMENSIONS CD)) BOTTOM TOP (HEIGHT (CAR DIMS)) (WIDTH (CADR DIMS))) (DOTIMES (I HEIGHT) (AND (DOTIMES (J WIDTH) (AND (NOT (ZEROP (AREF CD I J))) (RETURN T))) (RETURN (SETQ TOP I)))) (DOTIMES (I HEIGHT) (AND (DOTIMES (J WIDTH) (AND (NOT (ZEROP (AREF CD (- HEIGHT I 1) J))) (RETURN T))) (RETURN (SETQ BOTTOM I)))) (COND (TOP (VALUES BOTTOM TOP)) ;; Handle case where all data is empty. (T (VALUES HEIGHT 0))))) ;Write an AC file from a Lisp machine font. (DEFUN WRITE-FONT-INTO-AC (FONTNAME &OPTIONAL FILENAME) (MULTIPLE-VALUE (FONTNAME FILENAME) (GET-OUTPUT-FILENAME-AND-FONTNAME FONTNAME FILENAME "AC")) (LET ((FD (FONT-NAME-FONT-DESCRIPTOR FONTNAME))) (WRITE-FONT-DESCRIPTOR-INTO-AC FD FILENAME))) (DEFUN WRITE-FONT-DESCRIPTOR-INTO-AC (FD &OPTIONAL FILENAME &AUX FAMILY-NAME FACE-CODE POINT-SIZE BC EC) (SETQ FILENAME (GET-OUTPUT-FILENAME-FROM-FONT-DESCRIPTOR FD FILENAME "AC")) (SETF (VALUES FAMILY-NAME FACE-CODE POINT-SIZE) (PRESS:DECODE-FONT-NAME (STRING (FD-NAME FD)))) (WITH-OPEN-FILE (OUTPUT-FILE FILENAME '(:WRITE :FIXNUM)) (LET* ((FONT-LENGTH (ARRAY-ACTIVE-LENGTH FD)) UNUSED-TOP-RASTERS UNUSED-BOTTOM-RASTERS CHAR-DATA-SIZE-TABLE (TOTAL-DATA-SIZE 0)) (AND (> FONT-LENGTH #o400) (PROGN (SETQ FONT-LENGTH #o400) (CERROR T NIL NIL "Font contains codes above 377 which AC file cannot hold" ))) (SETQ UNUSED-TOP-RASTERS (MAKE-ARRAY FONT-LENGTH) UNUSED-BOTTOM-RASTERS (MAKE-ARRAY FONT-LENGTH)) ;; Figure out range of chars to actually output. (DOTIMES (I FONT-LENGTH) (AND (AREF FD I) (RETURN (SETQ BC I)))) (DO ((I (1- FONT-LENGTH) (1- I))) ((MINUSP I)) (AND (AREF FD I) (RETURN (SETQ EC I)))) ;; Precompute how much data each character is going to require. ;; Count number of words of rasters, plus 1 word of info before them. (SETQ CHAR-DATA-SIZE-TABLE (MAKE-ARRAY FONT-LENGTH)) (DOTIMES (CHAR-CODE FONT-LENGTH) (LET* ((CD (AREF FD CHAR-CODE)) (DATA-SIZE 0)) (AND CD (MULTIPLE-VALUE-BIND (TEM1 TEM2) (CD-UNUSED-RASTER-HEIGHT CD) (SETF (AREF UNUSED-BOTTOM-RASTERS CHAR-CODE) TEM1) (SETF (AREF UNUSED-TOP-RASTERS CHAR-CODE) TEM2) (SETQ DATA-SIZE (1+ (* (CEILING (- (ARRAY-DIMENSION CD 0) TEM1 TEM2) #o20) (ARRAY-DIMENSION CD 1)))))) (SETQ TOTAL-DATA-SIZE (+ TOTAL-DATA-SIZE DATA-SIZE)) (SETF (AREF CHAR-DATA-SIZE-TABLE CHAR-CODE) DATA-SIZE))) (SETQ TOTAL-DATA-SIZE (+ TOTAL-DATA-SIZE (* 10. (- EC BC -1)))) ;; Index entry type 1, 12. words long. (SEND OUTPUT-FILE ':TYO (DPB 1 #o1404 12.)) ;; Family code - always 1, since we only write one family. (SEND OUTPUT-FILE ':TYO 1) ;; Write the family name now. (DO ((I 0 (1+ I)) (LEN (STRING-LENGTH FAMILY-NAME)) (HIGH-BYTE (STRING-LENGTH FAMILY-NAME))) ((= I 19.)) (LET ((CH (IF (< I LEN) (AREF FAMILY-NAME I) 0))) (IF HIGH-BYTE (PROGN (SEND OUTPUT-FILE ':TYO (DPB HIGH-BYTE #o1010 CH)) (SETQ HIGH-BYTE NIL)) (SETQ HIGH-BYTE CH)))) ;; Now write the index entry for the data segment. ;; Type 3, 11. words long. (SEND OUTPUT-FILE ':TYO (DPB 3 #o1404 11.)) ;; Now family code and face code. (SEND OUTPUT-FILE ':TYO (DPB 1 #o1010 (PRESS:ENCODE-PRESS-FACE FACE-CODE))) ;; Now range of characters actually existing in the font. (SEND OUTPUT-FILE ':TYO (DPB BC #o1010 EC)) ;; Now size of font. (SEND OUTPUT-FILE ':TYO (ROUND (* POINT-SIZE 2540.) 72.)) ;; Rotation is 0. (SEND OUTPUT-FILE ':TYO 0) ;; Position in file of start of data (2 words). (SEND OUTPUT-FILE ':TYO 0) (SEND OUTPUT-FILE ':TYO 24.) ;; Number of words of data. (SEND OUTPUT-FILE ':TYO (LDB #o2020 TOTAL-DATA-SIZE)) (SEND OUTPUT-FILE ':TYO (LDB #o0020 TOTAL-DATA-SIZE)) ;; Resolutions (FUNCALL OUTPUT-FILE ':TYO (FD-HORIZ-RESOLUTION FD)) (FUNCALL OUTPUT-FILE ':TYO (FD-VERT-RESOLUTION FD)) ;; Index entry type 0, end of index. (FUNCALL OUTPUT-FILE ':TYO 1) ;; Output descriptions of the characters in the font. (DO ((CHAR-CODE BC (1+ CHAR-CODE))) ((> CHAR-CODE EC)) (LET ((CD (AREF FD CHAR-CODE))) (COND ((NULL CD) (FUNCALL OUTPUT-FILE ':TYO 0) (FUNCALL OUTPUT-FILE ':TYO 0) (FUNCALL OUTPUT-FILE ':TYO 0) (FUNCALL OUTPUT-FILE ':TYO 0) (FUNCALL OUTPUT-FILE ':TYO 0) (FUNCALL OUTPUT-FILE ':TYO 0) (FUNCALL OUTPUT-FILE ':TYO 0) (FUNCALL OUTPUT-FILE ':TYO 177777)) (T (FUNCALL OUTPUT-FILE ':TYO (FIX (CD-CHAR-WIDTH CD))) (FUNCALL OUTPUT-FILE ':TYO (FIX (* 65536. (- (CD-CHAR-WIDTH CD) (FIX (CD-CHAR-WIDTH CD)))))) (FUNCALL OUTPUT-FILE ':TYO (FIX (CD-CHAR-VERT-WIDTH CD))) (FUNCALL OUTPUT-FILE ':TYO (FIX (* 65536. (- (CD-CHAR-VERT-WIDTH CD) (FIX (CD-CHAR-VERT-WIDTH CD)))))) (FUNCALL OUTPUT-FILE ':TYO (- (CD-CHAR-LEFT-KERN CD))) (FUNCALL OUTPUT-FILE ':TYO (+ (- (FD-BASELINE FD) (FD-LINE-SPACING FD)) (AREF UNUSED-BOTTOM-RASTERS CHAR-CODE))) (FUNCALL OUTPUT-FILE ':TYO (CADR (ARRAY-DIMENSIONS CD))) (FUNCALL OUTPUT-FILE ':TYO (- (CAR (ARRAY-DIMENSIONS CD)) (AREF UNUSED-BOTTOM-RASTERS CHAR-CODE) (AREF UNUSED-TOP-RASTERS CHAR-CODE))))))) ;; Output offsets to data for each character. (LET* ((CURRENT-POS (+ 24. (* 8 (- EC BC -1)))) (EXPECTED-DATA-START (+ CURRENT-POS (* 2 (- EC BC -1))))) (DO ((CHAR-CODE BC (1+ CHAR-CODE))) ((> CHAR-CODE EC)) (LET ((OFFSET (- EXPECTED-DATA-START CURRENT-POS))) (FUNCALL OUTPUT-FILE ':TYO (LDB 2020 OFFSET)) (FUNCALL OUTPUT-FILE ':TYO (LDB 0020 OFFSET))) (SETQ EXPECTED-DATA-START (+ EXPECTED-DATA-START (AREF CHAR-DATA-SIZE-TABLE CHAR-CODE))))) ;; Now output the rasters themselves. (DO ((CHAR-CODE BC (1+ CHAR-CODE))) ((> CHAR-CODE EC)) (LET* (WD (CD (AREF FD CHAR-CODE))) (COND (CD (LET* ((RASTER-WIDTH (ARRAY-DIMENSION CD 1)) (RASTER-BOTTOM-SKIP (AREF UNUSED-BOTTOM-RASTERS CHAR-CODE)) (REAL-RASTER-HEIGHT (ARRAY-DIMENSION CD 0)) (RASTER-HEIGHT (- REAL-RASTER-HEIGHT RASTER-BOTTOM-SKIP (AREF UNUSED-TOP-RASTERS CHAR-CODE)))) ;; Output redundant raster size info word. (FUNCALL OUTPUT-FILE ':TYO (DPB (CEILING RASTER-HEIGHT 20) 1206 (ARRAY-DIMENSION CD 1))) ;; Raster lines go vertically up, leftmost line first. (DOTIMES (HPOS RASTER-WIDTH) (SETQ WD 0) ;; Write the next vertical scan line. (DOTIMES (VPOS RASTER-HEIGHT) (SETQ WD (+ WD (LSH (AREF CD (- REAL-RASTER-HEIGHT 1 VPOS RASTER-BOTTOM-SKIP) HPOS) (- 17 (\ VPOS 20))))) ;; If wd is full, output it. (AND (ZEROP (\ (1+ VPOS) 16.)) (PROGN (FUNCALL OUTPUT-FILE ':TYO WD) (SETQ WD 0)))) ;; Output partially-filled word at end. (OR (ZEROP (\ RASTER-HEIGHT 16.)) (FUNCALL OUTPUT-FILE ':TYO WD))))))))) (FUNCALL OUTPUT-FILE ':CLOSE) (FUNCALL OUTPUT-FILE ':TRUENAME))) (DEFUN READ-AST-INTO-FONT (FILENAME &OPTIONAL FONTNAME) (MULTIPLE-VALUE (FILENAME FONTNAME) (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AST")) (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME (READ-AST-INTO-FONT-DESCRIPTOR FILENAME FONTNAME)) FONTNAME) (DEFUN READ-AST-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME &AUX FD) (MULTIPLE-VALUE (FILENAME FONTNAME) (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AST")) (WITH-OPEN-FILE (STREAM FILENAME '(:IN)) (SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME :MAKE-ARRAY (:LENGTH 200))) (READ-AST-DN STREAM) ;DISCARD KSTID (SETF (FD-LINE-SPACING FD) (READ-AST-DN STREAM)) (SETF (FD-BASELINE FD) (READ-AST-DN STREAM)) (READ-AST-DN STREAM) ;COLUMN POSITION ADJUSTMENT (SETF (FD-SPACE-WIDTH FD) 0) ;Just in case no space character. (SETF (FD-BLINKER-HEIGHT FD) (FD-LINE-SPACING FD)) (SETF (FD-NAME FD) FONTNAME) (LET (KERN CHAR-CODE RASTER-WIDTH INPUT-RASTER-WIDTH CHAR-WIDTH CD CH (LINE-HEIGHT (FD-LINE-SPACING FD))) (DO () ((NULL (READ-AST-NEXT-PAGE STREAM))) (SETQ CHAR-CODE (READ-AST-ON STREAM)) (SETQ INPUT-RASTER-WIDTH (READ-AST-DN STREAM) RASTER-WIDTH INPUT-RASTER-WIDTH) (SETQ CHAR-WIDTH (READ-AST-DN STREAM)) (SETQ KERN (READ-AST-DN STREAM)) (COND ((< KERN 0) ;FED compact raster lossage (SETQ RASTER-WIDTH (+ RASTER-WIDTH (ABS KERN))) (SETQ KERN 0))) (SETQ CD (MAKE-CHAR-DESCRIPTOR :MAKE-ARRAY (:TYPE ART-1B :LENGTH (LIST LINE-HEIGHT RASTER-WIDTH)))) (SETF (CD-CHAR-WIDTH CD) CHAR-WIDTH) (SETF (CD-CHAR-LEFT-KERN CD) KERN) (FD-STORE-CD FD CD CHAR-CODE) (AND (= CHAR-CODE #\SP) (SETF (FD-SPACE-WIDTH FD) CHAR-WIDTH)) (DO-NAMED TOP ((VPOS 0 (1+ VPOS))) ((= VPOS LINE-HEIGHT)) (DO ((HCNT 0 (1+ HCNT))) ((= HCNT INPUT-RASTER-WIDTH) (DO ((CH)) () (COND ((OR (NULL (SETQ CH (FUNCALL STREAM ':TYI))) (= CH #\RETURN)) (RETURN NIL)) ((= CH #\FORM) (FUNCALL STREAM ':UNTYI CH) (RETURN-FROM TOP NIL)) ((NOT (= CH #\SPACE)) (FERROR NIL "non space seen past raster width"))))) (SETQ CH (FUNCALL STREAM ':TYI)) (COND ((NULL CH) (RETURN-FROM TOP NIL)) ((= CH #\FORM) (FUNCALL STREAM ':UNTYI CH) (RETURN-FROM TOP NIL)) ((OR (< CH 40) (> CH 200)) (DO () ((= CH #\RETURN)) (SETQ CH (FUNCALL STREAM ':TYI))) (RETURN NIL)) ((> CH 40) (ASET 1 CD VPOS (+ HCNT (- RASTER-WIDTH INPUT-RASTER-WIDTH))))))) ; (COND ((> CHAR-CODE 37) (TYO CHAR-CODE)) ; (T (PRINC '^) (TYO (+ 100 CHAR-CODE)))) ) ;; Truncate fd to discard unused elements at the end. (DO ((I (1- (ARRAY-LENGTH FD)) (1- I))) ((OR (MINUSP I) (AREF FD I)) (ADJUST-ARRAY-SIZE FD (1+ I)))) (SETF (FD-FILL-POINTER FD) (ARRAY-LENGTH FD)) ;; Set width of blinker and space fields from the space character. (SETF (FD-BLINKER-WIDTH FD) (FD-SPACE-WIDTH FD)) FD))) (DEFUN READ-AST-DN (STREAM) (PROG (N CH SIGN) (SETQ N 0 SIGN 1) (SETQ CH (FUNCALL STREAM ':TYI)) ;LOOK FOR MINUS SIGN (COND ((= CH #/-) (SETQ SIGN -1)) (T (GO AA))) A (SETQ CH (FUNCALL STREAM ':TYI)) AA (AND ( CH #/0) ( CH #/9) (PROGN (SETQ N (+ (* N 10.) (- CH #/0))) (GO A))) B (AND (= CH #\RETURN) (RETURN (* N SIGN))) (SETQ CH (FUNCALL STREAM ':TYI)) (GO B))) (DEFUN READ-AST-ON (STREAM) (PROG (N CH) (SETQ N 0) A (SETQ CH (FUNCALL STREAM ':TYI)) (AND ( CH #/0) ( CH #/8) (PROGN (SETQ N (+ (* N 8) (- CH #/0))) (GO A))) B (AND (= CH #\RETURN) (RETURN N)) (SETQ CH (FUNCALL STREAM ':TYI)) (GO B))) (DEFUN READ-AST-NEXT-PAGE (STREAM) (PROG (CH) (COND ((NULL (SETQ CH (FUNCALL STREAM ':TYI))) (RETURN NIL)) ((= CH #\FORM) (SETQ CH (FUNCALL STREAM ':TYI)) (FUNCALL STREAM ':UNTYI CH) (IF (NULL CH) (RETURN NIL) (RETURN T))) (T (FERROR NIL "Random char where FF expected"))))) (DEFUN WRITE-FONT-INTO-AST (FONTNAME &OPTIONAL FILENAME) (MULTIPLE-VALUE (FONTNAME FILENAME) (GET-OUTPUT-FILENAME-AND-FONTNAME FONTNAME FILENAME "AST")) (LET ((FD (FONT-NAME-FONT-DESCRIPTOR FONTNAME))) (WRITE-FONT-DESCRIPTOR-INTO-AST FD FILENAME))) (DEFUN WRITE-FONT-DESCRIPTOR-INTO-AST (FD &OPTIONAL FILENAME &AUX (FONT-LENGTH (ARRAY-ACTIVE-LENGTH FD))) (SETQ FILENAME (GET-OUTPUT-FILENAME-FROM-FONT-DESCRIPTOR FD FILENAME "AST")) (WITH-OPEN-FILE (STREAM FILENAME '(:OUT :ASCII)) (FORMAT STREAM "0 KSTID ~A" FILENAME) (FORMAT STREAM "~%~D HEIGHT" (FD-LINE-SPACING FD)) (FORMAT STREAM "~%~D BASE LINE" (FD-BASELINE FD)) (FORMAT STREAM "~%0 COLUMN POSITION ADJUSTMENT~%") ;; Then write out all the characters. (LET (CD CHAR-HEIGHT LOSING-KERN KERN) (DOTIMES (CHAR-CODE FONT-LENGTH) (COND ((AND (SETQ CD (AREF FD CHAR-CODE)) ;; Wide fonts without chars-exist-tables can have 0-width chars. (OR (NOT (ZEROP (ARRAY-DIMENSION CD 1))) (NOT (ZEROP (CD-CHAR-WIDTH CD))))) (FUNCALL STREAM ':TYO #\FORM) (SETQ KERN (CD-CHAR-LEFT-KERN CD) LOSING-KERN (AND (MINUSP KERN) ( (CD-CHAR-WIDTH CD) (- (ARRAY-DIMENSION CD 1) KERN)) (- KERN))) (FORMAT STREAM "~O CHARACTER CODE ~A" CHAR-CODE FILENAME) (FORMAT STREAM "~%~D RASTER WIDTH" (IF LOSING-KERN (CD-CHAR-WIDTH CD) (ARRAY-DIMENSION CD 1))) (FORMAT STREAM "~%~D CHARACTER WIDTH" (CD-CHAR-WIDTH CD)) (FORMAT STREAM "~%~D LEFT KERN~%" (IF LOSING-KERN 0 KERN)) (SETQ CHAR-HEIGHT (ARRAY-DIMENSION CD 0)) (DOTIMES (VPOS CHAR-HEIGHT) (IF LOSING-KERN (DOTIMES (HPOS LOSING-KERN) (SEND STREAM ':TYO #\SPACE))) (DOTIMES (HPOS (ARRAY-DIMENSION CD 1)) (SEND STREAM ':TYO (IF (ZEROP (AREF CD VPOS HPOS)) #\SPACE #/*))) (SEND STREAM ':TYO #\RETURN)))))) (CLOSE STREAM) (SEND STREAM ':TRUENAME)))