diff --git a/lispusers/READ-BDF b/lispusers/READ-BDF index afc91dd6e..9173001df 100644 --- a/lispusers/READ-BDF +++ b/lispusers/READ-BDF @@ -5,25 +5,25 @@ BITMAPHEIGHT BITMAPWIDTH BLACKSHADE BLTSHADE BOLD CONDENSED CHARSETINFO DISPLAY FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITESTRIKEFONTFILE)) READTABLE "XCL" BASE 10) -(IL:FILECREATED " 5-Mar-2025 12:44:10" IL:|{DSK}matt>Interlisp>medley>lispusers>READ-BDF.;39| 42641 +(IL:FILECREATED "25-Apr-2025 10:10:08" IL:|{DSK}matt>Interlisp>medley>lispusers>READ-BDF.;57| 47436 :EDIT-BY "mth" - :CHANGES-TO (IL:FUNCTIONS BDF-TO-CHARSETINFO READ-GLYPH) + :CHANGES-TO (IL:FUNCTIONS WRITE-BDF-TO-DISPLAYFONT-FILES READ-BDF BDF-TO-CHARSETINFO READ-GLYPH + GET-FAMILY-FACE-SIZE-FROM-NAME SPLIT-FONT-NAME) - :PREVIOUS-DATE "26-Feb-2025 15:23:23" IL:|{DSK}matt>Interlisp>medley>lispusers>READ-BDF.;37| + :PREVIOUS-DATE "23-Apr-2025 17:55:25" IL:|{DSK}matt>Interlisp>medley>lispusers>READ-BDF.;54| ) (IL:PRETTYCOMPRINT IL:READ-BDFCOMS) (IL:RPAQQ IL:READ-BDFCOMS - ((IL:STRUCTURES BDF-FONT GL-LIMITS GLYPH) + ((IL:STRUCTURES BDF-FONT GLYPH) (IL:VARIABLES MAXCHARSET MAXTHINCHAR NOMAPPINGCHARSET) - (IL:FUNCTIONS FIXUP-CHARSETINFO GET-FAMILY-FACE-SIZE-FROM-NAME PACKFILENAME.STRING - READ-BDF READ-DELIMITED-LIST-FROM-STRING READ-GLYPH) - (IL:FUNCTIONS BDF-TO-CHARSETINFO BDF-TO-FONTDESCRIPTOR GET-GLYPH-LIMITS GLYPHS-BY-CHARSET - SPLIT-FONT-NAME WRITE-BDF-TO-DISPLAYFONT-FILES) + (IL:FUNCTIONS BDF-TO-CHARSETINFO BDF-TO-FONTDESCRIPTOR GET-FAMILY-FACE-SIZE-FROM-NAME + GLYPHS-BY-CHARSET PACKFILENAME.STRING READ-BDF READ-DELIMITED-LIST-FROM-STRING + READ-GLYPH SPLIT-FONT-NAME WRITE-BDF-TO-DISPLAYFONT-FILES) (IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY (IL:FILES (IL:LOADCOMP) IL:FONT)) (FILE-ENVIRONMENTS "READ-BDF") @@ -31,90 +31,287 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST IL:READ-BDF))) (DEFSTRUCT (BDF-FONT (:CONC-NAME "BF-")) + "Main structure to hold a parsed BDF font file" (NAME NIL :TYPE STRING) (SIZE NIL :TYPE LIST) (BOUNDINGBOX NIL :TYPE LIST) (METRICSSET 0 :TYPE (INTEGER 0 2)) (PROPERTIES NIL :TYPE LIST) - SWIDTH DWIDTH SWIDTH1 DWIDTH1 VVECTOR (GLYPHS NIL :TYPE LIST)) + SWIDTH DWIDTH SWIDTH1 DWIDTH1 VVECTOR (GLYPHS NIL :TYPE LIST) + (SLUG NIL :TYPE GLYPH)) -(DEFSTRUCT (GL-LIMITS (:CONC-NAME "GLIM-")) +(DEFSTRUCT GLYPH + "This is an individual BDF glyph. Includes some values calculted for creating CHARSETINFO" + (NAME NIL :TYPE STRING) + ENCODING SWIDTH DWIDTH SWIDTH1 DWIDTH1 VVECTOR BBW BBH BBXOFF0 BBYOFF0 BITMAP (XCODE 0 :TYPE INTEGER) - (GLYPH NIL :TYPE GLYPH) (WIDTH 0 :TYPE INTEGER) (ASCENT 0 :TYPE INTEGER) (DESCENT 0 :TYPE INTEGER)) -(DEFSTRUCT GLYPH - (NAME NIL :TYPE STRING) - ENCODING SWIDTH DWIDTH SWIDTH1 DWIDTH1 VVECTOR BBW BBH BBXOFF0 BBYOFF0 BITMAP) - (DEFCONSTANT MAXCHARSET 255) (DEFCONSTANT MAXTHINCHAR 255) (DEFCONSTANT NOMAPPINGCHARSET (1+ MAXCHARSET)) -(DEFUN FIXUP-CHARSETINFO (CSINFO ASCENT DESCENT SLUGWIDTH) - (IL:* IL:\; "Edited 3-Feb-2025 19:19 by mth") - (LET* ((CSASCENT (IL:|fetch| (CHARSETINFO IL:CHARSETASCENT) IL:|of| CSINFO)) - (CSDESCENT (IL:|fetch| (CHARSETINFO IL:CHARSETDESCENT) IL:|of| CSINFO)) - (WIDTHS (IL:|fetch| (CHARSETINFO IL:WIDTHS) IL:|of| CSINFO)) - (BMAP (IL:|fetch| (CHARSETINFO IL:CHARSETBITMAP) IL:|of| CSINFO)) - (AMARGIN (- ASCENT CSASCENT)) - (DMARGIN (- DESCENT CSDESCENT)) - NEWBMAP) - (SETQ NEWBMAP (BITMAPCREATE (+ (BITMAPWIDTH BMAP) - SLUGWIDTH) - (+ ASCENT DESCENT) - 1)) - (BITBLT BMAP 0 0 NEWBMAP 0 DMARGIN (BITMAPWIDTH BMAP) - (BITMAPHEIGHT BMAP) - 'INPUT - 'IL:REPLACE) - (BLTSHADE BLACKSHADE NEWBMAP (1+ (BITMAPWIDTH BMAP)) - 0 - (1- SLUGWIDTH) - (+ ASCENT DESCENT) - 'IL:REPLACE) - (IL:|replace| (CHARSETINFO IL:CHARSETBITMAP) IL:|of| CSINFO IL:|with| NEWBMAP) - (IL:|replace| (CHARSETINFO IL:CHARSETASCENT) IL:|of| CSINFO IL:|with| ASCENT) - (IL:|replace| (CHARSETINFO IL:CHARSETDESCENT) IL:|of| CSINFO IL:|with| DESCENT) - (LOOP :FOR I :FROM 0 :TO (+ MAXTHINCHAR 2) - :WHEN - (ZEROP (\\FGETWIDTH WIDTHS I)) - :DO - (\\FSETWIDTH WIDTHS I SLUGWIDTH)))) - -(DEFUN GET-FAMILY-FACE-SIZE-FROM-NAME (BDFONT) (IL:* IL:\; "Edited 5-Feb-2025 12:56 by mth") +(DEFUN BDF-TO-CHARSETINFO (FONT CSET SLUG-OR-WIDTH &OPTIONAL MAP-UNKNOWN-TO-PRIVATE) + (IL:* IL:\; "Edited 23-Apr-2025 17:53 by mth") + (IL:* IL:\; "Edited 21-Apr-2025 16:23 by mth") + (IL:* IL:\; "Edited 30-Jan-2025 16:40 by mth") + (LET (GBCS CSGLYPHS CSLIMITS) + (UNLESS (AND (INTEGERP CSET) + (<= 0 CSET MAXCHARSET)) + (ERROR "Invalid Character set: ~S" CSET) + + (IL:* IL:|;;| "Can we get here? I think not!") + + (SETQ CSET 0)) + (SETQ GBCS (COND + ((LISTP FONT) + + (IL:* IL:|;;| + "Assuming that FONT is already the LIST of ALIST form of result from GLYPHS-BY-CHARSET") + + FONT) + ((BDF-FONT-P FONT) + + (IL:* IL:|;;| + "If passed a BDF-FONT, look only at glyphs in the mapped charsets") + + (FIRST (GLYPHS-BY-CHARSET FONT MAP-UNKNOWN-TO-PRIVATE))) + (T (ERROR "Invalid FONT: ~S" FONT)))) + (WHEN (SETQ CSGLYPHS (SECOND (ASSOC CSET GBCS))) + (LET ((TOTAL-WIDTH 0) + (ASCENT 0) + (DESCENT 0) + (FIRSTCHAR MOST-POSITIVE-FIXNUM) + (LASTCHAR MOST-NEGATIVE-FIXNUM) + (CSINFO (IL:|create| CHARSETINFO)) + (DLEFT 0) + SLUG SLUGWIDTH GLYPHS-LIMITS BMAP OFFSETS HEIGHT WIDTHS) + (COND + ((GLYPH-P SLUG-OR-WIDTH) + (SETQ SLUG SLUG-OR-WIDTH) + (SETQ SLUGWIDTH (1+ (GLYPH-WIDTH SLUG))) + (SETQ ASCENT (MAX ASCENT (GLYPH-ASCENT SLUG))) + (SETQ DESCENT (MAX DESCENT (GLYPH-DESCENT SLUG)))) + ((INTEGERP SLUG-OR-WIDTH) + (SETQ SLUGWIDTH SLUG-OR-WIDTH)) + (T (ERROR "Invalid SLUG-OR-WIDTH: ~S" SLUG-OR-WIDTH))) + (SETQ CSGLYPHS (LOOP :FOR XGL :IN CSGLYPHS :COLLECT (LET* ((XCODE (CAR XGL)) + (GL (CDR XGL)) + (GWIDTH (GLYPH-WIDTH + GL)) + (ASC (GLYPH-ASCENT GL)) + (DSC (GLYPH-DESCENT + GL))) + + (IL:* IL:|;;| "It's possible that ALL glyphs in the character set are above the baseline. In that case, the GLYPH-DESCENT calculated by READ-GLYPH will not give a useful value, since it is >= 0. Investigate correcting this.") + + (IL:* IL:|;;| +  + "Is the above statement actually true?") + + (SETF (GLYPH-XCODE GL) + XCODE) + (SETQ FIRSTCHAR + (MIN FIRSTCHAR XCODE + )) + (SETQ LASTCHAR + (MAX LASTCHAR XCODE) + ) + (INCF TOTAL-WIDTH GWIDTH) + (SETQ ASCENT + (MAX ASCENT ASC)) + (SETQ DESCENT + (MAX DESCENT DSC)) + GL))) + (IL:|replace| (CHARSETINFO IL:CHARSETASCENT) IL:|of| CSINFO IL:|with| ASCENT) + (IL:|replace| (CHARSETINFO IL:CHARSETDESCENT) IL:|of| CSINFO IL:|with| DESCENT) + (SETQ OFFSETS (IL:|fetch| (CHARSETINFO IL:OFFSETS) IL:|of| CSINFO)) + + (IL:* IL:|;;| + "Initialize the offsets to the TOTAL-WIDTH (without the SLUG. It will be added later)") + + (IL:|for| I IL:|from| 0 IL:|to| (+ MAXTHINCHAR 2) IL:|do| (\\FSETOFFSET OFFSETS I + TOTAL-WIDTH)) + (SETQ WIDTHS (IL:|fetch| (CHARSETINFO IL:WIDTHS) IL:|of| CSINFO)) + + (IL:* IL:|;;| "Initialize the widths to SLUGWIDTH") + + (IL:|for| I IL:|from| 0 IL:|to| (+ MAXTHINCHAR 2) IL:|do| (\\FSETWIDTH WIDTHS I + SLUGWIDTH)) + (IL:|replace| (CHARSETINFO IL:IMAGEWIDTHS) IL:|of| CSINFO IL:|with| WIDTHS) + + (IL:* IL:|;;| "JDS 12/4/92: Apparently, these fields can be signed values, if all chars, e.g., ride above the base line. ") + + (IL:* IL:|;;| " From \\READSTRIKEFONTFILE, so -ve DESCENT is possible?") + + (SETQ HEIGHT (+ ASCENT DESCENT)) + (SETQ BMAP (BITMAPCREATE (+ TOTAL-WIDTH SLUGWIDTH) + HEIGHT 1)) + (IL:|replace| (CHARSETINFO IL:CHARSETBITMAP) IL:|of| CSINFO IL:|with| BMAP) + (LOOP :FOR GL :IN CSGLYPHS :WITH GLBM :WITH GLW :WITH XCODE :DO (SETQ GLBM + (GLYPH-BITMAP + GL)) + (SETQ GLW (GLYPH-WIDTH GL)) + (SETQ XCODE (GLYPH-XCODE GL)) + (BITBLT GLBM 0 0 BMAP (+ DLEFT (MAX 0 (GLYPH-BBXOFF0 GL))) + (+ DESCENT (GLYPH-BBYOFF0 GL)) + (BITMAPWIDTH GLBM) + (BITMAPHEIGHT GLBM) + 'INPUT + 'IL:REPLACE) + (\\FSETOFFSET OFFSETS XCODE DLEFT) + (\\FSETOFFSET WIDTHS XCODE GLW) + (INCF DLEFT GLW)) + + (IL:* IL:|;;| "Now insert the SLUG glyph into the BMAP, or make a slug (block)") + + (IF SLUG + (LET ((GLBM (GLYPH-BITMAP SLUG))) + (BITBLT GLBM 0 0 BMAP (+ TOTAL-WIDTH (MAX 0 (GLYPH-BBXOFF0 SLUG))) + (+ DESCENT (GLYPH-BBYOFF0 SLUG)) + (BITMAPWIDTH GLBM) + (BITMAPHEIGHT GLBM) + 'INPUT + 'IL:REPLACE)) + (BLTSHADE BLACKSHADE BMAP (1+ TOTAL-WIDTH) + 0 + (1- SLUGWIDTH) + (+ ASCENT DESCENT) + 'IL:REPLACE)) + CSINFO)))) + +(DEFUN BDF-TO-FONTDESCRIPTOR (BDFONT FAMILY SIZE FACE ROTATION DEVICE &OPTIONAL + MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING) + (IL:* IL:\; "Edited 21-Apr-2025 16:03 by mth") + (IL:* IL:\; "Edited 30-Jan-2025 21:27 by mth") + (WHEN (AND (BDF-FONT-P BDFONT) + FAMILY) (IL:* IL:\; "FAMILY Cannot be NIL") + (PROG* ((SLUG (BF-SLUG BDFONT)) + (SLUGWIDTH (AND SLUG (GLYPH-WIDTH SLUG))) + FONTDESC DEV GBCSL CHARSETS) + (WHEN (FONTP FAMILY) + (RETURN (BDF-TO-FONTDESCRIPTOR BDFONT (FONTPROP FAMILY 'IL:FAMILY) + (OR SIZE (FONTPROP FAMILY 'IL:SIZE)) + (OR FACE (FONTPROP FAMILY 'IL:FACE)) + (OR ROTATION (FONTPROP FAMILY 'IL:ROTATION)) + (OR DEVICE (FONTPROP FAMILY 'IL:DEVICE)) + MAP-UNKNOWN-TO-PRIVATE))) + (WHEN (LISTP FAMILY) + (RETURN (BDF-TO-FONTDESCRIPTOR BDFONT (FIRST FAMILY) + (OR (SECOND FAMILY) + SIZE) + (OR (THIRD FAMILY) + FACE "MRR") + (OR (FOURTH FAMILY) + ROTATION 0) + (OR (FIFTH FAMILY) + DEVICE + 'DISPLAY) + MAP-UNKNOWN-TO-PRIVATE))) + (SETQ FAMILY (\\FONTSYMBOL FAMILY)) + (UNLESS (AND (INTEGERP SIZE) + (PLUSP SIZE)) + (ERROR "Invalid SIZE: ~S~%" SIZE)) + (COND + ((NULL ROTATION) + (SETQ ROTATION 0)) + ((NOT (AND (INTEGERP ROTATION) + (>= ROTATION 0))) + (IL:\\ILLEGAL.ARG ROTATION))) + (SETQ DEV DEVICE) + (SETQ DEV (COND + ((NULL DEVICE) + 'DISPLAY) + ((AND (SYMBOLP DEVICE) + (NOT (EQ DEVICE T))) + + (IL:* IL:|;;| + "Maybe wrong case or package, but we bet it's OK and defer expensive coercion until we've failed.") + + DEVICE) + ((STRINGP DEVICE) + (INTERN (STRING-UPCASE DEVICE) + "IL")) + (T (IL:\\ILLEGAL.ARG DEVICE)))) + (SETQ FACE (\\FONTFACE FACE NIL DEV)) + (SETQ GBCSL (GLYPHS-BY-CHARSET BDFONT MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING)) + (UNLESS SLUGWIDTH + + (IL:* IL:|;;| + "If GLYPHS-BY-CHARSET didn't determine the SLUG width, use 60% of the SIZE, at least 1") + + (SETQ SLUGWIDTH (OR (THIRD GBCSL) + (MAX 1 (ROUND (* 0.6 SIZE)))))) + (FLET ((GBCS-TO-FONTDESC + (GBCS FAMILY) + (LET (FONTDESC CHARSETS) + (WHEN GBCS + (SETQ FONTDESC + (IL:|create| FONTDESCRIPTOR + IL:FONTDEVICE IL:_ DEV + IL:FONTFAMILY IL:_ FAMILY + IL:FONTSIZE IL:_ SIZE + IL:FONTFACE IL:_ FACE + IL:|\\SFAscent| IL:_ 0 + IL:|\\SFDescent| IL:_ 0 + IL:|\\SFHeight| IL:_ 0 + IL:ROTATION IL:_ ROTATION + IL:FONTDEVICESPEC IL:_ (LIST FAMILY SIZE FACE ROTATION + DEV))) + (SETQ CHARSETS (LOOP :FOR CS :IN GBCS :WITH CSET :WITH CSINFO :NCONC + (WHEN (<= 0 (SETQ CSET (FIRST CS)) + MAXCHARSET) + (SETQ CSINFO (BDF-TO-CHARSETINFO + GBCS CSET (OR SLUG (1+ + SLUGWIDTH + )))) + (\\INSTALLCHARSETINFO FONTDESC CSINFO CSET) + (LIST CSET))))) + (LIST FONTDESC CHARSETS)))) + (RETURN (VALUES-LIST (NCONC (GBCS-TO-FONTDESC (FIRST GBCSL) + FAMILY) + (GBCS-TO-FONTDESC (SECOND GBCSL) + (\\FONTSYMBOL (CONCATENATE 'STRING + (SYMBOL-NAME FAMILY) + "-UNMAPPED"))) + (LIST (ASSOC NOMAPPINGCHARSET (FIRST GBCSL) + :TEST + #'EQL))))))))) + +(DEFUN GET-FAMILY-FACE-SIZE-FROM-NAME (BDFONT) (IL:* IL:\; "Edited 23-Apr-2025 16:20 by mth") + (IL:* IL:\; "Edited 5-Feb-2025 12:56 by mth") (UNLESS (TYPEP BDFONT 'BDF-FONT) - (ERROR "Not a BDF-FONT: ~S~%" BDFONT)) + (ERROR "Not a BDF-FONT: ~S~%" BDFONT)) (DESTRUCTURING-BIND (FOUNDRY FAMILY WEIGHT SLANT EXPANSION ADD_STYLE_NAME PIXEL-SIZE POINT-SIZE) (SPLIT-FONT-NAME (BF-NAME BDFONT)) (IL:* IL:\; "Parse as XLFD format") (DECLARE (IGNORE FOUNDRY ADD_STYLE_NAME)) (IL:* IL:\;  "Don't need FOUNDRY or ADD_STYLE_NAME") (SETQ FAMILY (REMOVE #\Space FAMILY :TEST #'CHAR=)) - (SETQ WEIGHT (OR (CDR (ASSOC (CHAR-UPCASE (ELT WEIGHT 0)) - '((#\R . MEDIUM) - (#\M . MEDIUM) - (#\N . MEDIUM) - (#\B . BOLD) - (#\D . BOLD) - (#\L . LIGHT)))) + (SETQ WEIGHT (OR (AND WEIGHT (CDR (ASSOC (CHAR-UPCASE (ELT WEIGHT 0)) + '((#\R . MEDIUM) + (#\M . MEDIUM) + (#\N . MEDIUM) + (#\B . BOLD) + (#\D . BOLD) + (#\L . LIGHT))))) 'MEDIUM)) (IL:* IL:\; "DemiBold => BOLD") - (SETQ SLANT (OR (CDR (ASSOC (STRING-UPCASE SLANT) - '(("R" . REGULAR) - ("I" . ITALIC) - ("O" . ITALIC)))) + (SETQ SLANT (OR (AND SLANT (CDR (ASSOC (STRING-UPCASE SLANT) + '(("R" . REGULAR) + ("I" . ITALIC) + ("O" . ITALIC))))) 'REGULAR)) (IL:* IL:\; "Oblique => ITALIC") (IL:* IL:\; "Ignore others") - (SETQ EXPANSION (OR (CDR (ASSOC (CHAR-UPCASE (ELT EXPANSION 0)) - '((#\R . REGULAR) - (#\N . REGULAR) - (#\B . BOLD) - (#\S . CONDENSED) - (#\C . CONDENSED)))) + (SETQ EXPANSION (OR (AND EXPANSION (CDR (ASSOC (CHAR-UPCASE (ELT EXPANSION 0)) + '((#\R . REGULAR) + (#\N . REGULAR) + (#\B . BOLD) + (#\S . CONDENSED) + (#\C . CONDENSED))))) 'REGULAR)) (IL:* IL:\;  "S is for \"SemiCondensed\", Assuming \"Condensed\"") @@ -137,6 +334,139 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST POINT-SIZE (FIRST (BF-SIZE BDFONT)))))) +(DEFUN GLYPHS-BY-CHARSET (FONT &OPTIONAL MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING) + (IL:* IL:\; "Edited 21-Apr-2025 15:48 by mth") + (IL:* IL:\; "Edited 9-Jan-2025 11:23 by mth") + (LET* ((NCSETS (+ MAXCHARSET 2)) + (CSETS (MAKE-ARRAY NCSETS :INITIAL-CONTENTS (LOOP :REPEAT NCSETS :COLLECT (CONS NIL)))) + (UTOXFN (COND + (RAW-UNICODE-MAPPING #'IDENTITY) + (MAP-UNKNOWN-TO-PRIVATE #'UTOXCODE) + (T #'UTOXCODE?))) + (SLUG (BF-SLUG FONT)) + (SLUGWIDTH (AND SLUG (GLYPH-WIDTH SLUG))) + NOMAPPINGCSETS ENC XCODE XCS) + (UNLESS (OR MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING) + (SETQ NOMAPPINGCSETS (MAKE-ARRAY NCSETS :INITIAL-CONTENTS (LOOP :REPEAT NCSETS :COLLECT + (CONS NIL))))) + (FLET ((PUT-GLYPH-IN-CHARSET-ARRAY (CODE GLYPH CSARRAY) + (TCONC (AREF CSARRAY (LRSH CODE 8)) + (CONS (LOGAND CODE 255) + GLYPH)))) + (LOOP :FOR GL :IN (BF-GLYPHS FONT) + :UNLESS + (EQ GL SLUG) + :DO + (SETQ XCS NIL) + (SETQ ENC (GLYPH-ENCODING GL)) + (WHEN (LISTP ENC) + + (IL:* IL:|;;| + "Should happen only if -1 is first on ENCODING line in BDF file") + + (SETQ ENC (OR (SECOND ENC) + -1)) + + (IL:* IL:|;;| + "The -1 case of the (OR ...) shouldn't happen. The (EQ GL SLUG) test above should have caught it") + + ) + (SETQ XCODE (AND (INTEGERP ENC) + (PLUSP ENC) + (FUNCALL UTOXFN ENC))) + (IF RAW-UNICODE-MAPPING + (COND + ((> ENC 65535) + (WARN "~&Unicode encoding is beyond 16 bits: ~5X" ENC) + (TCONC (AREF CSETS NOMAPPINGCHARSET) + (CONS ENC GL))) + ((AND NIL (= 255 (LOGAND ENC 255))) + + (IL:* IL:|;;| + "Temporarily? disable this warning in RAW-UNICODE-MAPPING mode") + + (WARN + "~&Unicode encoding char byte (~2X,FF)=(~O,377) may not =FF in FONTDESCRIPTOR" + (LRSH ENC 8) + (LRSH ENC 8)) + (TCONC (AREF CSETS NOMAPPINGCHARSET) + (CONS ENC GL))) + (T (PUT-GLYPH-IN-CHARSET-ARRAY ENC GL CSETS))) + (COND + ((NULL XCODE) + + (IL:* IL:|;;| "These assoc with the Unicode encoding") + + (COND + ((OR (> ENC 65535) + (= 255 (LOGAND ENC 255))) + + (IL:* IL:|;;| + "Unicode encoding is > xFFFF, or encoding low byte is FF, put it in the NOMAPPINGCHARSET") + + (TCONC (AREF CSETS NOMAPPINGCHARSET) + (CONS ENC GL))) + (T (PUT-GLYPH-IN-CHARSET-ARRAY ENC GL NOMAPPINGCSETS)))) + ((AND (INTEGERP XCODE) + (<= 0 XCODE 65535)) + + (IL:* IL:|;;| + "These assoc with the 8 bit character code within the charset") + + (PUT-GLYPH-IN-CHARSET-ARRAY XCODE GL CSETS) + + (IL:* IL:|;;| "Default SLUG width is width of A.") + + (WHEN (AND (NOT SLUGWIDTH) + (= ENC (CHAR-CODE #\A))) + + (IL:* IL:|;;| "A is the same code in XCCS and UNICODE ") + + (IL:* IL:|;;| + "Comparing with ENC, not XCODE, to look only in charset 0") + + (SETQ SLUGWIDTH (GLYPH-WIDTH GL)))) + ((LISTP XCODE) + + (IL:* IL:|;;| + "These assoc with the 8 bit character code within the charset (like above)") + + (LOOP :FOR XC :IN XCODE :WITH CS :UNLESS (MEMBER (SETQ CS + (LRSH XC 8)) + XCS) + :DO + (PUSH CS XCS) + (PUT-GLYPH-IN-CHARSET-ARRAY XC GL CSETS))) + (T (ERROR "Invalid XCODE: ~A~%")))))) + + (IL:* IL:|;;| "Extract the lists from the TCONC pointers") + + (LOOP :FOR I :FROM 0 :TO NOMAPPINGCHARSET :DO (SETF (AREF CSETS I) + (SORT (REMOVE-DUPLICATES + (CAR (AREF CSETS I)) + :TEST + #'EQUAL) + #'< :KEY #'CAR))) + (SETQ CSETS (LOOP :FOR I :FROM 0 :TO NOMAPPINGCHARSET :NCONC + (LET ((CS (AREF CSETS I))) + (WHEN CS + (LIST (LIST I CS)))))) + + (IL:* IL:|;;| "Likewise for the NOMAPPINGCSETS, if any.") + + (WHEN NOMAPPINGCSETS + (LOOP :FOR I :FROM 0 :TO NOMAPPINGCHARSET :DO + (SETF (AREF NOMAPPINGCSETS I) + (SORT (REMOVE-DUPLICATES (CAR (AREF NOMAPPINGCSETS I)) + :TEST + #'EQUAL) + #'< :KEY #'CAR))) + (SETQ NOMAPPINGCSETS (LOOP :FOR I :FROM 0 :TO NOMAPPINGCHARSET :NCONC + (LET ((CS (AREF NOMAPPINGCSETS I))) + (WHEN CS + (LIST (LIST I CS))))))) + (LIST CSETS NOMAPPINGCSETS SLUGWIDTH))) + (DEFMACRO PACKFILENAME.STRING (&WHOLE WHOLE) (IL:* IL:\; "Edited 1-Feb-2025 23:17 by mth") `(IL:PACKFILENAME.STRING ,@(LOOP :FOR X :IN (CDR WHOLE) :BY @@ -157,17 +487,21 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST X)) Y)))) -(DEFUN READ-BDF (PATH) (IL:* IL:\; "Edited 26-Feb-2025 15:22 by mth") - (IL:* IL:\; "Edited 23-Sep-2024 12:37 by mth") - (IL:* IL:\; "Edited 22-Aug-2024 16:43 by mth") - (IL:* IL:\; "Edited 17-Jul-2024 14:45 by mth") +(DEFUN READ-BDF (PATH &OPTIONAL VERBOSE) (IL:* IL:\; "Edited 24-Apr-2025 00:44 by mth") + (IL:* IL:\; "Edited 17-Apr-2025 15:10 by mth") (IL:* IL:\; "Edited 12-Jul-2024 23:02 by mth") (LET - (PROPS PROPS-COMPLETE CHARS-COUNT FONT-COMPLETE FONT POS KEY V VV LINE ITEMS (NGLYPHS 0) + (PROPS PROPS-COMPLETE CHARS-COUNT FONT-COMPLETE FONT POS KEY V VV LINE ITEMS GL (NGLYPHS 0) (*PACKAGE* (FIND-PACKAGE "BDF"))) (WITH-OPEN-FILE (FILE-STREAM PATH :ELEMENT-TYPE 'CHARACTER :DIRECTION :INPUT) - (UNLESS (STRING-EQUAL "STARTFONT" (READ FILE-STREAM)) + (LOOP :WHILE (STRING-EQUAL "COMMENT" (SETQ KEY (READ FILE-STREAM))) + :DO + + (IL:* IL:|;;| "Ignore initial COMMENT lines.") + + (READ-LINE FILE-STREAM)) + (UNLESS (STRING-EQUAL "STARTFONT" KEY) (ERROR "Invalid BDF file - must begin with STARTFONT.")) (IL:* IL:|;;| "ignore the file format version number") @@ -252,8 +586,30 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST (ERROR "Invalid BDF file - CHARS count (~A) is invalid or missing." NGLYPHS)) (SETF (BF-GLYPHS FONT) - (LOOP :REPEAT NGLYPHS :COLLECT (READ-GLYPH FILE-STREAM FONT)))) + (LOOP :REPEAT NGLYPHS :COLLECT + (PROG1 (SETQ GL (READ-GLYPH FILE-STREAM FONT)) + + (IL:* IL:|;;| + "Any GLYPH with ENCODING of -1 is taken as the SLUG glyph. If multiple, the last applies.") + + (SETQ V (GLYPH-ENCODING GL)) + (WHEN (AND (LISTP V) + (EQ (FIRST V) + -1)) + (SETQ V (OR (SECOND V) + -1))) + (WHEN (EQ V -1) + (SETF (BF-SLUG FONT) + GL)))))) (ENDFONT (SETQ FONT-COMPLETE T)))))))) + (WHEN VERBOSE + (DESTRUCTURING-BIND (FAMILY (WEIGHT SLANT EXPANSION) + SIZE) + (GET-FAMILY-FACE-SIZE-FROM-NAME FONT) + (FORMAT *STANDARD-OUTPUT* + "Name: ~A~%Family: ~A~%Size: ~A~%Weight: ~A~%Slant: ~A~%Expansion: ~A~%" + (BF-NAME FONT) + FAMILY SIZE WEIGHT SLANT EXPANSION))) FONT))) (DEFUN READ-DELIMITED-LIST-FROM-STRING (INPUT-STRING &OPTIONAL (DELIMIT #\])) @@ -261,11 +617,10 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST (WITH-INPUT-FROM-STRING (SI (CONCATENATE 'STRING INPUT-STRING " " (STRING DELIMIT))) (READ-DELIMITED-LIST DELIMIT SI))) -(DEFUN READ-GLYPH (FILE-STREAM FONT) (IL:* IL:\; "Edited 5-Mar-2025 12:20 by mth") - (IL:* IL:\; "Edited 26-Feb-2025 15:23 by mth") - (IL:* IL:\; "Edited 2-Feb-2025 20:29 by mth") - (IL:* IL:\; "Edited 23-Sep-2024 12:38 by mth") - (IL:* IL:\; "Edited 22-Aug-2024 20:53 by mth") +(DEFUN READ-GLYPH (FILE-STREAM FONT) (IL:* IL:\; "Edited 23-Apr-2025 17:53 by mth") + (IL:* IL:\; "Edited 21-Apr-2025 13:37 by mth") + (IL:* IL:\; "Edited 19-Apr-2025 09:32 by mth") + (IL:* IL:\; "Edited 17-Apr-2025 18:14 by mth") (IL:* IL:\; "Edited 21-Aug-2024 01:10 by mth") (LET ((GLYPH (MAKE-GLYPH :SWIDTH (COPY-LIST (BF-SWIDTH FONT)) :DWIDTH @@ -352,327 +707,63 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST (SETF (GLYPH-BITMAP GLYPH) BM))) (ENDCHAR (SETQ CHAR-COMPLETE T))))))) + (SETF (GLYPH-ASCENT GLYPH) + (+ (GLYPH-BBH GLYPH) + (GLYPH-BBYOFF0 GLYPH))) + (SETF (GLYPH-DESCENT GLYPH) + (ABS (MIN 0 (GLYPH-BBYOFF0 GLYPH)))) + (SETF (GLYPH-WIDTH GLYPH) + (MAX (+ (MAX 0 (GLYPH-BBXOFF0 GLYPH)) + (GLYPH-BBW GLYPH)) + (FIRST (GLYPH-DWIDTH GLYPH)))) GLYPH)) -(DEFUN BDF-TO-CHARSETINFO (FONT CSET &OPTIONAL MAP-UNKNOWN-TO-PRIVATE) - (IL:* IL:\; "Edited 5-Mar-2025 12:39 by mth") - (IL:* IL:\; "Edited 3-Feb-2025 16:02 by mth") - (IL:* IL:\; "Edited 30-Jan-2025 16:40 by mth") - (LET (GBCS CSGLYPHS CSLIMITS) - (UNLESS (AND (INTEGERP CSET) - (<= 0 CSET MAXCHARSET)) - (ERROR "Invalid Character set: ~S" CSET) - - (IL:* IL:|;;| "Can we get here?") - - (SETQ CSET 0)) - (SETQ GBCS (COND - ((TYPEP FONT 'BDF-FONT) - (GLYPHS-BY-CHARSET FONT MAP-UNKNOWN-TO-PRIVATE)) - ((LISTP FONT) - - (IL:* IL:|;;| - "Assuming that FONT is already the A-LIST form of result from GLYPHS-BY-CHARSET") - - FONT) - (T (ERROR "Invalid FONT: ~S" FONT)))) - (WHEN (SETQ CSGLYPHS (SECOND (ASSOC CSET GBCS))) - (LET ((TOTAL-WIDTH 0) - (ASCENT 0) - (DESCENT 0) - (FIRSTCHAR MOST-POSITIVE-FIXNUM) - (LASTCHAR MOST-NEGATIVE-FIXNUM) - (CSINFO (IL:|create| CHARSETINFO)) - (DLEFT 0) - GLYPHS-LIMITS BMAP OFFSETS HEIGHT WIDTHS) - (SETQ GLYPHS-LIMITS (LOOP :FOR XGL :IN CSGLYPHS :COLLECT - (LET* ((XCODE (CAR XGL)) - (GL (CDR XGL)) - (GLIMITS (GET-GLYPH-LIMITS GL)) - (GWIDTH (GLIM-WIDTH GLIMITS)) - (ASC (GLIM-ASCENT GLIMITS)) - (DSC (GLIM-DESCENT GLIMITS))) - - (IL:* IL:|;;| "It's possible that ALL glyphs in the character set are above the baseline. In that case, the GLIM-DESCENT calculated by GET-GLYPH-LIMITS will not give a useful value, since it is >= 0. Investigate correcting this.") - - (SETF (GLIM-GLYPH GLIMITS) - GL) - (SETF (GLIM-XCODE GLIMITS) - XCODE) - (SETQ FIRSTCHAR (MIN FIRSTCHAR XCODE)) - (SETQ LASTCHAR (MAX LASTCHAR XCODE)) - (INCF TOTAL-WIDTH GWIDTH) - (SETQ ASCENT (MAX ASCENT ASC)) - (SETQ DESCENT (MAX DESCENT DSC)) - GLIMITS))) - (IL:|replace| (CHARSETINFO IL:CHARSETASCENT) IL:|of| CSINFO IL:|with| ASCENT) - (IL:|replace| (CHARSETINFO IL:CHARSETDESCENT) IL:|of| CSINFO IL:|with| DESCENT) - (SETQ OFFSETS (IL:|fetch| (CHARSETINFO IL:OFFSETS) IL:|of| CSINFO)) - - (IL:* IL:|;;| - "Initialize the offsets to the TOTAL-WIDTH (without the SLUG. It will be added later)") - - (IL:|for| I IL:|from| 0 IL:|to| (+ MAXTHINCHAR 2) IL:|do| (\\FSETOFFSET OFFSETS I - TOTAL-WIDTH)) - (SETQ WIDTHS (IL:|fetch| (CHARSETINFO IL:WIDTHS) IL:|of| CSINFO)) - - (IL:* IL:|;;| - "Initialize the widths to 0, the width of the slug will be set in FIXUP-CHARSETINFO") - - (IL:|for| I IL:|from| 0 IL:|to| (+ MAXTHINCHAR 2) IL:|do| (\\FSETWIDTH WIDTHS I 0)) - (IL:|replace| (CHARSETINFO IL:IMAGEWIDTHS) IL:|of| CSINFO IL:|with| WIDTHS) - - (IL:* IL:|;;| "JDS 12/4/92: Apparently, these fields can be signed values, if all chars, e.g., ride above the base line. ") - - (IL:* IL:|;;| " From \\READSTRIKEFONTFILE, so -ve DESCENT is possible?") - - (SETQ HEIGHT (+ ASCENT DESCENT)) - (SETQ BMAP (BITMAPCREATE TOTAL-WIDTH HEIGHT 1)) - (LOOP :FOR GLIM :IN GLYPHS-LIMITS :WITH GL :WITH GLBM :WITH GLW :WITH XCODE :DO - (SETQ GL (GLIM-GLYPH GLIM)) - (SETQ GLBM (GLYPH-BITMAP GL)) - (SETQ GLW (GLIM-WIDTH GLIM)) - (SETQ XCODE (GLIM-XCODE GLIM)) - (BITBLT GLBM 0 0 BMAP (+ DLEFT (GLYPH-BBXOFF0 GL)) - (+ DESCENT (GLYPH-BBYOFF0 GL)) - (BITMAPWIDTH GLBM) - (BITMAPHEIGHT GLBM) - 'INPUT - 'IL:REPLACE) - (\\FSETOFFSET OFFSETS XCODE DLEFT) - (\\FSETOFFSET WIDTHS XCODE GLW) - (INCF DLEFT GLW)) - (IL:|replace| (CHARSETINFO IL:CHARSETBITMAP) IL:|of| CSINFO IL:|with| BMAP) - CSINFO)))) - -(DEFUN BDF-TO-FONTDESCRIPTOR (BDFONT FAMILY SIZE FACE ROTATION DEVICE &OPTIONAL - MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING) - (IL:* IL:\; "Edited 5-Feb-2025 14:53 by mth") - (IL:* IL:\; "Edited 30-Jan-2025 21:27 by mth") - (WHEN (AND (BDF-FONT-P BDFONT) - FAMILY) (IL:* IL:\; "FAMILY Cannot be NIL") - (PROG (FONTDESC DEV GBCSL CHARSETS) - (WHEN (LISTP FAMILY) - (RETURN (BDF-TO-FONTDESCRIPTOR BDFONT (FIRST FAMILY) - (OR (SECOND FAMILY) - SIZE) - (OR (THIRD FAMILY) - FACE "MRR") - (OR (FOURTH FAMILY) - ROTATION 0) - (OR (FIFTH FAMILY) - DEVICE - 'DISPLAY) - MAP-UNKNOWN-TO-PRIVATE))) - (WHEN (FONTP FAMILY) - (RETURN (BDF-TO-FONTDESCRIPTOR BDFONT (FONTPROP FAMILY 'IL:FAMILY) - (OR SIZE (FONTPROP FAMILY 'IL:SIZE)) - (OR FACE (FONTPROP FAMILY 'IL:FACE)) - (OR ROTATION (FONTPROP FAMILY 'IL:ROTATION)) - (OR DEVICE (FONTPROP FAMILY 'IL:DEVICE)) - MAP-UNKNOWN-TO-PRIVATE))) - (SETQ FAMILY (\\FONTSYMBOL FAMILY)) - (UNLESS (AND (INTEGERP SIZE) - (PLUSP SIZE)) - (ERROR "Invalid SIZE: ~S~%" SIZE)) - (COND - ((NULL ROTATION) - (SETQ ROTATION 0)) - ((NOT (AND (INTEGERP ROTATION) - (>= ROTATION 0))) - (IL:\\ILLEGAL.ARG ROTATION))) - (SETQ DEV DEVICE) - (SETQ DEV (COND - ((NULL DEVICE) - 'DISPLAY) - ((AND (SYMBOLP DEVICE) - (NOT (EQ DEVICE T))) (IL:* IL:\; - "Maybe wrong case or package, but we bet it's OK and defer expensive coercion until we've failed.") - DEVICE) - ((STRINGP DEVICE) - (INTERN (STRING-UPCASE DEVICE) - "IL")) - (T (IL:\\ILLEGAL.ARG DEVICE)))) - (SETQ FACE (\\FONTFACE FACE NIL DEV)) - (SETQ GBCSL (GLYPHS-BY-CHARSET BDFONT MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING)) - (FLET ((GBCS-TO-FONTDESC (GBCS FAMILY) - (LET (FONTDESC CHARSETS) - (WHEN GBCS - (SETQ FONTDESC - (IL:|create| FONTDESCRIPTOR - IL:FONTDEVICE IL:_ DEV - IL:FONTFAMILY IL:_ FAMILY - IL:FONTSIZE IL:_ SIZE - IL:FONTFACE IL:_ FACE - IL:|\\SFAscent| IL:_ 0 - IL:|\\SFDescent| IL:_ 0 - IL:|\\SFHeight| IL:_ 0 - IL:ROTATION IL:_ ROTATION - IL:FONTDEVICESPEC IL:_ - (LIST FAMILY SIZE FACE ROTATION DEV))) - (SETQ CHARSETS - (LOOP :FOR CS :IN GBCS :WITH CSET :WITH CSINFO :NCONC - (WHEN (<= 0 (SETQ CSET (FIRST CS)) - MAXCHARSET) - (SETQ CSINFO (BDF-TO-CHARSETINFO GBCS CSET)) - (\\INSTALLCHARSETINFO FONTDESC CSINFO CSET) - (LIST (CONS CSET CSINFO))))) - (SETQ CHARSETS (LOOP :FOR CSP :IN CHARSETS :WITH ASCENT = - (FONTPROP FONTDESC 'IL:ASCENT) - :WITH DESCENT = (FONTPROP FONTDESC - 'IL:DESCENT) - :WITH SLUGWIDTH = (1+ (\\AVGCHARWIDTH - FONTDESC)) - :COLLECT - (PROGN (FIXUP-CHARSETINFO (CDR CSP) - ASCENT DESCENT SLUGWIDTH) - (CAR CSP))))) - (LIST FONTDESC CHARSETS)))) - (RETURN (VALUES-LIST (NCONC (GBCS-TO-FONTDESC (FIRST GBCSL) - FAMILY) - (GBCS-TO-FONTDESC (SECOND GBCSL) - (\\FONTSYMBOL (CONCATENATE 'STRING (SYMBOL-NAME - FAMILY) - "-UNMAPPED"))) - (LIST (ASSOC NOMAPPINGCHARSET (FIRST GBCSL) - :TEST - #'EQ))))))))) - -(DEFUN GET-GLYPH-LIMITS (GLYPH) (IL:* IL:\; "Edited 2-Feb-2025 21:07 by mth") - (IL:* IL:\; "Edited 29-Jan-2025 16:28 by mth") - (LET* ((BBYOFF0 (GLYPH-BBYOFF0 GLYPH)) - (ASCENT (+ (GLYPH-BBH GLYPH) - BBYOFF0)) - (DESCENT (ABS (MIN 0 BBYOFF0))) - (GWIDTH (MAX (+ (GLYPH-BBXOFF0 GLYPH) - (GLYPH-BBW GLYPH)) - (FIRST (GLYPH-DWIDTH GLYPH))))) - (MAKE-GL-LIMITS :WIDTH GWIDTH :ASCENT ASCENT :DESCENT DESCENT))) - -(DEFUN GLYPHS-BY-CHARSET (FONT &OPTIONAL MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING) - (IL:* IL:\; "Edited 5-Feb-2025 12:53 by mth") - (IL:* IL:\; "Edited 3-Feb-2025 23:00 by mth") - (IL:* IL:\; "Edited 2-Feb-2025 20:29 by mth") - (IL:* IL:\; "Edited 28-Jan-2025 23:09 by mth") - (IL:* IL:\; "Edited 27-Jan-2025 17:22 by mth") - (IL:* IL:\; "Edited 23-Jan-2025 17:58 by mth") - (IL:* IL:\; "Edited 9-Jan-2025 11:23 by mth") - (LET* ((NCSETS (+ MAXCHARSET 2)) - (CSETS (MAKE-ARRAY NCSETS :INITIAL-CONTENTS (LOOP :REPEAT NCSETS :COLLECT (CONS NIL)))) - (UTOXFN (COND - (RAW-UNICODE-MAPPING #'IDENTITY) - (MAP-UNKNOWN-TO-PRIVATE #'UTOXCODE) - (T #'UTOXCODE?))) - NOMAPPINGCSETS ENC XCODE CS XCS) - (UNLESS (OR MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING) - (SETQ NOMAPPINGCSETS (MAKE-ARRAY NCSETS :INITIAL-CONTENTS (LOOP :REPEAT NCSETS :COLLECT - (CONS NIL))))) - (FLET ((PUT-GLYPH-IN-CHARSET-ARRAY (CODE GLYPH CSARRAY) - (TCONC (AREF CSARRAY (LRSH CODE 8)) - (CONS (LOGAND CODE 255) - GLYPH)))) - (LOOP :FOR GL :IN (BF-GLYPHS FONT) - :DO - (SETQ XCS NIL) - (SETQ ENC (GLYPH-ENCODING GL)) - (SETQ XCODE (FUNCALL UTOXFN ENC)) - (IF RAW-UNICODE-MAPPING - (COND - ((> ENC 65535) - (WARN "~&Unicode encoding is beyond 16 bits: ~5X" ENC) - (TCONC (AREF CSETS NOMAPPINGCHARSET) - (CONS ENC GL))) - ((AND NIL (= 255 (LOGAND ENC 255))) - - (IL:* IL:|;;| - "Temporarily? disable this warning in RAW-UNICODE-MAPPING mode") - - (WARN - "~&Unicode encoding char byte (~2X,FF)=(~O,377) may not =FF in FONTDESCRIPTOR" - (LRSH ENC 8) - (LRSH ENC 8)) - (TCONC (AREF CSETS NOMAPPINGCHARSET) - (CONS ENC GL))) - (T (PUT-GLYPH-IN-CHARSET-ARRAY ENC GL CSETS))) - (COND - ((NULL XCODE) - - (IL:* IL:|;;| "These assoc with the Unicode encoding") - - (COND - ((OR (> ENC 65535) - (= 255 (LOGAND ENC 255))) - - (IL:* IL:|;;| - "Unicode encoding is > xFFFF, or encoding low byte is FF, put it in the NOMAPPINGCHARSET") - - (TCONC (AREF CSETS NOMAPPINGCHARSET) - (CONS ENC GL))) - (T (PUT-GLYPH-IN-CHARSET-ARRAY ENC GL NOMAPPINGCSETS)))) - ((AND (INTEGERP XCODE) - (<= 0 XCODE 65535)) - - (IL:* IL:|;;| - "These assoc with the 8 bit character code within the charset") - - (PUT-GLYPH-IN-CHARSET-ARRAY XCODE GL CSETS)) - ((LISTP XCODE) - - (IL:* IL:|;;| - "These assoc with the 8 bit character code within the charset (like above)") - - (LOOP :FOR XC :IN XCODE :UNLESS (MEMBER (SETQ CS (LRSH XC 8)) - XCS) - :DO - (PUSH CS XCS) - (PUT-GLYPH-IN-CHARSET-ARRAY XC GL CSETS))) - (T (ERROR "Invalid XCODE: ~A~%")))))) - - (IL:* IL:|;;| "Extract the lists from the TCONC pointers") - - (LOOP :FOR I :FROM 0 :TO NOMAPPINGCHARSET :DO (SETF (AREF CSETS I) - (SORT (REMOVE-DUPLICATES - (CAR (AREF CSETS I)) - :TEST - #'EQUAL) - #'< :KEY #'CAR))) - (SETQ CSETS (LOOP :FOR I :FROM 0 :TO NOMAPPINGCHARSET :NCONC - (LET ((CS (AREF CSETS I))) - (WHEN CS - (LIST (LIST I CS)))))) - - (IL:* IL:|;;| "Likewise for the NOMAPPINGCSETS, if any.") - - (WHEN NOMAPPINGCSETS - (LOOP :FOR I :FROM 0 :TO NOMAPPINGCHARSET :DO - (SETF (AREF NOMAPPINGCSETS I) - (SORT (REMOVE-DUPLICATES (CAR (AREF NOMAPPINGCSETS I)) - :TEST - #'EQUAL) - #'< :KEY #'CAR))) - (SETQ NOMAPPINGCSETS (LOOP :FOR I :FROM 0 :TO NOMAPPINGCHARSET :NCONC - (LET ((CS (AREF NOMAPPINGCSETS I))) - (WHEN CS - (LIST (LIST I CS))))))) - (LIST CSETS NOMAPPINGCSETS))) - -(DEFUN SPLIT-FONT-NAME (NAME) (IL:* IL:\; "Edited 31-Jan-2025 22:20 by mth") - (LOOP :FOR I = (IF (CHAR= #\- (ELT NAME 0)) - 1 - 0) - THEN - (1+ J) - :AS J = (POSITION #\- NAME :START I :TEST #'CHAR=) - :COLLECT - (SUBSEQ NAME I J) - :WHILE J)) - -(DEFUN WRITE-BDF-TO-DISPLAYFONT-FILES (BDFONT DEST-DIR &OPTIONAL MAP-UNKNOWN-TO-PRIVATE - RAW-UNICODE-MAPPING FAMILY SIZE FACE ROTATION DEVICE) - (IL:* IL:\; "Edited 5-Feb-2025 15:05 by mth") +(DEFUN SPLIT-FONT-NAME (NAME) (IL:* IL:\; "Edited 23-Apr-2025 16:22 by mth") + (IL:* IL:\; "Edited 31-Jan-2025 22:20 by mth") + + (IL:* IL:|;;| "First, check if it COULD be in XLFD format") + + (COND + ((POSITION #\- NAME :TEST #'CHAR=) + (LOOP :FOR I = (IF (CHAR= #\- (ELT NAME 0)) + 1 + 0) + THEN + (1+ J) + :AS J = (POSITION #\- NAME :START I :TEST #'CHAR=) + :COLLECT + (SUBSEQ NAME I J) + :WHILE J)) + (T + (IL:* IL:|;;| "Return the NAME as FAMILY with a NIL FOUNDRY") + + (LIST NIL NAME)))) + +(DEFUN WRITE-BDF-TO-DISPLAYFONT-FILES (BDFONT DEST-DIR &KEY FAMILY SIZE FACE ROTATION DEVICE + (CHAR-SETS T) + MAP-UNKNOWN-TO-PRIVATE WRITE-UNMAPPED + RAW-UNICODE-MAPPING) + (IL:* IL:\; "Edited 25-Apr-2025 10:08 by mth") + (IL:* IL:\; "Edited 24-Apr-2025 00:09 by mth") + (IL:* IL:\; "Edited 21-Apr-2025 16:03 by mth") (IL:* IL:\; "Edited 3-Feb-2025 23:18 by mth") (UNLESS (TYPEP BDFONT 'BDF-FONT) (ERROR "Not a BDF-FONT: ~S~%" BDFONT)) + (COND + ((EQ CHAR-SETS T) (IL:* IL:\; "This means ALL charsets") + ) + ((NULL CHAR-SETS) + (SETQ CHAR-SETS '(0)) (IL:* IL:\; "Only charset 0") + ) + ((AND (INTEGERP CHAR-SETS) + (<= 0 CHAR-SETS MAXCHARSET)) (IL:* IL:\; "A single integer charset") + (SETQ CHAR-SETS (LIST CHAR-SETS))) + ((AND (LISTP CHAR-SETS) + (EVERY #'(LAMBDA (CS) + (AND (INTEGERP CS) + (<= 0 CS MAXCHARSET))) + CHAR-SETS))) + (T (ERROR "Invalid specification of :CHAR-SETS ~S~%" CHAR-SETS))) (DESTRUCTURING-BIND (FN-FAMILY FN-FACE FN-SIZE) (GET-FAMILY-FACE-SIZE-FROM-NAME BDFONT) (SETQ FAMILY (OR FAMILY FN-FAMILY)) @@ -683,17 +774,29 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST (MULTIPLE-VALUE-BIND (FONTDESC CSETS UNMAPPED-FONTDESC UNICODE-CSETS UNMAPPEDGLYPHS) (BDF-TO-FONTDESCRIPTOR BDFONT FAMILY SIZE FACE ROTATION DEVICE MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING) + (UNLESS (EQ CHAR-SETS T) + (SETQ CSETS (INTERSECTION CHAR-SETS CSETS)) + (SETQ UNICODE-CSETS (INTERSECTION CHAR-SETS UNICODE-CSETS))) (LOOP :FOR CS :IN CSETS :DO (WRITESTRIKEFONTFILE FONTDESC CS (PACKFILENAME.STRING :BODY DEST-DIR :NAME (\\FONTFILENAME FAMILY SIZE FACE "DISPLAYFONT" CS)))) - (LOOP :FOR CS :IN UNICODE-CSETS :DO (WRITESTRIKEFONTFILE - UNMAPPED-FONTDESC CS - (PACKFILENAME.STRING :BODY DEST-DIR :NAME - (\\FONTFILENAME (FONTPROP - UNMAPPED-FONTDESC - 'IL:FAMILY) - SIZE FACE "DISPLAYFONT" CS)))) + (IF WRITE-UNMAPPED + (LOOP :FOR CS :IN UNICODE-CSETS :DO (WRITESTRIKEFONTFILE + UNMAPPED-FONTDESC CS + (PACKFILENAME.STRING + :BODY DEST-DIR :NAME + (\\FONTFILENAME (FONTPROP + UNMAPPED-FONTDESC + 'IL:FAMILY) + SIZE FACE "DISPLAYFONT" CS)))) + (SETQ UNICODE-CSETS NIL)) + + (IL:* IL:|;;| "These correspond to the charsets ACTUALLY written.") + + (IL:* IL:|;;| + "UNMAPPEDGLYPHS are never written. (Unicode encoding is > xFFFF, or encoding low byte is FF)") + (VALUES FONTDESC CSETS UNMAPPED-FONTDESC UNICODE-CSETS UNMAPPEDGLYPHS)))) (IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY @@ -719,11 +822,10 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST (IL:PUTPROPS IL:READ-BDF IL:DATABASE IL:NO) (IL:DECLARE\: IL:DONTCOPY - (IL:FILEMAP (NIL (2291 3912 (FIXUP-CHARSETINFO 2291 . 3912)) (3914 6946 ( -GET-FAMILY-FACE-SIZE-FROM-NAME 3914 . 6946)) (6948 8373 (PACKFILENAME.STRING 6948 . 8373)) (8375 14009 - (READ-BDF 8375 . 14009)) (14011 14334 (READ-DELIMITED-LIST-FROM-STRING 14011 . 14334)) (14336 20558 ( -READ-GLYPH 14336 . 20558)) (20560 25963 (BDF-TO-CHARSETINFO 20560 . 25963)) (25965 32055 ( -BDF-TO-FONTDESCRIPTOR 25965 . 32055)) (32057 32654 (GET-GLYPH-LIMITS 32057 . 32654)) (32656 38670 ( -GLYPHS-BY-CHARSET 32656 . 38670)) (38672 39035 (SPLIT-FONT-NAME 38672 . 39035)) (39037 41216 ( -WRITE-BDF-TO-DISPLAYFONT-FILES 39037 . 41216))))) + (IL:FILEMAP (NIL (2427 10386 (BDF-TO-CHARSETINFO 2427 . 10386)) (10388 16258 (BDF-TO-FONTDESCRIPTOR +10388 . 16258)) (16260 19623 (GET-FAMILY-FACE-SIZE-FROM-NAME 16260 . 19623)) (19625 26436 ( +GLYPHS-BY-CHARSET 19625 . 26436)) (26438 27863 (PACKFILENAME.STRING 26438 . 27863)) (27865 34669 ( +READ-BDF 27865 . 34669)) (34671 34994 (READ-DELIMITED-LIST-FROM-STRING 34671 . 34994)) (34996 41484 ( +READ-GLYPH 34996 . 41484)) (41486 42227 (SPLIT-FONT-NAME 41486 . 42227)) (42229 46011 ( +WRITE-BDF-TO-DISPLAYFONT-FILES 42229 . 46011))))) IL:STOP diff --git a/lispusers/READ-BDF.DFASL b/lispusers/READ-BDF.DFASL index 87b9e2076..631844166 100644 Binary files a/lispusers/READ-BDF.DFASL and b/lispusers/READ-BDF.DFASL differ diff --git a/lispusers/READ-BDF.TEDIT b/lispusers/READ-BDF.TEDIT index 50e3c235f..9ecae0f36 100644 Binary files a/lispusers/READ-BDF.TEDIT and b/lispusers/READ-BDF.TEDIT differ