;;; -*- Mode:Common-Lisp; Package:USER; Base:10; Fonts:(CPTFONT CPTFONTB CPTFONTBI) -*- #| This program allows one to read in characters from X11 font files and convert them to Explorer font objects. The font files are located in the directory tilde:/lagoon.u1/X11-beta.1/fonts/bdf/. This program reads the font information in a manner similar to the fc program in tilde:/lagoon.u1/X11-beta.1/fonts/compiler/fc.c. To run the program, call the function read-font, and pass a pathname for the font file. The read-font function returns the symbol whose value is the font object. These symbols are prefixed with `X11-' to distinguish them from Explorer fonts which may have the same name. |# ;;; Change history: ;;; ;;; Date Author Description ;;; ------------------------------------------------------------------------------------- ;;; 112*/106*/88 LGO 1Ensure font name is all caps.* ;;; 11/114*/88 LGO 1Get font height and baseline from ascent and descent when FontBoundingBox is bad.* ;;; 11/09/88 LGO Get font height and baseline from the FontBoundingBox. ;;; These font attributes cannot be derived from ascent and descent. ;;; 11/08/88 LGO Correctly skip characters with negative encoding ;;; 11/08/88 LGO Correctly left-justify font bitmaps ;;; 11/08/88 LGO Gather font properties correctly. ;;; 11/08/88 LGO Adjust FED:FD-SPACE-WIDTH and FED:FD-BLINKER-WIDTH for fixed width fonts ;;; 10/27/88 TWE Changed the inner data collection loop index start-row to never ;;; start below the index of 0. ;;; 9/14/88 LGO Use Y-RESOLUTION instead of explorer pixel-resolution ;;; when computing character sizes. ;;; 9/13/88 LGO Fix READ-A-LINE to work on unix files ;;; 9/13/88 LGO Add compile-x11-font function which dumps x11-font-info ;;; in the same file as the font. ;;; 9/13/88 LGO Set char-width to x-width instead of bounding-box-width ;;; 9/13/88 LGO Pad the top of char bitmaps to make the baselines line up. ;;; The prefix for font pathnames and font objects is the same. (DEFCONSTANT X-FONT-OBJECT-PREFIX "X11-") (DEFCONSTANT GOLDEN-RATIO (/ (1+ (SQRT 5)) 2)) (DEFCONSTANT MAX-ENCODING (EXPT 2 16) "2Largest number of characters in a font that can be supported*") (DEFCONSTANT VERSION-STRING "STARTFONT 2.1") (DEFCONSTANT X-FONT-OBJECT-PREFIX "X11-") (DEFPARAMETER LINE-NUMBER 0 2 *"2Number of the line read from a font file. Used for error reporting.*") ;;; Simpler version of the read-from-string function, which more easily handles ;;; keywords. This version is less general than the read-from-string function, ;;; but sufices here. (DEFUN READ-FROM-STRING-FIX (STRING &KEY (START 0)) (READ-FROM-STRING STRING T NIL :START START)) ;;; The following defparameters are located here instead of being inside of a LET in read-font ;;; because release 2.1 doesn't allow one to put a large number of locals inside of a function. ;;; Data line read from the font file. (DEFPARAMETER LINE NIL) ;;; Determines the name of the font. This may be a filename, which means ;;; that the font name needs to be extracted. (DEFPARAMETER FAMILY NIL) ;;; Resolution of the font in the X direction. (DEFPARAMETER X-RESOLUTION NIL) ;;; Resolution of the font in the Y direction. (DEFPARAMETER Y-RESOLUTION NIL) ;;; Symbol which is the font's name. Has the X11- prefix. (DEFPARAMETER FONT-SYMBOL NIL) ;;; The number of glyphs in this font. (DEFPARAMETER NUMBER-CHARACTERS NIL) ;;; The lowest character in the font. (DEFPARAMETER LOWEST-ENCODING MOST-POSITIVE-FIXNUM) ;;; The highest character in the font. (DEFPARAMETER LARGEST-ENCODING 0) ;;; The next 4 deal with 2-D fonts. (DEFPARAMETER FI.FIRST-ROW MOST-POSITIVE-FIXNUM) (DEFPARAMETER FI.LAST-ROW 0) (DEFPARAMETER FI.CH-FIRST MOST-POSITIVE-FIXNUM) (DEFPARAMETER FI.CH-LAST 0) (DEFPARAMETER REAL-PROPERTY-COUNTER 0 "2Number of properties for this font.*") (DEFPARAMETER PROPERTIES NIL) ;1;; Total font height* (defparameter font-height nil) ;1;; Font baseline* (defparameter font-baseline nil) (defparameter font-y nil) ;;; Maximum length of ascenders for the font. (DEFPARAMETER FONT-ASCENT NIL) ;;; Maximum length of descenders for the font. (DEFPARAMETER FONT-DESCENT NIL) ;;; Maximums and minimums for components of x-char-info. (DEFPARAMETER MAX-LEFT-SIDE-BEARING NIL) (DEFPARAMETER MAX-RIGHT-SIDE-BEARING NIL) (DEFPARAMETER MAX-CHARACTER-WIDTH NIL) (DEFPARAMETER MAX-FONT-ASCENT NIL) (DEFPARAMETER MAX-FONT-DESCENT NIL) (DEFPARAMETER MIN-LEFT-SIDE-BEARING NIL) (DEFPARAMETER MIN-RIGHT-SIDE-BEARING NIL) (DEFPARAMETER MIN-CHARACTER-WIDTH NIL) (DEFPARAMETER MIN-FONT-ASCENT NIL) (DEFPARAMETER MIN-FONT-DESCENT NIL) ;;; Default character property for the font. (DEFPARAMETER DEFAULT-CHARACTER NIL) (DEFPARAMETER ALL-CHARS-EXIST NIL) (DEFPARAMETER CONSTANT-METRICS NIL) ;;; Point size for the font. (DEFPARAMETER POINT-SIZE NIL) ;;; Family name property of the font. Not used for anything yet. (DEFPARAMETER FAMILY-NAME NIL) ;;; Resolution property of the font. I'm not sure how this differs from ;;; the values of x-resolution and y-resolution, which are supposed to ;;; have the same value (i.e. X resolution = Y resolution). (DEFPARAMETER RESOLUTION NIL) ;;; Height of the font. (DEFPARAMETER X-HEIGHT NIL) ;;; Weight property of the font. (DEFPARAMETER WEIGHT NIL) ;;; Quad width property of the font. (DEFPARAMETER QUAD-WIDTH NIL) ;1;; The FED font descriptor* (defparameter font-desc nil) (DEFUN READ-FONT (PATHNAME &AUX (x11-metrics (make-array 256))) "2Read an X11 bdf font file and generate Explorer font object. PATHNAME is the pathname where the .bdf information exists. X11 font descriptor informations is put on the* 2:X11-FONT-INFO roperty of the font name symbol.*" (WITH-OPEN-FILE (FONT-STREAM PATHNAME :DIRECTION :INPUT) (SETQ ALL-CHARS-EXIST T X-HEIGHT NIL FONT-HEIGHT NIL FONT-ASCENT NIL FONT-DESCENT NIL LARGEST-ENCODING 0;;; Maximum length of ascenders for the font. LINE-NUMBER 0 LOWEST-ENCODING MOST-POSITIVE-FIXNUM MAX-CHARACTER-WIDTH 0 MAX-FONT-ASCENT 0 MAX-FONT-DESCENT 0 MAX-LEFT-SIDE-BEARING 0 MAX-RIGHT-SIDE-BEARING 0 MIN-CHARACTER-WIDTH MOST-POSITIVE-FIXNUM MIN-FONT-ASCENT MOST-POSITIVE-FIXNUM MIN-FONT-DESCENT MOST-POSITIVE-FIXNUM MIN-LEFT-SIDE-BEARING MOST-POSITIVE-FIXNUM MIN-RIGHT-SIDE-BEARING MOST-POSITIVE-FIXNUM PROPERTIES NIL) ;; The validate-string function compares the first few characters of LINE ;; to those characters in STRING. If they are not the same (case doesn't count) ;; then an error message is generated. (FLET ((VALIDATE-STRING (STRING &OPTIONAL MESSAGE) (IF (NOT (STRING-EQUAL (SETQ LINE (READ-A-LINE FONT-STREAM)) STRING :end1 (LENGTH STRING))) (FERROR NIL "Missing font ~A on line ~D, got ~A instead." (OR MESSAGE (STRING-TRIM " " STRING)) LINE-NUMBER LINE) ;;1ELSE* (nsubstring LINE (LENGTH STRING))))) ;; Parse the header stuff for the font. (VALIDATE-STRING VERSION-STRING "file, or incorrect version") (SETQ FAMILY (VALIDATE-STRING "FONT " "family line")) ;; Form a font name from the family string. The family can be one of ;; several things: a simple string, a simple filename with an ;; extension, or a fully specified pathname with an optional extension. ;; It is assumed that the characters of the filename component of a ;; pathname contain only alphabetic, numeric, - or _ characters. (SETQ FONT-SYMBOL (INTERN (CONCATENATE 'SIMPLE-STRING "X11-" ;; 1make the *font name the same as the file name. This ;; makes it much easier to deal with fonts, since ;; X uses the file system to locate fonts. (string-upcase (PATHNAME-NAME FONT-STREAM))) 'FONTS)) ;; Read in the point size, x resolution and y resolution. (LET ((RESOLUTIONS-STRING (VALIDATE-STRING "SIZE " "size line"))) (MULTIPLE-VALUE-BIND (VALUE X-RESOLUTION-POSITION) (READ-FROM-STRING-FIX RESOLUTIONS-STRING) (SETQ POINT-SIZE VALUE) (MULTIPLE-VALUE-BIND (VALUE Y-RESOLUTION-POSITION) (READ-FROM-STRING-FIX RESOLUTIONS-STRING :START X-RESOLUTION-POSITION) (SETQ X-RESOLUTION VALUE Y-RESOLUTION (READ-FROM-STRING-FIX RESOLUTIONS-STRING :START Y-RESOLUTION-POSITION)))) (WHEN (NOT (= X-RESOLUTION Y-RESOLUTION)) (FERROR NIL "X and Y resolution must be equal, but are ~D and ~D" X-RESOLUTION Y-RESOLUTION))) (let ((BOUNDING-BOX-STRING (VALIDATE-STRING "FONTBOUNDINGBOX "))) (MULTIPLE-VALUE-BIND (VALUE HEIGHT-POSITION) (READ-FROM-STRING BOUNDING-BOX-STRING) value ;1; Ignore font bounding-box width* (MULTIPLE-VALUE-BIND (VALUE LEFT-POSITION) (READ-FROM-STRING-FIX BOUNDING-BOX-STRING :START HEIGHT-POSITION) (SETQ font-height VALUE) (MULTIPLE-VALUE-BIND (VALUE BOTTOM-POSITION) (READ-FROM-STRING-FIX BOUNDING-BOX-STRING :START LEFT-POSITION) value ;1; Ignore font bounding-box X* (SETQ value (READ-FROM-STRING-FIX BOUNDING-BOX-STRING :START BOTTOM-POSITION)) (setq font-y (- value)))))) (SETQ REAL-PROPERTY-COUNTER 0) ;; Read in the properties of the font. (LOOP WITH NUMBER-OF-PROPERTIES = (READ-FROM-STRING (VALIDATE-STRING "STARTPROPERTIES " "properties")) FOR PROPERTY-COUNTER FROM 1 BY 1 WHILE (>= NUMBER-OF-PROPERTIES PROPERTY-COUNTER) FOR LINE = (READ-A-LINE FONT-STREAM) DO (MULTIPLE-VALUE-BIND (NAME VALUE-INDEX) (let ((*package* *keyword-package*)) (READ-FROM-STRING LINE)) (LET ((VALUE (READ-FROM-STRING-FIX LINE :START VALUE-INDEX))) (unless (numberp value) (setq value (intern (string value) 'keyword))) (case name ;1; These properties are used, and DON'T go on the property list* (:font_ascent (setq font-ascent value)) (:font_descent (setq font-descent value)) (:default_char (setq default-character value)) (otherwise (setq properties (list* name value properties)) (incf real-property-counter) (case name ;1; These properties are used and DO go on the property list* (:point_size (setq point-size value)) #+comment ;1; what is this property anyway??? - LGO* (:x_height (setq x-height value)))))))) (VALIDATE-STRING "ENDPROPERTIES" "terminator for font properties") (WHEN (OR (NULL FONT-ASCENT) (NULL FONT-DESCENT)) (FERROR NIL "Must have FONT_ASCENT and FONT_DESCENT properties")) ;1; We shouldn't have to do this, but some fonts have incorrect fontboundingbox* ;1; specifications (probably because bdftosnf donesn't use it)* (setq font-height (max font-height (+ font-ascent font-descent)) font-baseline (- font-height (max font-y font-descent))) (SETQ NUMBER-CHARACTERS (READ-FROM-STRING (VALIDATE-STRING "CHARS " "character count"))) (unless x-height (setq x-height (if (and font-ascent font-descent) (+ font-ascent font-descent) (ROUND (* POINT-SIZE ;; Convert points to inches (/ 1 72.27) ;; Convert inches to pixels Y-RESOLUTION))))) (unless FONT-ASCENT (setq font-ascent (if font-descent (- font-height font-descent) ;; Assume that the ascender covers about 80% of a character. (* FONT-HEIGHT 0.8)))) (setq font-desc (FED:MAKE-FONT-DESCRIPTOR :MAKE-ARRAY (:LENGTH (MAX NUMBER-CHARACTERS 256.)) FED:FD-FILL-POINTER (MAX NUMBER-CHARACTERS 256.) FED:FD-NAME FONT-SYMBOL FED:FD-SPACE-WIDTH (ROUND (* ;; Convert height to width (/ POINT-SIZE GOLDEN-RATIO) ;; Convert points to inches (/ 1 72.27) ;; Convert inches to pixels Y-RESOLUTION)) FED:FD-LINE-SPACING (+ FONT-ASCENT FONT-DESCENT) FED:FD-BASELINE FONT-BASELINE FED:FD-BLINKER-WIDTH (ROUND (* ;; Convert height to width (/ POINT-SIZE GOLDEN-RATIO) ;; Convert points to inches (/ 1 72.27) ;; Convert inches to pixels Y-RESOLUTION)) FED:FD-BLINKER-HEIGHT FONT-HEIGHT)) ;; Loop through each character in this font. (LOOP WITH BOUNDING-BOX-WIDTH = NIL WITH BOUNDING-BOX-HEIGHT = NIL WITH BOUNDING-BOX-LEFT = NIL WITH BOUNDING-BOX-BOTTOM = NIL FOR CHARACTER-COUNTER FROM 0 BELOW NUMBER-CHARACTERS ;; 1234567890 WHILE (string= (SETQ LINE (READ-A-LINE FONT-STREAM)) "STARTCHAR " :end1 10) FOR CHARACTER-NAME = (SUBSEQ LINE 10) FOR LAST-ENCODING = NIL THEN ENCODING FOR ENCODING = (LET ((ENCODING (VALIDATE-STRING "encoding "))) (MULTIPLE-VALUE-BIND (VALUE END-POSITION) (READ-FROM-STRING ENCODING) (WHEN (AND (NOT (= END-POSITION (LENGTH ENCODING))) (= VALUE -1)) ;; We have two values. Get the second one since the ;; first one looks kind of trashy (I don't know what ;; the real meaning is behind the -1 value). (SETQ VALUE (READ-FROM-STRING-FIX ENCODING :START END-POSITION))) (WHEN (= VALUE -1) #+comment (FORMAT T "~%Character ~A with encoding = -1 ignored at line ~D" CHARACTER-NAME LINE-NUMBER) (LOOP FOR LINE = (READ-A-LINE FONT-STREAM) UNTIL (EQUAL LINE "ENDCHAR"))) (WHEN (> VALUE MAX-ENCODING) (FERROR NIL "Character `~A' has encoding(=~D) ~ which is too large" CHARACTER-NAME VALUE)) (SETQ LARGEST-ENCODING (MAX VALUE LARGEST-ENCODING)) VALUE)) unless (minusp encoding) do ;; The following three things are unused, but are calculated in ;; the C program, so we do this here in case we need them later. (let* ((CHARACTER-ROW (LOGAND (ASH ENCODING -8) #xFF)) (CHARACTER-COLUMN (LET ((COLUMN (LOGAND ENCODING #xFF))) (SETQ FI.FIRST-ROW (MIN FI.FIRST-ROW CHARACTER-ROW) FI.LAST-ROW (MAX FI.LAST-ROW CHARACTER-ROW) FI.CH-FIRST (MIN FI.CH-FIRST COLUMN) FI.CH-LAST (MAX FI.CH-LAST COLUMN)) COLUMN)) (SWIDTH (VALIDATE-STRING "SWIDTH ")) ;; X component of width (X-WIDTH (READ-FROM-STRING (VALIDATE-STRING "DWIDTH "))) (BOUNDING-BOX-STRING (VALIDATE-STRING "BBX" "bounding box")) (ATTRIBUTES 0)) swidth character-column ;1; not used* ;; Decode the components of the bounding box. (MULTIPLE-VALUE-BIND (VALUE HEIGHT-POSITION) (READ-FROM-STRING BOUNDING-BOX-STRING) (SETQ BOUNDING-BOX-WIDTH VALUE) (MULTIPLE-VALUE-BIND (VALUE LEFT-POSITION) (READ-FROM-STRING-FIX BOUNDING-BOX-STRING :START HEIGHT-POSITION) (SETQ BOUNDING-BOX-HEIGHT VALUE) (MULTIPLE-VALUE-BIND (VALUE BOTTOM-POSITION) (READ-FROM-STRING-FIX BOUNDING-BOX-STRING :START LEFT-POSITION) (SETQ BOUNDING-BOX-LEFT VALUE BOUNDING-BOX-BOTTOM (READ-FROM-STRING-FIX BOUNDING-BOX-STRING :START BOTTOM-POSITION))))) (WHEN (OR (ZEROP BOUNDING-BOX-WIDTH) (ZEROP BOUNDING-BOX-HEIGHT)) ;; The character has zero size. Make sure that the left and ;; bottom dimensions don't affect the minimum/maximum ;; calculations. (SETQ BOUNDING-BOX-WIDTH 0 BOUNDING-BOX-HEIGHT 0 BOUNDING-BOX-LEFT MIN-LEFT-SIDE-BEARING BOUNDING-BOX-BOTTOM (- MIN-FONT-DESCENT))) (SETQ LINE (READ-A-LINE FONT-STREAM)) ;; 12345678901 (WHEN (STRING-EQUAL (SUBSEQ LINE 0 11) "ATTRIBUTES ") ;; The attributes line is optional. (SETQ ATTRIBUTES (READ-FROM-STRING-FIX (CONCATENATE 'SIMPLE-STRING "#\x" LINE) :START 11)) (SETQ LINE (READ-A-LINE FONT-STREAM))) (SETQ LOWEST-ENCODING (MIN LOWEST-ENCODING ENCODING)) ;; Write information out regarding this character. (setf (aref x11-metrics encoding) (X11:MAKE-X-CHAR-INFO :LEFT-SIDE-BEARING BOUNDING-BOX-LEFT :RIGHT-SIDE-BEARING (+ BOUNDING-BOX-LEFT BOUNDING-BOX-WIDTH) :CHARACTER-WIDTH X-WIDTH :ASCENT (+ BOUNDING-BOX-HEIGHT BOUNDING-BOX-BOTTOM) :DESCENT (- BOUNDING-BOX-BOTTOM) :ATTRIBUTES ATTRIBUTES)) (SETQ MAX-LEFT-SIDE-BEARING (MAX MAX-LEFT-SIDE-BEARING BOUNDING-BOX-LEFT) MAX-RIGHT-SIDE-BEARING (MAX MAX-RIGHT-SIDE-BEARING (+ BOUNDING-BOX-LEFT BOUNDING-BOX-WIDTH)) MAX-CHARACTER-WIDTH (MAX MAX-CHARACTER-WIDTH X-WIDTH) MAX-FONT-ASCENT (MAX MAX-FONT-ASCENT (+ BOUNDING-BOX-HEIGHT BOUNDING-BOX-BOTTOM)) MAX-FONT-DESCENT (MAX MAX-FONT-DESCENT (- BOUNDING-BOX-BOTTOM)) MIN-LEFT-SIDE-BEARING (MIN MIN-LEFT-SIDE-BEARING BOUNDING-BOX-LEFT) MIN-RIGHT-SIDE-BEARING (MIN MIN-RIGHT-SIDE-BEARING (+ BOUNDING-BOX-LEFT BOUNDING-BOX-WIDTH)) MIN-CHARACTER-WIDTH (MIN MIN-CHARACTER-WIDTH X-WIDTH) MIN-FONT-ASCENT (MIN MIN-FONT-ASCENT (+ BOUNDING-BOX-HEIGHT BOUNDING-BOX-BOTTOM)) MIN-FONT-DESCENT (MIN MIN-FONT-DESCENT (- BOUNDING-BOX-BOTTOM))) ;; Can't use validate-string here because the attributes line ;; is optional. (WHEN (NOT (STRING-EQUAL LINE "BITMAP")) (FERROR NIL "Missing font bitmap on line ~D, got ~A instead." LINE LINE-NUMBER)) ;; Loop collecting each row of the character. (LOOP with start-row = (- font-baseline (+ BOUNDING-BOX-HEIGHT BOUNDING-BOX-BOTTOM)) #+comment (min (max (- font-ascent (+ BOUNDING-BOX-HEIGHT BOUNDING-BOX-BOTTOM)) 0) (1- font-height)) ;1 These min/maxes are a kludge... do better someday* WITH CHAR-DESC = (FED:MAKE-CHAR-DESCRIPTOR :MAKE-ARRAY (:element-type 'BIT :LENGTH (LIST font-height BOUNDING-BOX-WIDTH)) FED:CD-CHAR-WIDTH X-WIDTH FED:CD-CHAR-LEFT-KERN 0) FOR ROW FROM start-row ;1;*(+ start-row fudge) FOR RAW-DATA = (READ-A-LINE FONT-STREAM) WHILE (NOT (EQUAL RAW-DATA "ENDCHAR")) ;; Loop through all of the bits of this row. ;; The data comes in left justified, so we need ;; to shift it to make it right justified. DO (LOOP with DATA = (parse-integer raw-data :radix 16.) WITH SHIFTED-DATA = (ASH DATA (- BOUNDING-BOX-WIDTH (* 4 (LENGTH RAW-DATA)))) FOR COLUMN FROM (1- BOUNDING-BOX-WIDTH) DOWNTO 0 DO (PROGN (SETF (AREF CHAR-DESC ROW COLUMN) (LOGAND SHIFTED-DATA 1)) (SETQ SHIFTED-DATA (ASH SHIFTED-DATA -1)))) FINALLY (SETF (AREF FONT-DESC ENCODING) CHAR-DESC)))) (progn ;; WHEN OUTPUT-PATHNAME (SETQ CONSTANT-METRICS (AND (= MIN-LEFT-SIDE-BEARING MAX-LEFT-SIDE-BEARING) (= MIN-RIGHT-SIDE-BEARING MAX-RIGHT-SIDE-BEARING) (= MIN-CHARACTER-WIDTH MAX-CHARACTER-WIDTH) (= MIN-FONT-ASCENT MAX-FONT-ASCENT) (= MIN-FONT-DESCENT MAX-FONT-DESCENT))) ;1; Ensure correct space and blinker width for constant-metric fonts* (when constant-metrics (setf (FED:FD-SPACE-WIDTH font-desc) max-character-width (FED:FD-BLINKER-WIDTH font-desc) max-character-width)) ;; Adjust the size of the font to only have those characters it defines. (SETF (FILL-POINTER FONT-DESC) (1+ LARGEST-ENCODING)) (ADJUST-ARRAY FONT-DESC (1+ LARGEST-ENCODING)) (FED:FONT-NAME-SET-FONT-AND-DESCRIPTOR FONT-SYMBOL FONT-DESC) ;1; Canonicalize metrics vector* (unless constant-metrics (loop with metrics = (make-array (1+ (- largest-encoding lowest-encoding))) for i from lowest-encoding to largest-encoding for j upfrom 0 do (setf (aref metrics j) (aref x11-metrics i)) finally (setq x11-metrics metrics))) ;1; Calculate all-chars-exists* (setq all-chars-exist t) (dotimes (i (1+ (- largest-encoding lowest-encoding))) (unless (aref x11-metrics i) (return (setq all-chars-exist nil)))) ;1; Setup the font-info-record* (setf (get font-symbol :x11-font-info) (X11:MAKE-FONT-INFO-RECORD :VERSION VERSION-STRING :ALL-EXIST ALL-CHARS-EXIST :DRAW-DIRECTION X11:LEFT-TO-RIGHT-FONT :NO-OVERLAP 0 ; HUH? :CONSTANT-METRICS (if constant-metrics 1 0) :TERMINAL-FONT (IF (AND CONSTANT-METRICS (ZEROP MAX-LEFT-SIDE-BEARING)) 1 0) :LINEAR T :FIRST-COL LOWEST-ENCODING :LAST-COL LARGEST-ENCODING :FIRST-ROW 0 :LAST-ROW 0 :N-PROPS REAL-PROPERTY-COUNTER :PROPERTIES PROPERTIES :LEN-STRINGS 0 ; WHAT IS THIS? ;; Try a bunch of default characters, starting with `?' and ending with ;; the first character in the font. :CH-DEFAULT (LOOP FOR CHAR IN `(#\? #\! #\@ #\# #\$ #\% #\& ,LOWEST-ENCODING) WHEN (PLUSP (AREF (W:FONT-CHARS-EXIST-TABLE (symbol-value FONT-SYMBOL)) (CHAR-INT CHAR))) RETURN (CHAR-INT CHAR)) :FONT-DESCENT FONT-DESCENT :FONT-ASCENT FONT-ASCENT :MIN-BOUNDS (X11:MAKE-X-CHAR-INFO :LEFT-SIDE-BEARING MIN-LEFT-SIDE-BEARING :RIGHT-SIDE-BEARING MIN-RIGHT-SIDE-BEARING :CHARACTER-WIDTH MIN-CHARACTER-WIDTH :ASCENT MIN-FONT-ASCENT :DESCENT MIN-FONT-DESCENT :ATTRIBUTES 0) :MAX-BOUNDS (X11:MAKE-X-CHAR-INFO :LEFT-SIDE-BEARING MAX-LEFT-SIDE-BEARING :RIGHT-SIDE-BEARING MAX-RIGHT-SIDE-BEARING :CHARACTER-WIDTH MAX-CHARACTER-WIDTH :ASCENT MAX-FONT-ASCENT :DESCENT MAX-FONT-DESCENT :ATTRIBUTES 0) :PIX-DEPTH 1 :GLYPH-SETS NUMBER-CHARACTERS :VERSION2 VERSION-STRING ;1; Metrics NIL when constant* :metrics (and (not constant-metrics) x11-metrics)))))) FONT-SYMBOL) (DEFUN READ-A-LINE (STREAM) "Reads a line from a font file." ;; Loop through each line read, skipping over special case lines. (LOOP FOR STRING = (MAKE-ARRAY 20 :ELEMENT-TYPE :STRING-CHAR :FILL-POINTER 0) with char do ;1; Skip newline and formfeed* (loop while (or (CHAR= (setq char (read-char stream)) '#.(INT-CHAR (LOGAND (CHAR-INT #\NEWLINE) #O177))) (CHAR= CHAR #\NEWLINE) (char= char #\linefeed))) ;1; Read into string until a newline or formfeed* (LOOP DO (VECTOR-PUSH-EXTEND CHAR STRING) (setq CHAR (READ-CHAR STREAM)) UNTIL (or (CHAR= CHAR '#.(INT-CHAR (LOGAND (CHAR-INT #\NEWLINE) #O177))) (CHAR= CHAR #\NEWLINE) (char= char #\linefeed))) ;; Skip over comment, empty and dot lines. WHILE (OR (STRING-EQUAL (SUBSEQ STRING 0 7) "COMMENT") ; For apl-s25 font (ZEROP (LENGTH STRING)) ; For cartoon font in crturz.bdf (STRING-EQUAL STRING (STRING #\CENTER-DOT))) ; For cursor font FINALLY (RETURN STRING))) (defun compile-x11-font (bdf-pathname &optional (xld-pathname "")) (let ((font-symbol (read-font bdf-pathname))) (setq bdf-pathname (parse-namestring bdf-pathname)) (compiler:DUMP-FORMS-TO-FILE (merge-pathnames (string-downcase (CONCATENATE 'SIMPLE-STRING X-FONT-OBJECT-PREFIX (PATHNAME-NAME bdf-pathname) "." (string (si::local-binary-file-type)))) xld-pathname) ;1; Take font-symbol from the file name, to allow aliasing* `((setq ,font-symbol ',(symbol-value font-symbol)) (setf (get ',font-symbol :x11-font-info) ',(get font-symbol :x11-font-info)) (let ((symbol (and si:fdefine-file-pathname (intern (string-upcase (pathname-name si:fdefine-file-pathname)) 'fonts)))) (when symbol (setf (symbol-value symbol) ,font-symbol) (setf (get symbol :x11-font-info) (get ',font-symbol :x11-font-info))))) `(:FONT-SYMBOL ,FONT-SYMBOL :PACKAGE :USER)))) (defun update-all-x-fonts (from to) (let ((files (directory (make-pathname :defaults from :type "BDF" :name :wild)))) (dolist (file files) (format t "~%~a " (pathname-name file)) ;; Skip 16b fonts (not handled yet) (unless (member (pathname-name file) '("K14") :test #'string-equal) (princ (compile-x11-font file to)))))) #| (update-all-x-fonts "stroke:/u1/XV11R3/fonts/bdf/" "tan:/u1/oren/fonts/") ;1; Andrew fonts* (let ((fudge -1)) ;1; The .bdf files in this directory are incorrect, so compensate* (update-all-x-fonts "tan:/u1/oren/andyfont/" "tan:/u1/oren/fonts/")) (update-all-x-fonts "tan:/u1/oren/andysrc/" "tan:/u1/oren/fonts/") (update-all-x-fonts "stroke:/u1/XV11R3/fonts/bdf/75dpi/" "tan:/u1/oren/fonts/") (update-all-x-fonts "stroke:/u1/XV11R3/fonts/bdf/misc/" "tan:/u1/oren/fonts/") |# #| (update-all-x-fonts "x11m:fonts.100dpi;" "x11m:fonts.100dpi;") (update-all-x-fonts "x11m:fonts.75dpi;" "x11m:fonts.75dpi;") (update-all-x-fonts "x11m:fonts.misc;" "x11m:fonts.misc;") (update-all-x-fonts "x11m:fonts.rel2;" "x11m:fonts.rel2;") |#