More progress on composite files.
WRITE-BDF-TO-DISPLAYFONT-FILES is deprecated (but symbols imported from IL: only for use there are not yet removed from :IMPORT-FROM)
This commit is contained in:
Matt Heffron
@@ -1,30 +1,33 @@
|
||||
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "BDF" ( USE "XCL" "LISP") ( EXPORT "READ-BDF"
|
||||
"WRITE-BDF-TO-DISPLAYFONT-FILES") ( IMPORT-FROM "IL" "BITBLT" "BITMAPCREATE" "BITMAPHEIGHT"
|
||||
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "BDF" ( USE "XCL" "LISP") ( EXPORT "READ-BDF" "BUILD-COMPOSITE"
|
||||
"WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE") ( 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)
|
||||
"WRITESTRIKEFONTFILE" "MEDLEYFONT.FILENAME" "MEDLEYFONT.WRITE.FONT")) READTABLE "XCL" BASE 10)
|
||||
|
||||
(IL:FILECREATED " 6-Nov-2025 23:10:51" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;13| 49101
|
||||
(IL:FILECREATED "19-Nov-2025 22:01:49" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;37| 59108
|
||||
|
||||
:EDIT-BY "mth"
|
||||
|
||||
:CHANGES-TO (IL:FUNCTIONS BDF-TO-FONTDESCRIPTOR BDF-TO-CHARSETINFO READ-GLYPH
|
||||
WRITE-BDF-TO-DISPLAYFONT-FILES)
|
||||
(FILE-ENVIRONMENTS "READ-BDF")
|
||||
:CHANGES-TO (FILE-ENVIRONMENTS "READ-BDF")
|
||||
(IL:FUNCTIONS BUILD-COMPOSITE READ-BDF WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE
|
||||
WRITE-BDF-TO-DISPLAYFONT-FILES GET-FAMILY-FACE-SIZE-FROM-NAME READ-GLYPH
|
||||
GET-CHARS-PRESENT)
|
||||
(IL:STRUCTURES BDF-FONT XLFD)
|
||||
(IL:VARS IL:READ-BDFCOMS)
|
||||
|
||||
:PREVIOUS-DATE " 6-Nov-2025 22:43:21" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;9|
|
||||
:PREVIOUS-DATE "18-Nov-2025 21:22:35" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;36|
|
||||
)
|
||||
|
||||
|
||||
(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 GET-CHARS-PRESENT
|
||||
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 WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE)
|
||||
(IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY (IL:FILES (IL:SYSLOAD)
|
||||
IL:SYSEDIT)
|
||||
(IL:FILES (IL:LOADCOMP)
|
||||
@@ -41,7 +44,7 @@
|
||||
(METRICSSET 0 :TYPE (INTEGER 0 2))
|
||||
(PROPERTIES NIL :TYPE LIST)
|
||||
SWIDTH DWIDTH SWIDTH1 DWIDTH1 VVECTOR (GLYPHS NIL :TYPE LIST)
|
||||
(SLUG NIL :TYPE GLYPH))
|
||||
(XLFD NIL :TYPE XLFD))
|
||||
|
||||
(DEFSTRUCT GLYPH
|
||||
"This is an individual BDF glyph. Includes some values calculated for creating CHARSETINFO"
|
||||
@@ -52,6 +55,23 @@
|
||||
(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)
|
||||
(EXPANSION 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)
|
||||
@@ -59,6 +79,7 @@
|
||||
(DEFCONSTANT NOMAPPINGCHARSET (1+ MAXCHARSET))
|
||||
|
||||
(DEFUN BDF-TO-CHARSETINFO (FONT CSET SLUG-OR-WIDTH &OPTIONAL MAP-UNKNOWN-TO-PRIVATE)
|
||||
(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")
|
||||
@@ -92,6 +113,7 @@
|
||||
(FIRSTCHAR MOST-POSITIVE-FIXNUM)
|
||||
(LASTCHAR MOST-NEGATIVE-FIXNUM)
|
||||
(CSINFO (IL:|create| CHARSETINFO))
|
||||
(IMAGEWIDTHS (IL:\\CREATECSINFOELEMENT))
|
||||
(DLEFT 0)
|
||||
SLUG SLUGWIDTH GLYPHS-LIMITS BMAP OFFSETS HEIGHT WIDTHS)
|
||||
(COND
|
||||
@@ -140,13 +162,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. ")
|
||||
|
||||
@@ -168,7 +194,8 @@
|
||||
'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)")
|
||||
@@ -292,59 +319,139 @@
|
||||
:TEST
|
||||
#'EQL)))))))))
|
||||
|
||||
(DEFUN GET-FAMILY-FACE-SIZE-FROM-NAME (BDFONT) (IL:* IL:\; "Edited 30-Apr-2025 13:18 by mth")
|
||||
(DEFUN BUILD-COMPOSITE (BASE-FONT &REST FILL-FROM) (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 (UCHAR-PRESENT FONT FAMILY WEIGHT SLANT EXPANSION SIZE UC-PRESENT)
|
||||
(UNLESS (AND FILL-FROM (LISTP FILL-FROM))
|
||||
(ERROR "FILL-FROM is not a list."))
|
||||
(COND
|
||||
((OR (STRINGP BASE-FONT)
|
||||
(PATHNAMEP BASE-FONT))
|
||||
(UNLESS (IL:INFILEP BASE-FONT)
|
||||
(ERROR "BASE-FONT ~S doesn't exist or is unreadable." BASE-FONT))
|
||||
(MULTIPLE-VALUE-SETQ (FONT FAMILY WEIGHT SLANT EXPANSION SIZE UC-PRESENT)
|
||||
(READ-BDF BASE-FONT :MCCS-ONLY T))
|
||||
(SETQ BASE-FONT FONT)
|
||||
(SETQ UCHAR-PRESENT UC-PRESENT))
|
||||
((TYPEP BASE-FONT 'BDF-FONT)
|
||||
(SETQ UCHAR-PRESENT (GET-CHARS-PRESENT BASE-FONT)))
|
||||
(T (ERROR "BASE-FONT is not a BDF-FONT, nor string, nor pathname.")))
|
||||
(UNLESS UCHAR-PRESENT)
|
||||
(LOOP :FOR FILL-FONT :IN FILL-FROM :WHEN FILL-FONT :DO
|
||||
(COND
|
||||
((OR (STRINGP FILL-FONT)
|
||||
(PATHNAMEP FILL-FONT))
|
||||
(UNLESS (IL:INFILEP FILL-FONT)
|
||||
(ERROR "Element of FILL-FROM (~S) doesn't exist or is unreadable." FILL-FONT
|
||||
))
|
||||
(MULTIPLE-VALUE-SETQ (FONT FAMILY WEIGHT SLANT EXPANSION SIZE UC-PRESENT)
|
||||
(READ-BDF FILL-FONT :MCCS-ONLY T))
|
||||
(SETQ FILL-FONT FONT))
|
||||
((NOT (TYPEP FILL-FONT 'BDF-FONT))
|
||||
(ERROR "Element of FILL-FROM (~S) is not a BDF-FONT, nor string, nor pathname."
|
||||
FILL-FONT)))
|
||||
(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 (BIT (AREF UCHAR-PRESENT (LRSH V 8))
|
||||
(LOGAND V 255))))
|
||||
(SETF (BIT (AREF UCHAR-PRESENT (LRSH V 8))
|
||||
(LOGAND V 255))
|
||||
1)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"What other bookkeping of BASE-FONT needs to be done when adding a glyph? Any?")
|
||||
|
||||
(PUSH GL (BF-GLYPHS BASE-FONT)))))
|
||||
BASE-FONT))
|
||||
|
||||
(DEFUN GET-CHARS-PRESENT (BFONT) (IL:* IL:\; "Edited 16-Nov-2025 17:52 by mth")
|
||||
(IL:* IL:\; "Edited 14-Nov-2025 16:40 by mth")
|
||||
(UNLESS (TYPEP BFONT 'BDF-FONT)
|
||||
(ERROR "BFONT is not a BDF-FONT."))
|
||||
(LET ((UCHAR-PRESENT (MAKE-ARRAY 256 :INITIAL-CONTENTS (LOOP :FOR I :FROM 0 :TO 255 :COLLECT
|
||||
(MAKE-ARRAY 256 :ELEMENT-TYPE
|
||||
'BIT :INITIAL-ELEMENT 0)))))
|
||||
(LOOP :FOR GL :IN (BF-GLYPHS BFONT)
|
||||
:WITH V :DO (SETQ V (GLYPH-ENCODING GL))
|
||||
(WHEN (AND (LISTP V)
|
||||
(EQ (FIRST V)
|
||||
-1))
|
||||
(SETQ V (OR (SECOND V)
|
||||
-1)))
|
||||
(WHEN (UTOMCODE? V)
|
||||
(SETF (BIT (AREF UCHAR-PRESENT (LRSH V 8))
|
||||
(LOGAND V 255))
|
||||
1)))
|
||||
UCHAR-PRESENT))
|
||||
|
||||
(DEFUN GET-FAMILY-FACE-SIZE-FROM-NAME (FONTNAME) (IL:* IL:\; "Edited 18-Nov-2025 15:15 by mth")
|
||||
(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)
|
||||
(UNLESS (STRINGP FONTNAME)
|
||||
(IL:\\ILLEGAL.ARG FONTNAME))
|
||||
(FLET ((PARSE-P-SIZE (SZSTR)
|
||||
(COND
|
||||
((ZEROP (LENGTH SZSTR))
|
||||
-1)
|
||||
((PARSE-INTEGER SZSTR :JUNK-ALLOWED T))
|
||||
(T -1))))
|
||||
(DESTRUCTURING-BIND (FOUNDRY FAMILY WEIGHT SLANT EXPANSION ADD¬STYLE¬NAME PIXEL¬SIZE
|
||||
POINT¬SIZE RESOLUTION¬X RESOLUTION¬Y SPACING AVERAGE¬WIDTH
|
||||
CHARSET¬REGISTRY CHARSET¬ENCODING)
|
||||
(SPLIT-FONT-NAME FONTNAME)
|
||||
|
||||
(IL:* IL:|;;| "Now, parse pieces as XLFD format")
|
||||
|
||||
(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)
|
||||
(#\S . COMPRESSED)
|
||||
(#\C . COMPRESSED)))))
|
||||
'REGULAR)) (IL:* IL:\;
|
||||
(#\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")
|
||||
(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))))))
|
||||
(WHEN (AND (EQ WEIGHT EXPANSION)
|
||||
(EQ EXPANSION 'BOLD))
|
||||
(SETQ EXPANSION 'REGULAR))
|
||||
(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 :EXPANSION
|
||||
EXPANSION :ADD¬STYLE¬NAME ADD¬STYLE¬NAME :PIXEL¬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 GLYPHS-BY-CHARSET (FONT &OPTIONAL MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING)
|
||||
(IL:* IL:\; "Edited 6-Nov-2025 18:11 by mth")
|
||||
@@ -509,15 +616,25 @@
|
||||
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 18-Nov-2025 19:39 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)
|
||||
(PROPS PROPS-COMPLETE CHARS-COUNT FONT-COMPLETE FONT POS KEY V VV LINE ITEMS GL XLFD (NGLYPHS
|
||||
0)
|
||||
(UCHAR-PRESENT (MAKE-ARRAY 256 :INITIAL-CONTENTS (LOOP :FOR I :FROM 0 :TO 255 :COLLECT
|
||||
(MAKE-ARRAY 256 :ELEMENT-TYPE
|
||||
'BIT :INITIAL-ELEMENT 0))))
|
||||
(*PACKAGE* (FIND-PACKAGE "BDF")))
|
||||
|
||||
(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
|
||||
|
||||
@@ -542,7 +659,9 @@
|
||||
(COND
|
||||
((EQ KEY 'FONT)
|
||||
(SETF (BF-NAME FONT)
|
||||
LINE))
|
||||
LINE)
|
||||
(SETF (BF-XLFD FONT)
|
||||
(GET-FAMILY-FACE-SIZE-FROM-NAME LINE)))
|
||||
(T
|
||||
(SETQ ITEMS (READ-DELIMITED-LIST-FROM-STRING LINE))
|
||||
(CASE KEY
|
||||
@@ -609,38 +728,61 @@
|
||||
(ERROR "Invalid BDF file - CHARS count (~A) is invalid or missing."
|
||||
NGLYPHS))
|
||||
(SETF (BF-GLYPHS FONT)
|
||||
(LOOP :REPEAT NGLYPHS :COLLECT
|
||||
(PROG1 (SETQ GL (READ-GLYPH FILE-STREAM FONT))
|
||||
(LOOP :REPEAT NGLYPHS :NCONC
|
||||
(PROGN (SETQ GL (READ-GLYPH FILE-STREAM FONT))
|
||||
(SETQ V (GLYPH-ENCODING GL))
|
||||
(WHEN (AND (LISTP V)
|
||||
(EQ (FIRST V)
|
||||
-1))
|
||||
(SETQ V (OR (SECOND V)
|
||||
-1)))
|
||||
(COND
|
||||
((EQ V -1)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Any GLYPH with ENCODING of -1 is taken as the SLUG glyph. If multiple, the last applies.")
|
||||
(IL:* IL:|;;|
|
||||
"Any GLYPH with ENCODING of -1 will be ignored.")
|
||||
|
||||
(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))))))
|
||||
NIL)
|
||||
((UTOMCODE? V)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Need to change this based on the CHARSET¬REGISTRY of the XLFD")
|
||||
|
||||
(SETF (BIT (AREF UCHAR-PRESENT (LRSH V 8))
|
||||
(LOGAND V 255))
|
||||
1)
|
||||
(LIST GL))
|
||||
(T NIL))))))
|
||||
(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-EXPANSION XLFD)))
|
||||
(VALUES FONT (XLFD-FAMILY XLFD)
|
||||
(XLFD-WEIGHT XLFD)
|
||||
(XLFD-SLANT XLFD)
|
||||
(XLFD-EXPANSION XLFD)
|
||||
(LIST (FIRST (BF-SIZE FONT))
|
||||
(XLFD-PIXEL¬SIZE XLFD)
|
||||
(XLFD-POINT¬SIZE XLFD))
|
||||
UCHAR-PRESENT))))
|
||||
|
||||
(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 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 +819,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)
|
||||
@@ -762,10 +904,10 @@
|
||||
|
||||
(LIST NIL NAME))))
|
||||
|
||||
(DEFUN WRITE-BDF-TO-DISPLAYFONT-FILES (BDFONT DEST-DIR &KEY FAMILY SIZE FACE ROTATION DEVICE
|
||||
(CHAR-SETS T)
|
||||
(DEFUN WRITE-BDF-TO-DISPLAYFONT-FILES (BDFONT DEST-DIR &KEY FAMILY SIZE FACE ROTATION DEVICE
|
||||
MAP-UNKNOWN-TO-PRIVATE WRITE-UNMAPPED
|
||||
RAW-UNICODE-MAPPING)
|
||||
RAW-UNICODE-MAPPING (CHAR-SETS T))
|
||||
(IL:* IL:\; "Edited 18-Nov-2025 15:37 by mth")
|
||||
(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")
|
||||
@@ -788,40 +930,76 @@
|
||||
(<= 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))
|
||||
(LET ((XLFD (BF-XLFD BDFONT)))
|
||||
(SETQ FAMILY (OR FAMILY (XLFD-FAMILY XLFD)))
|
||||
(WHEN RAW-UNICODE-MAPPING
|
||||
(SETQ FAMILY (IL:\\FONTSYMBOL (CONCATENATE 'STRING "RAW-" (STRING FAMILY)))))
|
||||
(SETQ FACE (OR FACE (LIST (XLFD-WEIGHT XLFD)
|
||||
(XLFD-SLANT XLFD)
|
||||
(XLFD-EXPANSION 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))))
|
||||
(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.")
|
||||
(IL:* IL:|;;| "These correspond to the charsets ACTUALLY written.")
|
||||
|
||||
(IL:* IL:|;;|
|
||||
(IL:* IL:|;;|
|
||||
"UNMAPPEDGLYPHS are never written. (Unicode encoding is > xFFFF, or encoding low byte is FF)")
|
||||
|
||||
(VALUES FONTDESC CSETS UNMAPPED-FONTDESC UNICODE-CSETS UNMAPPEDGLYPHS))))
|
||||
(VALUES FONTDESC CSETS UNMAPPED-FONTDESC UNICODE-CSETS UNMAPPEDGLYPHS))))
|
||||
|
||||
(DEFUN WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE (BDFONT DEST-DIR &KEY FAMILY SIZE FACE ROTATION DEVICE
|
||||
&AUX FULLFILENAME)
|
||||
(IL:* IL:\; "Edited 18-Nov-2025 15:37 by mth")
|
||||
(IL:* IL:\; "Edited 16-Nov-2025 17:32 by mth")
|
||||
(UNLESS (TYPEP BDFONT 'BDF-FONT)
|
||||
(ERROR "Not a BDF-FONT: ~S ~%" BDFONT))
|
||||
(LET ((XLFD (BF-XLFD BDFONT)))
|
||||
(SETQ FAMILY (OR FAMILY (XLFD-FAMILY XLFD)))
|
||||
(SETQ FACE (OR FACE (LIST (XLFD-WEIGHT XLFD)
|
||||
(XLFD-SLANT XLFD)
|
||||
(XLFD-EXPANSION 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))))
|
||||
(MULTIPLE-VALUE-BIND (FONTDESC CSETS)
|
||||
(BDF-TO-FONTDESCRIPTOR BDFONT FAMILY SIZE FACE ROTATION DEVICE)
|
||||
(SETQ FULLFILENAME (MEDLEYFONT.WRITE.FONT FONTDESC (MEDLEYFONT.FILENAME FONTDESC NIL
|
||||
NIL DEST-DIR)))
|
||||
|
||||
(IL:* IL:|;;| "These correspond to the charsets ACTUALLY written.")
|
||||
|
||||
(VALUES FULLFILENAME FONTDESC CSETS))))
|
||||
(IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY
|
||||
|
||||
(IL:FILESLOAD (IL:SYSLOAD)
|
||||
@@ -833,8 +1011,8 @@
|
||||
)
|
||||
|
||||
(DEFINE-FILE-ENVIRONMENT "READ-BDF" :PACKAGE (DEFPACKAGE "BDF" (:USE "XCL" "LISP")
|
||||
(:EXPORT "READ-BDF"
|
||||
"WRITE-BDF-TO-DISPLAYFONT-FILES")
|
||||
(:EXPORT "READ-BDF" "BUILD-COMPOSITE"
|
||||
"WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE")
|
||||
(:IMPORT-FROM "IL" "BITBLT" "BITMAPCREATE"
|
||||
"BITMAPHEIGHT" "BITMAPWIDTH" "BLACKSHADE"
|
||||
"BLTSHADE" "BOLD" "COMPRESSED"
|
||||
@@ -842,16 +1020,20 @@
|
||||
"FONTP" "FONTPROP" "INPUT" "ITALIC"
|
||||
"LIGHT" "LRSH" "MEDIUM" "REGULAR" "TCONC"
|
||||
"UTOMCODE" "UTOMCODE?"
|
||||
"WRITESTRIKEFONTFILE"))
|
||||
"WRITESTRIKEFONTFILE"
|
||||
"MEDLEYFONT.FILENAME"
|
||||
"MEDLEYFONT.WRITE.FONT"))
|
||||
:READTABLE "XCL"
|
||||
:COMPILER :COMPILE-FILE)
|
||||
|
||||
(IL:PUTPROPS IL:READ-BDF IL:DATABASE IL:NO)
|
||||
(IL:PUTPROPS IL:READ-BDF IL:COPYRIGHT (IL:NONE))
|
||||
(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 (3325 11890 (BDF-TO-CHARSETINFO 3325 . 11890)) (11892 18310 (BDF-TO-FONTDESCRIPTOR
|
||||
11892 . 18310)) (18312 21261 (BUILD-COMPOSITE 18312 . 21261)) (21263 22332 (GET-CHARS-PRESENT 21263 .
|
||||
22332)) (22334 26224 (GET-FAMILY-FACE-SIZE-FROM-NAME 22334 . 26224)) (26226 33656 (GLYPHS-BY-CHARSET
|
||||
26226 . 33656)) (33658 35083 (PACKFILENAME.STRING 33658 . 35083)) (35085 44000 (READ-BDF 35085 . 44000
|
||||
)) (44002 44325 (READ-DELIMITED-LIST-FROM-STRING 44002 . 44325)) (44327 50925 (READ-GLYPH 44327 .
|
||||
50925)) (50927 51668 (SPLIT-FONT-NAME 50927 . 51668)) (51670 56008 (WRITE-BDF-TO-DISPLAYFONT-FILES
|
||||
51670 . 56008)) (56010 57596 (WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE 56010 . 57596)))))
|
||||
IL:STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
Reference in New Issue
Block a user