diff --git a/lispusers/READ-BDF b/lispusers/READ-BDF index a4c28123e..3a1d3bdfa 100644 --- a/lispusers/READ-BDF +++ b/lispusers/READ-BDF @@ -1,30 +1,30 @@ -(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "BDF" (USE "XCL" "LISP") (EXPORT "READ-BDF" -"WRITE-BDF-TO-DISPLAYFONT-FILES") (IMPORT-FROM "IL" "BITBLT" "BITMAPCREATE" "BITMAPHEIGHT" -"BITMAPWIDTH" "BLACKSHADE" "BLTSHADE" "BOLD" "COMPRESSED" "CHARSETINFO" "DISPLAY" "FONTDESCRIPTOR" -"FONTP" "FONTPROP" "INPUT" "ITALIC" "LIGHT" "LRSH" "MEDIUM" "REGULAR" "TCONC" "UTOMCODE" "UTOMCODE?" -"WRITESTRIKEFONTFILE")) READTABLE "XCL" BASE 10) +(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "BDF" (USE "XCL" "LISP") (EXPORT "READ-BDF" "BUILD-COMPOSITE" + "WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE") (IMPORT-FROM "IL" "BITBLT" "BITMAPBIT" "BITMAPCREATE" +"BITMAPHEIGHT" "BITMAPWIDTH" "BLACKSHADE" "BLTSHADE" "BOLD" "COMPRESSED" "CHARSETINFO" "CHARSETPROP" +"DISPLAY" "FONTDESCRIPTOR" "FONTP" "FONTPROP" "INPUT" "ITALIC" "LIGHT" "LRSH" "MCCS" "MEDIUM" +"REGULAR" "TCONC" "UTOMCODE?" "MEDLEYFONT.FILENAME" "MEDLEYFONT.WRITE.FONT")) READTABLE "XCL" BASE +10) -(IL:FILECREATED " 6-Nov-2025 23:10:51" IL:|{DSK}matt>Interlisp>medley>lispusers>READ-BDF.;13| 49101 +(IL:FILECREATED " 8-Dec-2025 12:13:40" IL:|{DSK}matt>Interlisp>medley>lispusers>READ-BDF.;9| 51309 :EDIT-BY "mth" - :CHANGES-TO (IL:FUNCTIONS BDF-TO-FONTDESCRIPTOR BDF-TO-CHARSETINFO READ-GLYPH - WRITE-BDF-TO-DISPLAYFONT-FILES) + :CHANGES-TO (IL:FUNCTIONS BDF-TO-CHARSETINFO BDF-TO-FONTDESCRIPTOR) (FILE-ENVIRONMENTS "READ-BDF") - (IL:VARS IL:READ-BDFCOMS) - :PREVIOUS-DATE " 6-Nov-2025 22:43:21" IL:|{DSK}matt>Interlisp>medley>lispusers>READ-BDF.;9| + :PREVIOUS-DATE " 8-Dec-2025 12:12:47" IL:|{DSK}matt>Interlisp>medley>lispusers>READ-BDF.;8| ) (IL:PRETTYCOMPRINT IL:READ-BDFCOMS) (IL:RPAQQ IL:READ-BDFCOMS - ((IL:STRUCTURES BDF-FONT GLYPH) + ((IL:STRUCTURES BDF-FONT GLYPH XLFD) (IL:VARIABLES MAXCHARSET MAXTHINCHAR NOMAPPINGCHARSET) - (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:FUNCTIONS BDF-TO-CHARSETINFO BDF-TO-FONTDESCRIPTOR BUILD-COMPOSITE CHAR-PRESENT-BIT + COUNT-MCHARS GLYPHS-BY-CHARSET PACKFILENAME.STRING READ-BDF + READ-DELIMITED-LIST-FROM-STRING READ-GLYPH WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE + XLFD-SPLIT-FONT-NAME XLFD-TO-FACE) (IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY (IL:FILES (IL:SYSLOAD) IL:SYSEDIT) (IL:FILES (IL:LOADCOMP) @@ -41,7 +41,9 @@ (METRICSSET 0 :TYPE (INTEGER 0 2)) (PROPERTIES NIL :TYPE LIST) SWIDTH DWIDTH SWIDTH1 DWIDTH1 VVECTOR (GLYPHS NIL :TYPE LIST) - (SLUG NIL :TYPE GLYPH)) + (UNMAPPED¬GLYPHS NIL :TYPE LIST) + (XLFD NIL :TYPE XLFD) + (MCHAR-PRESENT NIL :TYPE IL:BITMAP)) (DEFSTRUCT GLYPH "This is an individual BDF glyph. Includes some values calculated for creating CHARSETINFO" @@ -52,85 +54,95 @@ (ASCENT 0 :TYPE INTEGER) (DESCENT 0 :TYPE INTEGER)) +(DEFSTRUCT XLFD + "Hold a parsed XLFD font descriptor" + (FOUNDRY NIL :TYPE STRING) + (FAMILY NIL :TYPE STRING) + (WEIGHT NIL :TYPE STRING) + (SLANT NIL :TYPE STRING) + (SETWIDTH¬NAME NIL :TYPE STRING) + (ADD¬STYLE¬NAME NIL :TYPE STRING) + (PIXEL¬SIZE 0 :TYPE INTEGER) + (POINT¬SIZE 0 :TYPE INTEGER) + (RESOLUTION¬X 0 :TYPE INTEGER) + (RESOLUTION¬Y 0 :TYPE INTEGER) + (SPACING NIL :TYPE STRING) + (AVERAGE¬WIDTH 0 :TYPE INTEGER) + (CHARSET¬REGISTRY NIL :TYPE STRING) + (CHARSET¬ENCODING NIL :TYPE STRING)) + (DEFCONSTANT MAXCHARSET 255) (DEFCONSTANT MAXTHINCHAR 255) (DEFCONSTANT NOMAPPINGCHARSET (1+ MAXCHARSET)) -(DEFUN BDF-TO-CHARSETINFO (FONT CSET SLUG-OR-WIDTH &OPTIONAL MAP-UNKNOWN-TO-PRIVATE) +(DEFUN BDF-TO-CHARSETINFO (FONT CSET SLUGWIDTH) (IL:* IL:\; "Edited 8-Dec-2025 12:13 by mth") + (IL:* IL:\; "Edited 30-Nov-2025 00:12 by mth") + (IL:* IL:\; "Edited 28-Nov-2025 16:37 by mth") + (IL:* IL:\; "Edited 26-Nov-2025 21:18 by mth") + (IL:* IL:\; "Edited 20-Nov-2025 12:19 by mth") + (IL:* IL:\; "Edited 15-Nov-2025 14:26 by mth") (IL:* IL:\; "Edited 6-Nov-2025 17:30 by mth") (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) + (LET (GBCS CSGLYPHS CSLIMITS SW) (UNLESS (AND (INTEGERP CSET) (<= 0 CSET MAXCHARSET)) (ERROR "Invalid Character set: ~S" CSET) - (IL:* IL:|;;| "Can we get here? I think not!") + (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)))) + (COND + ((LISTP FONT) + + (IL:* IL:|;;| + "Assuming that FONT is already the LIST of ALIST form of result from GLYPHS-BY-CHARSET") + + (SETQ GBCS FONT)) + ((BDF-FONT-P FONT) + + (IL:* IL:|;;| "If passed a BDF-FONT, look only at glyphs in the mapped charsets") + + (DESTRUCTURING-SETQ (GBCS SW) + (GLYPHS-BY-CHARSET FONT))) + (T (ERROR "Invalid FONT: ~S" FONT))) + (UNLESS (AND (INTEGERP SLUGWIDTH) + (PLUSP SLUGWIDTH)) + (IF (AND (INTEGERP SW) + (PLUSP SW)) + (SETQ SLUGWIDTH SW) + (ERROR "Invalid SLUGWIDTH: ~D" SLUGWIDTH))) (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)) + (CSINFO (IL:|create| CHARSETINFO + IL:CHARSETNO IL:_ CSET)) + (IMAGEWIDTHS (IL:\\CREATECSINFOELEMENT)) (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* ((MCODE (CAR XGL)) - (GL (CDR XGL)) - (GWIDTH (GLYPH-WIDTH - GL)) - (ASC (GLYPH-ASCENT GL)) - (DSC (GLYPH-DESCENT - GL))) + GLYPHS-LIMITS BMAP OFFSETS HEIGHT WIDTHS) + (CHARSETPROP CSINFO 'IL:CSCHARENCODING 'MCCS) + (LOOP :FOR XGL :IN CSGLYPHS :DO (LET* ((MCODE (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-MCODE GL) - MCODE) - (SETQ FIRSTCHAR - (MIN FIRSTCHAR MCODE - )) - (SETQ LASTCHAR - (MAX LASTCHAR MCODE) - ) - (INCF TOTAL-WIDTH GWIDTH) - (SETQ ASCENT - (MAX ASCENT ASC)) - (SETQ DESCENT - (MAX DESCENT DSC)) - GL))) + (IL:* IL:|;;| + "Is the above statement actually true?") + + (SETQ FIRSTCHAR (MIN FIRSTCHAR MCODE)) + (SETQ LASTCHAR (MAX LASTCHAR MCODE)) + (INCF TOTAL-WIDTH GWIDTH) + (SETQ ASCENT (MAX ASCENT ASC)) + (SETQ DESCENT (MAX DESCENT DSC)))) (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)) @@ -140,13 +152,17 @@ (IL:|for| I IL:|from| 0 IL:|to| (+ MAXTHINCHAR 2) IL:|do| (IL:\\FSETOFFSET OFFSETS I TOTAL-WIDTH)) + + (IL:* IL:|;;| "Now WIDTHS is NOT the IMAGEWIDTHS array. BDF provides both, and MEDLEYDISPLAYFONT can persist both.") + (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| (IL:\\FSETWIDTH WIDTHS I + (IL:|for| I IL:|from| 0 IL:|to| (+ MAXTHINCHAR 2) IL:|do| (IL:\\FSETWIDTH + IMAGEWIDTHS I SLUGWIDTH)) - (IL:|replace| (CHARSETINFO IL:IMAGEWIDTHS) IL:|of| CSINFO IL:|with| WIDTHS) + (IL:|replace| (CHARSETINFO IL:IMAGEWIDTHS) IL:|of| CSINFO IL:|with| IMAGEWIDTHS) (IL:* IL:|;;| "JDS 12/4/92: Apparently, these fields can be signed values, if all chars, e.g., ride above the base line. ") @@ -156,338 +172,284 @@ (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 MCODE :DO (SETQ GLBM - (GLYPH-BITMAP - GL)) + (LOOP :FOR XGL :IN CSGLYPHS :WITH GL :WITH GLBM :WITH GLW :WITH MCODE :DO + (SETQ MCODE (CAR XGL)) + (SETQ GL (CDR XGL)) + (SETQ GLBM (GLYPH-BITMAP GL)) (SETQ GLW (GLYPH-WIDTH GL)) - (SETQ MCODE (GLYPH-MCODE GL)) - (BITBLT GLBM 0 0 BMAP (+ DLEFT (MAX 0 (GLYPH-BBXOFF0 GL))) - (+ DESCENT (GLYPH-BBYOFF0 GL)) - (BITMAPWIDTH GLBM) - (BITMAPHEIGHT GLBM) - 'INPUT - 'IL:REPLACE) + (WHEN GLBM + + (IL:* IL:|;;| "Empty bitmap, nothing to copy.") + + (BITBLT GLBM 0 0 BMAP (+ DLEFT (MAX 0 (GLYPH-BBXOFF0 GL))) + (+ DESCENT (GLYPH-BBYOFF0 GL)) + (BITMAPWIDTH GLBM) + (BITMAPHEIGHT GLBM) + 'INPUT + 'IL:REPLACE)) (IL:\\FSETOFFSET OFFSETS MCODE DLEFT) - (IL:\\FSETOFFSET WIDTHS MCODE GLW) + (IL:\\FSETOFFSET IMAGEWIDTHS MCODE GLW) + (IL:\\FSETOFFSET WIDTHS MCODE (FIRST (GLYPH-DWIDTH GL))) (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)) + (IL:* IL:|;;| "Now make a slug (block)") + + (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) +(DEFUN BDF-TO-FONTDESCRIPTOR (BDFONT FAMILY SIZE FACE ROTATION DEVICE) + (IL:* IL:\; "Edited 8-Dec-2025 12:11 by mth") + (IL:* IL:\; "Edited 2-Dec-2025 16:10 by mth") + (IL:* IL:\; "Edited 30-Nov-2025 15:59 by mth") + (IL:* IL:\; "Edited 28-Nov-2025 18:03 by mth") + (IL:* IL:\; "Edited 20-Nov-2025 12:46 by mth") (IL:* IL:\; "Edited 5-Nov-2025 16:09 by mth") (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) - - (IL:* IL:|;;| "Assume this is a FONTSPEC") - - (RETURN (BDF-TO-FONTDESCRIPTOR BDFONT (IL:|fetch| (IL:FONTSPEC IL:FSFAMILY) - IL:|of| FAMILY) - (OR (IL:|fetch| (IL:FONTSPEC IL:FSSIZE) IL:|of| FAMILY) - SIZE) - (OR (IL:|fetch| (IL:FONTSPEC IL:FSFACE) IL:|of| FAMILY) - FACE "MRR") - (OR (IL:|fetch| (IL:FONTSPEC IL:FSROTATION) IL:|of| FAMILY) - ROTATION 0) - (OR (IL:|fetch| (IL:FONTSPEC IL:FSDEVICE) IL:|of| FAMILY) - DEVICE - 'DISPLAY) - MAP-UNKNOWN-TO-PRIVATE))) - (SETQ FAMILY (IL:\\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:|;;| + + (IL:* IL:|;;| "Check valid required argument") + + (WHEN (BDF-FONT-P BDFONT) + (WHEN (FONTP FAMILY) + (RETURN-FROM BDF-TO-FONTDESCRIPTOR (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))))) + (WHEN (CONSP FAMILY) (IL:* IL:\; + "Because (LISTP NIL) == T !!!") + + (IL:* IL:|;;| "Assume this is a FONTSPEC.") + + (RETURN-FROM BDF-TO-FONTDESCRIPTOR (BDF-TO-FONTDESCRIPTOR BDFONT (IL:|fetch| (IL:FONTSPEC + IL:FSFAMILY) + IL:|of| FAMILY) + (OR SIZE (IL:|fetch| (IL:FONTSPEC IL:FSSIZE) + IL:|of| FAMILY)) + (OR FACE (IL:|fetch| (IL:FONTSPEC IL:FSFACE) + IL:|of| FAMILY) + 'IL:MRR) + (OR ROTATION (IL:|fetch| (IL:FONTSPEC + IL:FSROTATION) + IL:|of| FAMILY) + 0) + (OR DEVICE (IL:|fetch| (IL:FONTSPEC IL:FSDEVICE) + IL:|of| FAMILY) + 'DISPLAY)))) + (LET ((XLFD (BF-XLFD BDFONT)) + FONTDESC GBCSL CHARSETS SLUGWIDTH) + (SETQ FAMILY (IL:\\FONTSYMBOL (OR FAMILY (XLFD-FAMILY XLFD)))) + (SETQ FACE (OR FACE (XLFD-TO-FACE XLFD))) + (SETQ SIZE (OR SIZE (AND (>= (XLFD-PIXEL¬SIZE XLFD) + 0) + (XLFD-PIXEL¬SIZE XLFD)) + (AND (>= (XLFD-POINT¬SIZE XLFD) + 0) + (CEILING (XLFD-POINT¬SIZE XLFD) + 10)) + (FIRST (BF-SIZE BDFONT)))) + (COND + ((NULL ROTATION) + (SETQ ROTATION 0)) + ((NOT (AND (IL:SMALLP ROTATION) + (>= ROTATION 0))) + (IL:\\ILLEGAL.ARG ROTATION))) + (SETQ DEVICE (COND + ((OR (NULL DEVICE) + (EQ DEVICE T)) + 'DISPLAY) + ((SYMBOLP DEVICE) + + (IL:* IL:|;;| + "This PROBABLY isn't a good assumption... BUT it's a very unlikely case.") + + (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 (IL:\\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 - )))) - (IL:\\INSTALLCHARSETINFO FONTDESC CSINFO CSET - ) - (LIST CSET))))) - (LIST FONTDESC CHARSETS)))) - (RETURN (VALUES-LIST (NCONC (GBCS-TO-FONTDESC (FIRST GBCSL) - FAMILY) - (GBCS-TO-FONTDESC (SECOND GBCSL) - (IL:\\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 30-Apr-2025 13:18 by mth") - (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)) - (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 (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 (AND SLANT (CDR (ASSOC (CHAR-UPCASE (ELT SLANT 0)) - '((REGULAR) - (#\R . REGULAR) - (#\I . ITALIC) - (#\O . ITALIC))))) - 'REGULAR)) (IL:* IL:\; "Oblique => ITALIC") - (IL:* IL:\; "Ignore others") - (SETQ EXPANSION (OR (AND EXPANSION (CDR (ASSOC (CHAR-UPCASE (ELT EXPANSION 0)) - '((#\R . REGULAR) - (#\N . REGULAR) - (#\B . BOLD) - (#\S . COMPRESSED) - (#\C . COMPRESSED))))) - 'REGULAR)) (IL:* IL:\; - "S is for \"SemiCondensed\", Assuming \"Condensed\"") - - (IL:* IL:|;;| - "Now check for WEIGHT and EXPANSION both BOLD. If so, change Expansion to REGULAR") - - (WHEN (AND (EQ WEIGHT EXPANSION) - (EQ EXPANSION 'BOLD)) - (SETQ EXPANSION 'REGULAR)) - (WHEN (ZEROP (LENGTH PIXEL-SIZE)) - (SETQ PIXEL-SIZE NIL)) - (SETQ POINT-SIZE (COND - ((ZEROP (LENGTH POINT-SIZE)) - NIL) - ((SETQ POINT-SIZE (PARSE-INTEGER POINT-SIZE :JUNK-ALLOWED T)) - (CEILING POINT-SIZE 10)) - (T NIL))) - (LIST FAMILY (LIST WEIGHT SLANT EXPANSION) - (OR (AND PIXEL-SIZE (PARSE-INTEGER PIXEL-SIZE :JUNK-ALLOWED T)) - POINT-SIZE - (FIRST (BF-SIZE BDFONT)))))) - -(DEFUN GLYPHS-BY-CHARSET (FONT &OPTIONAL MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING) + DEVICE) + ((STRINGP DEVICE) + (INTERN (STRING-UPCASE DEVICE) + "IL")) + (T (IL:\\ILLEGAL.ARG DEVICE)))) + (SETQ FACE (IL:\\FONTFACE (OR FACE (XLFD-TO-FACE XLFD) + 'IL:MRR) + NIL DEVICE)) + (DESTRUCTURING-SETQ (GBCSL SLUGWIDTH) + (GLYPHS-BY-CHARSET BDFONT)) + (UNLESS SLUGWIDTH + + (IL:* IL:|;;| + "If GLYPHS-BY-CHARSET didn't determine the SLUGWIDTH, use 60% of the SIZE, at least 1") + + (SETQ SLUGWIDTH (MAX 1 (ROUND (* 0.6 SIZE))))) + (WHEN GBCSL + (SETQ FONTDESC + (IL:|create| FONTDESCRIPTOR + IL:FONTDEVICE IL:_ DEVICE + 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 DEVICE) + IL:FONTSLUGWIDTH IL:_ SLUGWIDTH + IL:FONTCHARENCODING IL:_ 'MCCS)) + (SETQ CHARSETS (LOOP :FOR CS :IN GBCSL :WITH CSET :WITH CSINFO :NCONC + (WHEN (<= 0 (SETQ CSET (FIRST CS)) + MAXCHARSET) + (SETQ CSINFO (BDF-TO-CHARSETINFO GBCSL CSET (1+ SLUGWIDTH))) + (IL:\\INSTALLCHARSETINFO FONTDESC CSINFO CSET) + (LIST CSET))))) + (LIST FONTDESC CHARSETS)))) + +(DEFUN BUILD-COMPOSITE (FONTS &KEY VERBOSE) (IL:* IL:\; "Edited 1-Dec-2025 23:07 by mth") + (IL:* IL:\; "Edited 30-Nov-2025 12:32 by mth") + (IL:* IL:\; "Edited 26-Nov-2025 21:23 by mth") + (IL:* IL:\; "Edited 18-Nov-2025 21:22 by mth") + (IL:* IL:\; "Edited 16-Nov-2025 18:25 by mth") + (IL:* IL:\; "Edited 14-Nov-2025 17:04 by mth") + (LET* ((BASE-FONT (FIRST (SETQ FONTS (IL:MKLIST FONTS)))) + (FILL-FROM (REST FONTS)) + MCHAR-PRESENT CHAR-COUNT FONT) + (COND + ((OR (STRINGP BASE-FONT) + (PATHNAMEP BASE-FONT)) + (UNLESS (IL:INFILEP BASE-FONT) + (ERROR "Initial font file ~S doesn't exist or is unreadable." (NAMESTRING BASE-FONT) + )) + (WHEN VERBOSE + (FORMAT *STANDARD-OUTPUT* "~&Loading initial font file: ~A~%" (NAMESTRING BASE-FONT) + )) + (SETQ BASE-FONT (READ-BDF BASE-FONT :MCCS-ONLY T :VERBOSE VERBOSE))) + ((NOT (BDF-FONT-P BASE-FONT)) + (ERROR "Initial font (~S) is not a BDF-FONT, nor string, nor pathname." BASE-FONT))) + (WHEN VERBOSE + (FORMAT *STANDARD-OUTPUT* "~&Initial font contains ~D MCCS characters.~%" + (SETQ CHAR-COUNT (COUNT-MCHARS BASE-FONT)))) + (SETQ MCHAR-PRESENT (BF-MCHAR-PRESENT BASE-FONT)) + (LOOP :FOR FILL-FONT :IN FILL-FROM :WITH PREV-CC :WHEN FILL-FONT :DO + (COND + ((OR (STRINGP FILL-FONT) + (PATHNAMEP FILL-FONT)) + (UNLESS (IL:INFILEP FILL-FONT) + (ERROR "Subsequent font ~S doesn't exist or is unreadable." (NAMESTRING + FILL-FONT))) + (WHEN VERBOSE + (FORMAT *STANDARD-OUTPUT* "~&Loading subsequent font file: ~A~%" (NAMESTRING + FILL-FONT))) + (SETQ FILL-FONT (READ-BDF FILL-FONT :MCCS-ONLY T :VERBOSE VERBOSE))) + ((NOT (BDF-FONT-P FILL-FONT)) + (ERROR "Subsequent font (~S) is not a BDF-FONT, nor string, nor pathname." + FILL-FONT))) + (SETQ PREV-CC CHAR-COUNT) + (LOOP :FOR GL :IN (BF-GLYPHS FILL-FONT) + :WITH V :DO (SETQ V (GLYPH-ENCODING GL)) + (WHEN (AND (LISTP V) + (EQ (FIRST V) + -1)) + (SETQ V (OR (SECOND V) + -1))) + + (IL:* IL:|;;| + "Need to change this use of UTOMCODE? based on the CHARSET¬REGISTRY of the XLFD of FILL-FONT") + + (WHEN (AND (UTOMCODE? V) + (ZEROP (CHAR-PRESENT-BIT MCHAR-PRESENT V))) + (CHAR-PRESENT-BIT MCHAR-PRESENT V 1) + + (IL:* IL:|;;| + "What other bookkeping of BASE-FONT needs to be done when adding a glyph? Any?") + + (PUSH GL (BF-GLYPHS BASE-FONT)))) + (SETQ CHAR-COUNT (COUNT-MCHARS BASE-FONT)) + (WHEN VERBOSE + (FORMAT *STANDARD-OUTPUT* "~&Font ~A supplied ~D additional MCCS characters.~%" + (NAMESTRING FILL-FONT) + (- (SETQ CHAR-COUNT (COUNT-MCHARS BASE-FONT)) + PREV-CC)))) + BASE-FONT)) + +(DEFUN CHAR-PRESENT-BIT (BM MCODE &OPTIONAL (NEWBIT -1 SBIT) + &AUX CS CC) (IL:* IL:\; "Edited 26-Nov-2025 09:29 by mth") + (COND + ((NOT (TYPEP BM 'IL:BITMAP)) + (ERROR "BM is not a BITMAP")) + ((NOT (AND (INTEGERP MCODE) + (<= 0 MCODE 65535))) + (ERROR "Invalid MCODE")) + (SBIT (COND + ((OR (EQL NEWBIT 1) + (EQ NEWBIT T)) + (SETQ NEWBIT 1)) + ((OR (EQL NEWBIT 0) + (NULL NEWBIT)) + (SETQ NEWBIT 0)) + (T (ERROR "Invalid NEWBIT"))))) + (LET ((CS (- 255 (LRSH MCODE 8))) + (CC (LOGAND MCODE 255))) + (BITMAPBIT BM CC CS (AND SBIT NEWBIT)))) + +(DEFUN COUNT-MCHARS (BDFONT) (IL:* IL:\; "Edited 29-Nov-2025 23:52 by mth") + (WHEN (BDF-FONT-P BDFONT) + (LET ((MCPBM (BF-MCHAR-PRESENT BDFONT))) + (LOOP :FOR MC :FROM 0 :TO 65535 :COUNT (PLUSP (CHAR-PRESENT-BIT MCPBM MC)))))) + +(DEFUN GLYPHS-BY-CHARSET (FONT) (IL:* IL:\; "Edited 30-Nov-2025 17:36 by mth") + (IL:* IL:\; "Edited 28-Nov-2025 17:24 by mth") + (IL:* IL:\; "Edited 26-Nov-2025 20:50 by mth") + (IL:* IL:\; "Edited 20-Nov-2025 12:01 by mth") (IL:* IL:\; "Edited 6-Nov-2025 18:11 by mth") (IL:* IL:\; "Edited 5-Nov-2025 16:18 by mth") (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)))) - (UTOMFN (COND - (RAW-UNICODE-MAPPING #'IDENTITY) - (MAP-UNKNOWN-TO-PRIVATE #'UTOMCODE) - (T #'UTOMCODE?))) - (SLUG (BF-SLUG FONT)) - (SLUGWIDTH (AND SLUG (GLYPH-WIDTH SLUG))) - NOMAPPINGCSETS ENC MCODE MCS) - (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)) + SLUGWIDTH ENC MCODE CS-USED) + (FLET ((PUT-GLYPH-IN-CHARSET-ARRAY (CODE GLYPH CSARRAY &AUX CS) + (TCONC (AREF CSARRAY (SETQ CS (LRSH CODE 8))) (CONS (LOGAND CODE 255) - GLYPH)))) + GLYPH)) + (PUSHNEW CS CS-USED :TEST #'EQL))) (LOOP :FOR GL :IN (BF-GLYPHS FONT) - :UNLESS - (EQ GL SLUG) :DO - (SETQ MCS 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 MCODE (AND (INTEGERP ENC) - (PLUSP ENC) - (FUNCALL UTOMFN 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 - ((AND (ZEROP (GLYPH-BBW GL)) - (ZEROP (FIRST (GLYPH-DWIDTH GL)))) - - (IL:* IL:|;;| - "This has zero-width \"image\" with zero-width \"escapement\", put it in the NOMAPPINGCHARSET") - - (TCONC (AREF CSETS NOMAPPINGCHARSET) - (CONS ENC GL))) - ((NULL MCODE) - - (IL:* IL:|;;| "These assoc with the Unicode encoding") - - (COND - ((OR (> ENC 65535) - (= 255 (LOGAND ENC 255))) + (SETQ MCODE (GLYPH-MCODE GL)) + (COND + ((AND (INTEGERP MCODE) + (<= 0 MCODE 65535)) - (IL:* IL:|;;| - "Unicode encoding is > xFFFF, or encoding low byte is FF, put it in the NOMAPPINGCHARSET") + (IL:* IL:|;;| "These assoc with the 8 bit character code within the charset") - (TCONC (AREF CSETS NOMAPPINGCHARSET) - (CONS ENC GL))) - (T (PUT-GLYPH-IN-CHARSET-ARRAY ENC GL NOMAPPINGCSETS)))) - ((AND (INTEGERP MCODE) - (<= 0 MCODE 65535)) + (PUT-GLYPH-IN-CHARSET-ARRAY MCODE GL CSETS) - (IL:* IL:|;;| - "These assoc with the 8 bit character code within the charset") - - (PUT-GLYPH-IN-CHARSET-ARRAY MCODE GL CSETS) + (IL:* IL:|;;| "Default SLUG width is width of A, in charset 0") - (IL:* IL:|;;| "Default SLUG width is width of A.") + (WHEN (AND (NOT SLUGWIDTH) + (ZEROP (LRSH MCODE 8)) + (EQL MCODE (CHAR-CODE #\A))) + (SETQ SLUGWIDTH (GLYPH-WIDTH GL)))) + (T + (IL:* IL:|;;| "Shouldn't happen!") - (WHEN (AND (NOT SLUGWIDTH) - (= ENC (CHAR-CODE #\A))) + (ERROR "Invalid MCODE: ~A~%"))))) + (SETQ CSETS (LOOP :FOR I :IN CS-USED :NCONC (LET ((CS (CAR (AREF CSETS I)))) - (IL:* IL:|;;| "A is the same code in MCCS and UNICODE ") + (IL:* IL:|;;| + "Extract the lists from the TCONC pointers") - (IL:* IL:|;;| - "Comparing with ENC, not MCODE, to look only in charset 0") - - (SETQ SLUGWIDTH (GLYPH-WIDTH GL)))) - ((LISTP MCODE) - - (IL:* IL:|;;| - "These assoc with the 8 bit character code within the charset (like above)") - - (LOOP :FOR MC :IN MCODE :WITH CS :UNLESS (MEMBER (SETQ CS - (LRSH MC 8)) - MCS) - :DO - (PUSH CS MCS) - (PUT-GLYPH-IN-CHARSET-ARRAY MC GL CSETS))) - (T (ERROR "Invalid MCODE: ~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))) + (SETQ CS (SORT (REMOVE-DUPLICATES + CS :TEST #'EQUAL) + #'< :KEY #'CAR)) + (WHEN CS + (LIST (LIST I CS)))))) + (LIST (SORT CSETS #'< :KEY #'CAR) + 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) @@ -509,15 +471,29 @@ X)) Y)))) -(DEFUN READ-BDF (PATH &OPTIONAL VERBOSE) (IL:* IL:\; "Edited 30-Apr-2025 13:37 by mth") +(DEFUN READ-BDF (PATH &KEY VERBOSE MCCS-ONLY (EXTERNAL-FORMAT :ISO8859/1)) + (IL:* IL:\; "Edited 1-Dec-2025 22:40 by mth") + (IL:* IL:\; "Edited 30-Nov-2025 11:59 by mth") + (IL:* IL:\; "Edited 28-Nov-2025 17:39 by mth") + (IL:* IL:\; "Edited 26-Nov-2025 22:47 by mth") + (IL:* IL:\; "Edited 19-Nov-2025 23:15 by mth") + (IL:* IL:\; "Edited 14-Nov-2025 16:35 by mth") + (IL:* IL:\; "Edited 30-Apr-2025 13:37 by mth") (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 GL (NGLYPHS 0) - (*PACKAGE* (FIND-PACKAGE "BDF"))) + ((NGLYPHS 0) + (MCHAR-PRESENT (BITMAPCREATE 256 256 1)) + (*PACKAGE* (FIND-PACKAGE "BDF")) + (MAPPED-GLYPHS (LIST NIL)) + (UNMAPPED-GLYPHS (LIST NIL)) + PROPS PROPS-COMPLETE CHARS-COUNT FONT-COMPLETE FONT POS KEY V VV LINE ITEMS GL XLFD) + + (IL:* IL:|;;| "Note: The EXTERNAL-FORMAT *ought* to be :UTF-8 for the BDF files from otf2bdf, but I'm seeing :ISO8859/1. I don't know why! But I'm setting the default :EXTERNAL-FORMAT appropriately for this.") + (WITH-OPEN-FILE - (FILE-STREAM PATH :ELEMENT-TYPE 'CHARACTER :DIRECTION :INPUT) + (FILE-STREAM PATH :ELEMENT-TYPE 'CHARACTER :DIRECTION :INPUT :EXTERNAL-FORMAT EXTERNAL-FORMAT) (LOOP :WHILE (STRING-EQUAL "COMMENT" (SETQ KEY (READ FILE-STREAM))) :DO @@ -530,7 +506,7 @@ (IL:* IL:|;;| "ignore the file format version number") (READ-LINE FILE-STREAM) - (SETQ FONT (MAKE-BDF-FONT)) + (SETQ FONT (MAKE-BDF-FONT :MCHAR-PRESENT MCHAR-PRESENT)) (LOOP :UNTIL FONT-COMPLETE :DO (SETQ LINE (READ-LINE FILE-STREAM)) (WHEN LINE (IL:* IL:\; "Ignore blank lines") @@ -542,7 +518,9 @@ (COND ((EQ KEY 'FONT) (SETF (BF-NAME FONT) - LINE)) + LINE) + (SETF (BF-XLFD FONT) + (SETQ XLFD (XLFD-SPLIT-FONT-NAME LINE)))) (T (SETQ ITEMS (READ-DELIMITED-LIST-FROM-STRING LINE)) (CASE KEY @@ -608,39 +586,66 @@ (PLUSP NGLYPHS)) (ERROR "Invalid BDF file - CHARS count (~A) is invalid or missing." NGLYPHS)) + (LOOP :REPEAT NGLYPHS :WITH ENC :WITH MC :DO (SETQ GL (READ-GLYPH + FILE-STREAM + FONT)) + (SETQ ENC (GLYPH-ENCODING GL)) + (WHEN (AND (LISTP ENC) + (EQ (FIRST ENC) + -1)) + (SETQ ENC (OR (SECOND ENC) + -1))) + (COND + ((AND (OR (PLUSP (GLYPH-BBW GL)) + (PLUSP (FIRST (GLYPH-DWIDTH GL)))) + (SETQ MC (UTOMCODE? ENC))) + + (IL:* IL:|;;| "This glyph must have either a non-zero-width \"image\" or a non-zero-width \"escapement\", otherwise it cannot be mapped, no matter the UTOMCODE? value.") + + (LOOP :FOR CC :IN (IL:MKLIST MC) + :WITH CGL :DO + + (IL:* IL:|;;| "Copy GL if multiple MCODEs") + + (SETQ CGL (IF (LISTP MC) + (COPY-GLYPH GL) + GL)) + (SETF (GLYPH-MCODE CGL) + CC) + + (IL:* IL:|;;| "It ought to be safe to share the bitmap") + + (TCONC MAPPED-GLYPHS CGL) + (CHAR-PRESENT-BIT MCHAR-PRESENT CC 1))) + (T (TCONC UNMAPPED-GLYPHS GL)))) (SETF (BF-GLYPHS 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)))))) + (CAR MAPPED-GLYPHS)) + (SETF (BF-UNMAPPED¬GLYPHS FONT) + (CAR UNMAPPED-GLYPHS))) (ENDFONT (SETQ FONT-COMPLETE T)))))))) - (DESTRUCTURING-BIND (FAMILY (WEIGHT SLANT EXPANSION) - SIZE) - (GET-FAMILY-FACE-SIZE-FROM-NAME FONT) - (WHEN VERBOSE - (FORMAT *STANDARD-OUTPUT* - "Name: ~A~%Family: ~A~%Size: ~A~%Weight: ~A~%Slant: ~A~%Expansion: ~A~%" - (BF-NAME FONT) - FAMILY SIZE WEIGHT SLANT EXPANSION)) - (VALUES FONT FAMILY WEIGHT SLANT EXPANSION SIZE))))) + (WHEN VERBOSE + + (IL:* IL:|;;| "The SIZE reported needs clarification:") + + (FORMAT *STANDARD-OUTPUT* "Name: ~A~%Family: ~A~%Sizes: Font: ~A Pixel: ~A Point: ~A (decipoints)~%Weight: ~A~%Slant: ~A~%Expansion: ~A~%" + (BF-NAME FONT) + (XLFD-FAMILY XLFD) + (FIRST (BF-SIZE FONT)) + (XLFD-PIXEL¬SIZE XLFD) + (XLFD-POINT¬SIZE XLFD) + (XLFD-WEIGHT XLFD) + (XLFD-SLANT XLFD) + (XLFD-SETWIDTH¬NAME XLFD))) + FONT))) (DEFUN READ-DELIMITED-LIST-FROM-STRING (INPUT-STRING &OPTIONAL (DELIMIT #\])) (IL:* IL:\; "Edited 20-Aug-2024 16:46 by mth") (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 23-Apr-2025 17:53 by mth") +(DEFUN READ-GLYPH (FILE-STREAM FONT) (IL:* IL:\; "Edited 26-Nov-2025 23:32 by mth") + (IL:* IL:\; "Edited 17-Nov-2025 20:03 by mth") + (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") @@ -677,7 +682,7 @@ (SETQ ITEMS (READ-DELIMITED-LIST-FROM-STRING LINE)) (CASE KEY (ENCODING (SETF (GLYPH-ENCODING GLYPH) - (IF (EQUAL -1 (FIRST ITEMS)) + (IF (EQL -1 (FIRST ITEMS)) ITEMS (FIRST ITEMS)))) (SWIDTH (SETF (GLYPH-SWIDTH GLYPH) @@ -698,37 +703,41 @@ (THIRD ITEMS) (GLYPH-BBYOFF0 GLYPH) (FOURTH ITEMS))) - (BITMAP (LET* ((BM (BITMAPCREATE BBW BBH 1)) - (BM.BASE (IL:|fetch| IL:BITMAPBASE IL:|of| BM)) - (BM.RASTERWIDTH (IL:|fetch| IL:BITMAPRASTERWIDTH - IL:|of| BM)) - (NBYTES (CEILING BBW 8)) - (NCHARS (* 2 NBYTES)) - (NWORDS (CEILING BBW 16)) - BITS BYTEPOS WORDINDEX) - (LOOP :WITH BITROW = 0 :REPEAT BBH :DO - (SETQ LINE (STRING-TRIM '(#\Space #\Tab) - (READ-LINE FILE-STREAM))) - (UNLESS (AND (EQUAL NCHARS (LENGTH LINE)) - (SETQ BITS - (PARSE-INTEGER LINE :RADIX 16 - :JUNK-ALLOWED T))) - (ERROR + (BITMAP (UNLESS (ZEROP (* BBW BBH)) + + (IL:* IL:|;;| "Don't bother creating a BITMAP with no area") + + (LET* ((BM (BITMAPCREATE BBW BBH 1)) + (BM.BASE (IL:|fetch| IL:BITMAPBASE IL:|of| BM)) + (BM.RASTERWIDTH (IL:|fetch| IL:BITMAPRASTERWIDTH + IL:|of| BM)) + (NBYTES (CEILING BBW 8)) + (NCHARS (* 2 NBYTES)) + (NWORDS (CEILING BBW 16)) + BITS BYTEPOS WORDINDEX) + (LOOP :WITH BITROW = 0 :REPEAT BBH :DO + (SETQ LINE (STRING-TRIM '(#\Space #\Tab) + (READ-LINE FILE-STREAM))) + (UNLESS (AND (EQUAL NCHARS (LENGTH LINE)) + (SETQ BITS + (PARSE-INTEGER LINE :RADIX 16 + :JUNK-ALLOWED T))) + (ERROR "Invalid BDF file - bad line in BITMAP: ~A" - LINE)) - (WHEN (ODDP NBYTES) - (SETQ BITS (ASH BITS 8))) - (SETQ WORDINDEX (* BITROW BM.RASTERWIDTH)) - (SETQ BYTEPOS (* 16 (1- NWORDS))) - (LOOP :REPEAT NWORDS :DO - (IL:\\PUTBASE BM.BASE WORDINDEX - (LDB (BYTE 16 BYTEPOS) - BITS)) - (INCF WORDINDEX) - (DECF BYTEPOS 16)) - (INCF BITROW)) - (SETF (GLYPH-BITMAP GLYPH) - BM))) + LINE)) + (WHEN (ODDP NBYTES) + (SETQ BITS (ASH BITS 8))) + (SETQ WORDINDEX (* BITROW BM.RASTERWIDTH)) + (SETQ BYTEPOS (* 16 (1- NWORDS))) + (LOOP :REPEAT NWORDS :DO + (IL:\\PUTBASE BM.BASE WORDINDEX + (LDB (BYTE 16 BYTEPOS) + BITS)) + (INCF WORDINDEX) + (DECF BYTEPOS 16)) + (INCF BITROW)) + (SETF (GLYPH-BITMAP GLYPH) + BM)))) (ENDCHAR (SETQ CHAR-COMPLETE T))))))) (SETF (GLYPH-ASCENT GLYPH) (+ (GLYPH-BBH GLYPH) @@ -741,87 +750,119 @@ (FIRST (GLYPH-DWIDTH GLYPH)))) GLYPH)) -(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") +(DEFUN WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE (BDFONT DEST-DIR &KEY FAMILY SIZE FACE ROTATION DEVICE + &AUX FULLFILENAME) + (IL:* IL:\; "Edited 2-Dec-2025 14:47 by mth") + (IL:* IL:\; "Edited 30-Nov-2025 16:03 by mth") + (IL:* IL:\; "Edited 28-Nov-2025 17:56 by mth") + (IL:* IL:\; "Edited 26-Nov-2025 21:07 by mth") + (IL:* IL:\; "Edited 16-Nov-2025 17:32 by mth") + (UNLESS (BDF-FONT-P BDFONT) + (ERROR "Not a BDF-FONT: ~S ~%" BDFONT)) + (DESTRUCTURING-BIND (FONTDESC CSETS) + (BDF-TO-FONTDESCRIPTOR BDFONT FAMILY SIZE FACE ROTATION DEVICE) + (UNLESS FONTDESC - (IL:* IL:|;;| "First, check if it COULD be in XLFD format") + (IL:* IL:|;;| "Creation of the FONTDESCRIPTOR failed!") - (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 5-Nov-2025 23:06 by mth") - (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)) - (WHEN RAW-UNICODE-MAPPING - (SETQ FAMILY (IL:\\FONTSYMBOL (CONCATENATE 'STRING "RAW-" (STRING FAMILY))))) - (SETQ FACE (OR FACE FN-FACE)) - (SETQ SIZE (OR SIZE FN-SIZE)) - (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 - (IL:\\FONTFILENAME 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 - (IL:\\FONTFILENAME (FONTPROP - UNMAPPED-FONTDESC - 'IL:FAMILY) - SIZE FACE "DISPLAYFONT" CS)))) - (SETQ UNICODE-CSETS NIL)) - - (IL:* IL:|;;| "These correspond to the charsets ACTUALLY written.") + (HELP "FONTDESC IS NIL")) - (IL:* IL:|;;| - "UNMAPPEDGLYPHS are never written. (Unicode encoding is > xFFFF, or encoding low byte is FF)") + (IL:* IL:|;;| "CSETS correspond to the charsets actually present in the FONTDESC.") + + (SETQ FULLFILENAME (MEDLEYFONT.WRITE.FONT FONTDESC (MEDLEYFONT.FILENAME FONTDESC NIL NIL + DEST-DIR))) + (LIST FULLFILENAME FONTDESC CSETS))) + +(DEFUN XLFD-SPLIT-FONT-NAME (NAME) (IL:* IL:\; "Edited 26-Nov-2025 09:43 by mth") + (IL:* IL:\; "Edited 23-Apr-2025 16:22 by mth") + (IL:* IL:\; "Edited 31-Jan-2025 22:20 by mth") + (LET (PARTS (XLFD (MAKE-XLFD))) + + (IL:* IL:|;;| "First, check if it COULD be in XLFD format") + + (SETQ PARTS (IF (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) + (PROGN + (IL:* IL:|;;| + "There are no -'s, so use the NAME as the FAMILY with a NIL FOUNDRY") + + (LIST NIL NAME)))) + (FLET ((PARSE-P-SIZE (SZSTR) + (COND + ((ZEROP (LENGTH SZSTR)) + -1) + ((PARSE-INTEGER SZSTR :JUNK-ALLOWED T)) + (T -1)))) + (DESTRUCTURING-BIND (FOUNDRY FAMILY WEIGHT SLANT SETWIDTH¬NAME ADD¬STYLE¬NAME + PIXEL¬SIZE POINT¬SIZE RESOLUTION¬X RESOLUTION¬Y SPACING + AVERAGE¬WIDTH CHARSET¬REGISTRY CHARSET¬ENCODING) + PARTS + (SETQ FAMILY (REMOVE #\Space FAMILY :TEST #'CHAR=)) + (SETQ PIXEL¬SIZE (PARSE-P-SIZE PIXEL¬SIZE)) + (SETQ POINT¬SIZE (PARSE-P-SIZE POINT¬SIZE)) + (MAKE-XLFD :FOUNDRY FOUNDRY :FAMILY FAMILY :WEIGHT WEIGHT :SLANT SLANT + :SETWIDTH¬NAME SETWIDTH¬NAME :ADD¬STYLE¬NAME ADD¬STYLE¬NAME :PIXEL¬SIZE + PIXEL¬SIZE :POINT¬SIZE POINT¬SIZE :RESOLUTION¬X RESOLUTION¬X + :RESOLUTION¬Y RESOLUTION¬Y :SPACING SPACING :AVERAGE¬WIDTH AVERAGE¬WIDTH + :CHARSET¬REGISTRY CHARSET¬REGISTRY :CHARSET¬ENCODING CHARSET¬ENCODING))))) + +(DEFUN XLFD-TO-FACE (XLFD) (IL:* IL:\; "Edited 25-Nov-2025 17:50 by mth") + (UNLESS (TYPEP XLFD 'XLFD) + (ERROR "Not an XLFD object: ~S ~%" XLFD)) + (LET ((WEIGHT (XLFD-WEIGHT XLFD)) + (SLANT (XLFD-SLANT XLFD)) + (EXPANSION (XLFD-SETWIDTH¬NAME XLFD))) + + (IL:* IL:|;;| "mth 11-25-2025 Brute force hackery now. This needs to be made smarter.") + + (SETQ WEIGHT (OR (AND WEIGHT (CADR (ASSOC (CHAR-UPCASE (ELT WEIGHT 0)) + '((#\R MEDIUM) + (#\M MEDIUM) + (#\N MEDIUM) + (#\B BOLD) + (#\D BOLD + (IL:* IL:\; "DemiBold => BOLD")) + (#\L LIGHT))))) + 'MEDIUM)) + (SETQ SLANT (OR (AND SLANT (CADR (ASSOC (CHAR-UPCASE (ELT SLANT 0)) + '((REGULAR) + (#\R REGULAR) + (#\I ITALIC) + (#\O ITALIC + (IL:* IL:\; "Oblique => ITALIC")))))) + 'REGULAR)) (IL:* IL:\; "Ignore other SLANTs") + + (IL:* IL:|;;| "Expansion (SETWIDTH¬NAME) has many more options than these, and they aren't 1st character unique! Apparently, there's no set of (semi-)standard names.") + + (SETQ EXPANSION (OR (AND EXPANSION (CADR (ASSOC (CHAR-UPCASE (ELT EXPANSION 0)) + '((#\R REGULAR) + (#\N REGULAR) + (#\E EXPANDED + (IL:* IL:\; + "E could be ExtraCondensed, Expanded, ExtraExpanded!!!") + ) + (#\S COMPRESSED + (IL:* IL:\; + "S is for \"SemiCompressed\", Using \"Condensed\"") + ) + (#\C COMPRESSED))))) + 'REGULAR)) + + (IL:* IL:|;;| + "Now check for WEIGHT and EXPANSION both BOLD. If so, change Expansion to REGULAR") - (VALUES FONTDESC CSETS UNMAPPED-FONTDESC UNICODE-CSETS UNMAPPEDGLYPHS)))) + (WHEN (AND (EQ WEIGHT EXPANSION) + (EQ EXPANSION 'BOLD)) + (SETQ EXPANSION 'REGULAR)) + (LIST WEIGHT SLANT EXPANSION))) (IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY (IL:FILESLOAD (IL:SYSLOAD) @@ -833,25 +874,27 @@ ) (DEFINE-FILE-ENVIRONMENT "READ-BDF" :PACKAGE (DEFPACKAGE "BDF" (:USE "XCL" "LISP") - (:EXPORT "READ-BDF" - "WRITE-BDF-TO-DISPLAYFONT-FILES") - (:IMPORT-FROM "IL" "BITBLT" "BITMAPCREATE" - "BITMAPHEIGHT" "BITMAPWIDTH" "BLACKSHADE" - "BLTSHADE" "BOLD" "COMPRESSED" - "CHARSETINFO" "DISPLAY" "FONTDESCRIPTOR" + (:EXPORT "READ-BDF" "BUILD-COMPOSITE" + "WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE") + (:IMPORT-FROM "IL" "BITBLT" "BITMAPBIT" + "BITMAPCREATE" "BITMAPHEIGHT" + "BITMAPWIDTH" "BLACKSHADE" "BLTSHADE" + "BOLD" "COMPRESSED" "CHARSETINFO" + "CHARSETPROP" "DISPLAY" "FONTDESCRIPTOR" "FONTP" "FONTPROP" "INPUT" "ITALIC" - "LIGHT" "LRSH" "MEDIUM" "REGULAR" "TCONC" - "UTOMCODE" "UTOMCODE?" - "WRITESTRIKEFONTFILE")) + "LIGHT" "LRSH" "MCCS" "MEDIUM" "REGULAR" + "TCONC" "UTOMCODE?" "MEDLEYFONT.FILENAME" + "MEDLEYFONT.WRITE.FONT")) :READTABLE "XCL" :COMPILER :COMPILE-FILE) (IL:PUTPROPS IL:READ-BDF IL:DATABASE IL:NO) (IL:DECLARE\: IL:DONTCOPY - (IL:FILEMAP (NIL (2497 10576 (BDF-TO-CHARSETINFO 2497 . 10576)) (10578 16996 (BDF-TO-FONTDESCRIPTOR -10578 . 16996)) (16998 20538 (GET-FAMILY-FACE-SIZE-FROM-NAME 16998 . 20538)) (20540 27970 ( -GLYPHS-BY-CHARSET 20540 . 27970)) (27972 29397 (PACKFILENAME.STRING 27972 . 29397)) (29399 36358 ( -READ-BDF 29399 . 36358)) (36360 36683 (READ-DELIMITED-LIST-FROM-STRING 36360 . 36683)) (36685 43176 ( -READ-GLYPH 36685 . 43176)) (43178 43919 (SPLIT-FONT-NAME 43178 . 43919)) (43921 47827 ( -WRITE-BDF-TO-DISPLAYFONT-FILES 43921 . 47827))))) + (IL:FILEMAP (NIL (3116 10226 (BDF-TO-CHARSETINFO 3116 . 10226)) (10228 16847 (BDF-TO-FONTDESCRIPTOR +10228 . 16847)) (16849 20782 (BUILD-COMPOSITE 16849 . 20782)) (20784 21533 (CHAR-PRESENT-BIT 20784 . +21533)) (21535 21819 (COUNT-MCHARS 21535 . 21819)) (21821 24856 (GLYPHS-BY-CHARSET 21821 . 24856)) ( +24858 26283 (PACKFILENAME.STRING 24858 . 26283)) (26285 35760 (READ-BDF 26285 . 35760)) (35762 36085 ( +READ-DELIMITED-LIST-FROM-STRING 35762 . 36085)) (36087 43085 (READ-GLYPH 36087 . 43085)) (43087 44472 +(WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE 43087 . 44472)) (44474 46891 (XLFD-SPLIT-FONT-NAME 44474 . 46891) +) (46893 49905 (XLFD-TO-FACE 46893 . 49905))))) IL:STOP diff --git a/lispusers/READ-BDF.DFASL b/lispusers/READ-BDF.DFASL index 927778eaf..d112551a3 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 891c14cc1..1f1add700 100644 Binary files a/lispusers/READ-BDF.TEDIT and b/lispusers/READ-BDF.TEDIT differ