READ-BDF initial changes for XCCS to MCCS (#2360)
* Verbose mode (READ-BDF) was implemented incorrectly - fixed * Cleanup DEFPACKAGE in source file using :IMPORT-FROM, and fewer imports. * Various renaming for consistency with XCCS -> MCCS changes. * Use IL:FONTSPEC record instead of using FIRST, SECOND, etc. * Fix the parsing of IL:FONTSPEC to use COMPRESSED instead of incorrect CONDENSED. * Zero-width "image" with zero-width "escapement" GLYPHS now get put into NOMAPPINGCHARSET. * Add (FILES (SYSLOAD) SYSEDIT) under existing (DECLARE: EVAL@COMPILE DONTCOPY ...)
This commit is contained in:
Matt Heffron
GitHub
parent
428aac56ea
commit
defd68a892
@ -1,17 +1,19 @@
|
||||
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "BDF" ( USE "XCL" "LISP") ( EXPORT "READ-BDF"
|
||||
"WRITE-BDF-TO-DISPLAYFONT-FILES") ( IMPORT \AVGCHARWIDTH \FGETWIDTH \FONTFACE \FONTFILENAME
|
||||
\FSETOFFSET \FSETWIDTH \FONTSYMBOL \GETSTREAM \INSTALLCHARSETINFO \PUTBASE BITBLT BITMAPCREATE
|
||||
BITMAPHEIGHT BITMAPWIDTH BLACKSHADE BLTSHADE BOLD CONDENSED CHARSETINFO DISPLAY FONTDESCRIPTOR FONTP
|
||||
FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITESTRIKEFONTFILE))
|
||||
READTABLE "XCL" BASE 10)
|
||||
"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)
|
||||
|
||||
(IL:FILECREATED "30-Apr-2025 13:20:10" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;61| 47500
|
||||
(IL:FILECREATED " 6-Nov-2025 23:10:51" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;13| 49101
|
||||
|
||||
:EDIT-BY "mth"
|
||||
|
||||
:CHANGES-TO (IL:FUNCTIONS GET-FAMILY-FACE-SIZE-FROM-NAME)
|
||||
:CHANGES-TO (IL:FUNCTIONS BDF-TO-FONTDESCRIPTOR BDF-TO-CHARSETINFO READ-GLYPH
|
||||
WRITE-BDF-TO-DISPLAYFONT-FILES)
|
||||
(FILE-ENVIRONMENTS "READ-BDF")
|
||||
(IL:VARS IL:READ-BDFCOMS)
|
||||
|
||||
:PREVIOUS-DATE "25-Apr-2025 10:10:08" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;60|
|
||||
:PREVIOUS-DATE " 6-Nov-2025 22:43:21" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;9|
|
||||
)
|
||||
|
||||
|
||||
@ -23,8 +25,10 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
(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))
|
||||
(IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY (IL:FILES (IL:SYSLOAD)
|
||||
IL:SYSEDIT)
|
||||
(IL:FILES (IL:LOADCOMP)
|
||||
IL:FONT))
|
||||
(FILE-ENVIRONMENTS "READ-BDF")
|
||||
(IL:PROP (IL:DATABASE)
|
||||
IL:READ-BDF)))
|
||||
@ -40,10 +44,10 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
(SLUG NIL :TYPE GLYPH))
|
||||
|
||||
(DEFSTRUCT GLYPH
|
||||
"This is an individual BDF glyph. Includes some values calculted for creating CHARSETINFO"
|
||||
"This is an individual BDF glyph. Includes some values calculated for creating CHARSETINFO"
|
||||
(NAME NIL :TYPE STRING)
|
||||
ENCODING SWIDTH DWIDTH SWIDTH1 DWIDTH1 VVECTOR BBW BBH BBXOFF0 BBYOFF0 BITMAP
|
||||
(XCODE 0 :TYPE INTEGER)
|
||||
(MCODE 0 :TYPE INTEGER)
|
||||
(WIDTH 0 :TYPE INTEGER)
|
||||
(ASCENT 0 :TYPE INTEGER)
|
||||
(DESCENT 0 :TYPE INTEGER))
|
||||
@ -55,6 +59,7 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
(DEFCONSTANT NOMAPPINGCHARSET (1+ MAXCHARSET))
|
||||
|
||||
(DEFUN BDF-TO-CHARSETINFO (FONT CSET SLUG-OR-WIDTH &OPTIONAL MAP-UNKNOWN-TO-PRIVATE)
|
||||
(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")
|
||||
@ -98,7 +103,7 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
((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))
|
||||
(SETQ CSGLYPHS (LOOP :FOR XGL :IN CSGLYPHS :COLLECT (LET* ((MCODE (CAR XGL))
|
||||
(GL (CDR XGL))
|
||||
(GWIDTH (GLYPH-WIDTH
|
||||
GL))
|
||||
@ -112,13 +117,13 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
|
||||
"Is the above statement actually true?")
|
||||
|
||||
(SETF (GLYPH-XCODE GL)
|
||||
XCODE)
|
||||
(SETF (GLYPH-MCODE GL)
|
||||
MCODE)
|
||||
(SETQ FIRSTCHAR
|
||||
(MIN FIRSTCHAR XCODE
|
||||
(MIN FIRSTCHAR MCODE
|
||||
))
|
||||
(SETQ LASTCHAR
|
||||
(MAX LASTCHAR XCODE)
|
||||
(MAX LASTCHAR MCODE)
|
||||
)
|
||||
(INCF TOTAL-WIDTH GWIDTH)
|
||||
(SETQ ASCENT
|
||||
@ -133,13 +138,13 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
(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
|
||||
(IL:|for| I IL:|from| 0 IL:|to| (+ MAXTHINCHAR 2) IL:|do| (IL:\\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
|
||||
(IL:|for| I IL:|from| 0 IL:|to| (+ MAXTHINCHAR 2) IL:|do| (IL:\\FSETWIDTH WIDTHS I
|
||||
SLUGWIDTH))
|
||||
(IL:|replace| (CHARSETINFO IL:IMAGEWIDTHS) IL:|of| CSINFO IL:|with| WIDTHS)
|
||||
|
||||
@ -151,19 +156,19 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
(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
|
||||
(LOOP :FOR GL :IN CSGLYPHS :WITH GLBM :WITH GLW :WITH MCODE :DO (SETQ GLBM
|
||||
(GLYPH-BITMAP
|
||||
GL))
|
||||
(SETQ GLW (GLYPH-WIDTH GL))
|
||||
(SETQ XCODE (GLYPH-XCODE 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)
|
||||
(\\FSETOFFSET OFFSETS XCODE DLEFT)
|
||||
(\\FSETOFFSET WIDTHS XCODE GLW)
|
||||
(IL:\\FSETOFFSET OFFSETS MCODE DLEFT)
|
||||
(IL:\\FSETOFFSET WIDTHS MCODE GLW)
|
||||
(INCF DLEFT GLW))
|
||||
|
||||
(IL:* IL:|;;| "Now insert the SLUG glyph into the BMAP, or make a slug (block)")
|
||||
@ -185,6 +190,7 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
|
||||
(DEFUN BDF-TO-FONTDESCRIPTOR (BDFONT FAMILY SIZE FACE ROTATION DEVICE &OPTIONAL
|
||||
MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING)
|
||||
(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)
|
||||
@ -200,18 +206,22 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
(OR DEVICE (FONTPROP FAMILY 'IL:DEVICE))
|
||||
MAP-UNKNOWN-TO-PRIVATE)))
|
||||
(WHEN (LISTP FAMILY)
|
||||
(RETURN (BDF-TO-FONTDESCRIPTOR BDFONT (FIRST FAMILY)
|
||||
(OR (SECOND 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 (THIRD FAMILY)
|
||||
(OR (IL:|fetch| (IL:FONTSPEC IL:FSFACE) IL:|of| FAMILY)
|
||||
FACE "MRR")
|
||||
(OR (FOURTH FAMILY)
|
||||
(OR (IL:|fetch| (IL:FONTSPEC IL:FSROTATION) IL:|of| FAMILY)
|
||||
ROTATION 0)
|
||||
(OR (FIFTH FAMILY)
|
||||
(OR (IL:|fetch| (IL:FONTSPEC IL:FSDEVICE) IL:|of| FAMILY)
|
||||
DEVICE
|
||||
'DISPLAY)
|
||||
MAP-UNKNOWN-TO-PRIVATE)))
|
||||
(SETQ FAMILY (\\FONTSYMBOL FAMILY))
|
||||
(SETQ FAMILY (IL:\\FONTSYMBOL FAMILY))
|
||||
(UNLESS (AND (INTEGERP SIZE)
|
||||
(PLUSP SIZE))
|
||||
(ERROR "Invalid SIZE: ~S~%" SIZE))
|
||||
@ -236,7 +246,7 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
(INTERN (STRING-UPCASE DEVICE)
|
||||
"IL"))
|
||||
(T (IL:\\ILLEGAL.ARG DEVICE))))
|
||||
(SETQ FACE (\\FONTFACE FACE NIL DEV))
|
||||
(SETQ FACE (IL:\\FONTFACE FACE NIL DEV))
|
||||
(SETQ GBCSL (GLYPHS-BY-CHARSET BDFONT MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING))
|
||||
(UNLESS SLUGWIDTH
|
||||
|
||||
@ -268,15 +278,16 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
GBCS CSET (OR SLUG (1+
|
||||
SLUGWIDTH
|
||||
))))
|
||||
(\\INSTALLCHARSETINFO FONTDESC CSINFO CSET)
|
||||
(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)
|
||||
(\\FONTSYMBOL (CONCATENATE 'STRING
|
||||
(SYMBOL-NAME FAMILY)
|
||||
"-UNMAPPED")))
|
||||
(IL:\\FONTSYMBOL (CONCATENATE 'STRING
|
||||
(SYMBOL-NAME FAMILY)
|
||||
"-UNMAPPED")))
|
||||
(LIST (ASSOC NOMAPPINGCHARSET (FIRST GBCSL)
|
||||
:TEST
|
||||
#'EQL)))))))))
|
||||
@ -311,8 +322,8 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
'((#\R . REGULAR)
|
||||
(#\N . REGULAR)
|
||||
(#\B . BOLD)
|
||||
(#\S . CONDENSED)
|
||||
(#\C . CONDENSED)))))
|
||||
(#\S . COMPRESSED)
|
||||
(#\C . COMPRESSED)))))
|
||||
'REGULAR)) (IL:* IL:\;
|
||||
"S is for \"SemiCondensed\", Assuming \"Condensed\"")
|
||||
|
||||
@ -336,17 +347,19 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
(FIRST (BF-SIZE BDFONT))))))
|
||||
|
||||
(DEFUN GLYPHS-BY-CHARSET (FONT &OPTIONAL MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING)
|
||||
(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))))
|
||||
(UTOXFN (COND
|
||||
(UTOMFN (COND
|
||||
(RAW-UNICODE-MAPPING #'IDENTITY)
|
||||
(MAP-UNKNOWN-TO-PRIVATE #'UTOXCODE)
|
||||
(T #'UTOXCODE?)))
|
||||
(MAP-UNKNOWN-TO-PRIVATE #'UTOMCODE)
|
||||
(T #'UTOMCODE?)))
|
||||
(SLUG (BF-SLUG FONT))
|
||||
(SLUGWIDTH (AND SLUG (GLYPH-WIDTH SLUG)))
|
||||
NOMAPPINGCSETS ENC XCODE XCS)
|
||||
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)))))
|
||||
@ -358,7 +371,7 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
:UNLESS
|
||||
(EQ GL SLUG)
|
||||
:DO
|
||||
(SETQ XCS NIL)
|
||||
(SETQ MCS NIL)
|
||||
(SETQ ENC (GLYPH-ENCODING GL))
|
||||
(WHEN (LISTP ENC)
|
||||
|
||||
@ -372,9 +385,9 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
"The -1 case of the (OR ...) shouldn't happen. The (EQ GL SLUG) test above should have caught it")
|
||||
|
||||
)
|
||||
(SETQ XCODE (AND (INTEGERP ENC)
|
||||
(SETQ MCODE (AND (INTEGERP ENC)
|
||||
(PLUSP ENC)
|
||||
(FUNCALL UTOXFN ENC)))
|
||||
(FUNCALL UTOMFN ENC)))
|
||||
(IF RAW-UNICODE-MAPPING
|
||||
(COND
|
||||
((> ENC 65535)
|
||||
@ -394,7 +407,15 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
(CONS ENC GL)))
|
||||
(T (PUT-GLYPH-IN-CHARSET-ARRAY ENC GL CSETS)))
|
||||
(COND
|
||||
((NULL XCODE)
|
||||
((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")
|
||||
|
||||
@ -408,37 +429,37 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
(TCONC (AREF CSETS NOMAPPINGCHARSET)
|
||||
(CONS ENC GL)))
|
||||
(T (PUT-GLYPH-IN-CHARSET-ARRAY ENC GL NOMAPPINGCSETS))))
|
||||
((AND (INTEGERP XCODE)
|
||||
(<= 0 XCODE 65535))
|
||||
((AND (INTEGERP MCODE)
|
||||
(<= 0 MCODE 65535))
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"These assoc with the 8 bit character code within the charset")
|
||||
|
||||
(PUT-GLYPH-IN-CHARSET-ARRAY XCODE GL CSETS)
|
||||
(PUT-GLYPH-IN-CHARSET-ARRAY MCODE 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:|;;| "A is the same code in MCCS and UNICODE ")
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Comparing with ENC, not XCODE, to look only in charset 0")
|
||||
"Comparing with ENC, not MCODE, to look only in charset 0")
|
||||
|
||||
(SETQ SLUGWIDTH (GLYPH-WIDTH GL))))
|
||||
((LISTP XCODE)
|
||||
((LISTP MCODE)
|
||||
|
||||
(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)
|
||||
(LOOP :FOR MC :IN MCODE :WITH CS :UNLESS (MEMBER (SETQ CS
|
||||
(LRSH MC 8))
|
||||
MCS)
|
||||
:DO
|
||||
(PUSH CS XCS)
|
||||
(PUT-GLYPH-IN-CHARSET-ARRAY XC GL CSETS)))
|
||||
(T (ERROR "Invalid XCODE: ~A~%"))))))
|
||||
(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")
|
||||
|
||||
@ -488,7 +509,8 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
X))
|
||||
Y))))
|
||||
|
||||
(DEFUN READ-BDF (PATH &OPTIONAL VERBOSE) (IL:* IL:\; "Edited 24-Apr-2025 00:44 by mth")
|
||||
(DEFUN READ-BDF (PATH &OPTIONAL VERBOSE) (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
|
||||
@ -603,15 +625,15 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
(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)
|
||||
(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)))
|
||||
FONT)))
|
||||
FAMILY SIZE WEIGHT SLANT EXPANSION))
|
||||
(VALUES FONT FAMILY WEIGHT SLANT EXPANSION SIZE)))))
|
||||
|
||||
(DEFUN READ-DELIMITED-LIST-FROM-STRING (INPUT-STRING &OPTIONAL (DELIMIT #\]))
|
||||
(IL:* IL:\; "Edited 20-Aug-2024 16:46 by mth")
|
||||
@ -699,7 +721,7 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
(SETQ WORDINDEX (* BITROW BM.RASTERWIDTH))
|
||||
(SETQ BYTEPOS (* 16 (1- NWORDS)))
|
||||
(LOOP :REPEAT NWORDS :DO
|
||||
(\\PUTBASE BM.BASE WORDINDEX
|
||||
(IL:\\PUTBASE BM.BASE WORDINDEX
|
||||
(LDB (BYTE 16 BYTEPOS)
|
||||
BITS))
|
||||
(INCF WORDINDEX)
|
||||
@ -744,12 +766,13 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
(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))
|
||||
(ERROR "Not a BDF-FONT: ~S ~%" BDFONT))
|
||||
(COND
|
||||
((EQ CHAR-SETS T) (IL:* IL:\; "This means ALL charsets")
|
||||
)
|
||||
@ -769,7 +792,7 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
(GET-FAMILY-FACE-SIZE-FROM-NAME BDFONT)
|
||||
(SETQ FAMILY (OR FAMILY FN-FAMILY))
|
||||
(WHEN RAW-UNICODE-MAPPING
|
||||
(SETQ FAMILY (\\FONTSYMBOL (CONCATENATE 'STRING "RAW-" (STRING FAMILY)))))
|
||||
(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)
|
||||
@ -780,16 +803,16 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
(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
|
||||
(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
|
||||
(\\FONTFILENAME (FONTPROP
|
||||
UNMAPPED-FONTDESC
|
||||
'IL:FAMILY)
|
||||
(IL:\\FONTFILENAME (FONTPROP
|
||||
UNMAPPED-FONTDESC
|
||||
'IL:FAMILY)
|
||||
SIZE FACE "DISPLAYFONT" CS))))
|
||||
(SETQ UNICODE-CSETS NIL))
|
||||
|
||||
@ -801,6 +824,10 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
(VALUES FONTDESC CSETS UNMAPPED-FONTDESC UNICODE-CSETS UNMAPPEDGLYPHS))))
|
||||
(IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY
|
||||
|
||||
(IL:FILESLOAD (IL:SYSLOAD)
|
||||
IL:SYSEDIT)
|
||||
|
||||
|
||||
(IL:FILESLOAD (IL:LOADCOMP)
|
||||
IL:FONT)
|
||||
)
|
||||
@ -808,25 +835,23 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
|
||||
(DEFINE-FILE-ENVIRONMENT "READ-BDF" :PACKAGE (DEFPACKAGE "BDF" (:USE "XCL" "LISP")
|
||||
(:EXPORT "READ-BDF"
|
||||
"WRITE-BDF-TO-DISPLAYFONT-FILES")
|
||||
(:IMPORT \\AVGCHARWIDTH \\FGETWIDTH \\FONTFACE
|
||||
\\FONTFILENAME \\FSETOFFSET \\FSETWIDTH
|
||||
\\FONTSYMBOL \\GETSTREAM
|
||||
\\INSTALLCHARSETINFO \\PUTBASE BITBLT
|
||||
BITMAPCREATE BITMAPHEIGHT BITMAPWIDTH
|
||||
BLACKSHADE BLTSHADE BOLD CONDENSED
|
||||
CHARSETINFO DISPLAY FONTDESCRIPTOR FONTP
|
||||
FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM
|
||||
REGULAR TCONC UTOXCODE UTOXCODE?
|
||||
WRITESTRIKEFONTFILE))
|
||||
(: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"
|
||||
:COMPILER :COMPILE-FILE)
|
||||
|
||||
(IL:PUTPROPS IL:READ-BDF IL:DATABASE IL:NO)
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL (2316 10275 (BDF-TO-CHARSETINFO 2316 . 10275)) (10277 16147 (BDF-TO-FONTDESCRIPTOR
|
||||
10277 . 16147)) (16149 19687 (GET-FAMILY-FACE-SIZE-FROM-NAME 16149 . 19687)) (19689 26500 (
|
||||
GLYPHS-BY-CHARSET 19689 . 26500)) (26502 27927 (PACKFILENAME.STRING 26502 . 27927)) (27929 34733 (
|
||||
READ-BDF 27929 . 34733)) (34735 35058 (READ-DELIMITED-LIST-FROM-STRING 34735 . 35058)) (35060 41548 (
|
||||
READ-GLYPH 35060 . 41548)) (41550 42291 (SPLIT-FONT-NAME 41550 . 42291)) (42293 46075 (
|
||||
WRITE-BDF-TO-DISPLAYFONT-FILES 42293 . 46075)))))
|
||||
(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:STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
Loading…
x
Reference in New Issue
Block a user