Added new module READ-BDF. (#1811)
* Added new module READ-BDF. This will parse a bdf font file into a BDF::BDF-FONT structure. It does NOT create (convert into) an IL:FONTDESCRIPTOR instance. Minimal error checking! * Remove work-around for bug in CL:READ-FROM-STRING that is fixed in PR #1833
This commit is contained in:
Matt Heffron
GitHub
219
lispusers/READ-BDF
Normal file
219
lispusers/READ-BDF
Normal file
@@ -0,0 +1,219 @@
|
||||
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "BDF" ( USE "XCL" "LISP") ( EXPORT "READ-BDF")) READTABLE
|
||||
"XCL" BASE 10)
|
||||
|
||||
(IL:FILECREATED "23-Sep-2024 12:38:25" IL:{LU}READ-BDF.\;2 12260
|
||||
|
||||
:EDIT-BY "mth"
|
||||
|
||||
:CHANGES-TO (IL:FUNCTIONS READ-BDF READ-GLYPH)
|
||||
|
||||
:PREVIOUS-DATE "22-Aug-2024 20:54:00" IL:{LU}READ-BDF.\;1)
|
||||
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:READ-BDFCOMS)
|
||||
|
||||
(IL:RPAQQ IL:READ-BDFCOMS ((IL:STRUCTURES BDF-FONT GLYPH)
|
||||
(IL:FUNCTIONS READ-BDF READ-DELIMITED-LIST-FROM-STRING READ-GLYPH)
|
||||
(FILE-ENVIRONMENTS "READ-BDF")))
|
||||
|
||||
(DEFSTRUCT (BDF-FONT (:CONC-NAME "BF-"))
|
||||
(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))
|
||||
|
||||
(DEFSTRUCT GLYPH
|
||||
(NAME NIL :TYPE STRING)
|
||||
ENCODING SWIDTH DWIDTH SWIDTH1 DWIDTH1 VVECTOR BBW BBH BBXOFF0 BBYOFF0 BITMAP)
|
||||
|
||||
(DEFUN READ-BDF (PATH) (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")
|
||||
(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)
|
||||
(*PACKAGE* (FIND-PACKAGE "BDF")))
|
||||
(WITH-OPEN-FILE
|
||||
(FILE-STREAM PATH :ELEMENT-TYPE 'CHARACTER :DIRECTION :INPUT)
|
||||
(UNLESS (STRING-EQUAL "STARTFONT" (READ FILE-STREAM))
|
||||
(ERROR "Invalid BDF file - must begin with STARTFONT."))
|
||||
|
||||
(IL:* IL:|;;| "ignore the file format version number")
|
||||
|
||||
(READ-LINE FILE-STREAM)
|
||||
(SETQ FONT (MAKE-BDF-FONT))
|
||||
(LOOP
|
||||
:UNTIL FONT-COMPLETE :DO (SETQ LINE (READ-LINE FILE-STREAM))
|
||||
(WHEN LINE (IL:* IL:\; "Ignore blank lines")
|
||||
(MULTIPLE-VALUE-SETQ (KEY POS)
|
||||
(READ-FROM-STRING LINE))
|
||||
(UNLESS (MEMBER KEY '(COMMENT CONTENTVERSION))
|
||||
(WHEN (<= POS (LENGTH LINE))
|
||||
(SETQ LINE (SUBSEQ LINE POS)))
|
||||
(SETQ ITEMS (READ-DELIMITED-LIST-FROM-STRING LINE))
|
||||
(CASE KEY
|
||||
(FONT (SETF (BF-NAME FONT)
|
||||
LINE))
|
||||
(METRICSSET (IF (AND (INTEGERP (SETQ V (FIRST ITEMS)))
|
||||
(<= 0 V 2))
|
||||
(SETF (BF-METRICSSET FONT)
|
||||
V)
|
||||
(ERROR
|
||||
"Invalid BDF file - METRICSSET (~A) is invalid or out of range."
|
||||
V)))
|
||||
(SIZE (SETF (BF-SIZE FONT)
|
||||
ITEMS))
|
||||
(FONTBOUNDINGBOX (SETF (BF-BOUNDINGBOX FONT)
|
||||
ITEMS))
|
||||
(SWIDTH (SETF (BF-SWIDTH FONT)
|
||||
ITEMS))
|
||||
(DWIDTH (SETF (BF-DWIDTH FONT)
|
||||
ITEMS))
|
||||
(SWIDTH1 (SETF (BF-SWIDTH1 FONT)
|
||||
ITEMS))
|
||||
(DWIDTH1 (SETF (BF-DWIDTH1 FONT)
|
||||
ITEMS))
|
||||
(VVECTOR (SETF (BF-VVECTOR FONT)
|
||||
ITEMS))
|
||||
(STARTPROPERTIES
|
||||
(IF (AND (INTEGERP (SETQ V (FIRST ITEMS)))
|
||||
(PLUSP V))
|
||||
(SETQ PROPS (LOOP :UNTIL PROPS-COMPLETE :APPEND
|
||||
(WITH-INPUT-FROM-STRING
|
||||
(SI (SETQ LINE (READ-LINE FILE-STREAM)))
|
||||
(UNLESS (SETQ PROPS-COMPLETE
|
||||
(STRING-EQUAL "ENDPROPERTIES"
|
||||
(STRING-TRIM '(#\Space #\Tab)
|
||||
LINE)))
|
||||
(SETQ KEY (READ SI))
|
||||
(IF (AND KEY (SYMBOLP KEY)
|
||||
(SETQ VV (READ SI))
|
||||
(OR (STRINGP VV)
|
||||
(INTEGERP VV)))
|
||||
(LIST (INTERN (STRING KEY)
|
||||
"KEYWORD")
|
||||
VV)
|
||||
(ERROR
|
||||
"Invalid BDF file - malformed PROPERTY (~A)."
|
||||
LINE))))))
|
||||
(ERROR
|
||||
"Invalid BDF file - STARTPROPERTIES count (~A) is invalid or missing."
|
||||
V))
|
||||
(IF (EQL V (SETQ VV (/ (LENGTH PROPS)
|
||||
2)))
|
||||
(SETF (BF-PROPERTIES FONT)
|
||||
PROPS)
|
||||
(ERROR
|
||||
"Invalid BDF file - STARTPROPERTIES count (~D) does not match actual (~D)."
|
||||
V VV)))
|
||||
(CHARS
|
||||
(SETQ NGLYPHS (FIRST ITEMS))
|
||||
(UNLESS (AND NGLYPHS (INTEGERP NGLYPHS)
|
||||
(PLUSP NGLYPHS))
|
||||
(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))))
|
||||
(ENDFONT (SETQ FONT-COMPLETE T))))))
|
||||
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-Sep-2024 12:38 by mth")
|
||||
(IL:* IL:\; "Edited 22-Aug-2024 20:53 by mth")
|
||||
(IL:* IL:\; "Edited 21-Aug-2024 01:10 by mth")
|
||||
(LET ((GLYPH (MAKE-GLYPH :SWIDTH (COPY-LIST (BF-SWIDTH FONT))
|
||||
:DWIDTH
|
||||
(COPY-LIST (BF-DWIDTH FONT))
|
||||
:SWIDTH1
|
||||
(COPY-LIST (BF-SWIDTH1 FONT))
|
||||
:DWIDTH1
|
||||
(COPY-LIST (BF-DWIDTH1 FONT))
|
||||
:VVECTOR
|
||||
(COPY-LIST (BF-VVECTOR FONT))))
|
||||
CHAR-COMPLETE LINE ITEMS V KEY POS STARTED BBW BBH)
|
||||
(LOOP :UNTIL CHAR-COMPLETE :DO (SETQ LINE (READ-LINE FILE-STREAM))
|
||||
(WHEN LINE (IL:* IL:\; "Ignore blank lines")
|
||||
(MULTIPLE-VALUE-SETQ (KEY POS)
|
||||
(READ-FROM-STRING LINE))
|
||||
(WHEN (<= POS (LENGTH LINE))
|
||||
(SETQ LINE (SUBSEQ LINE POS)))
|
||||
(SETQ ITEMS (READ-DELIMITED-LIST-FROM-STRING LINE))
|
||||
(COND
|
||||
((EQ KEY 'STARTCHAR)
|
||||
(WHEN STARTED (ERROR "Invalid BDF file - STARTCHAR inside glyph."))
|
||||
(SETF STARTED T)
|
||||
(SETF (GLYPH-NAME GLYPH)
|
||||
(STRING LINE)))
|
||||
(T (UNLESS STARTED (ERROR "Invalid BDF file - glyph has ben started."))
|
||||
(CASE KEY
|
||||
(ENCODING (SETF (GLYPH-ENCODING GLYPH)
|
||||
(IF (EQUAL -1 (FIRST ITEMS))
|
||||
ITEMS
|
||||
(FIRST ITEMS))))
|
||||
(SWIDTH (SETF (GLYPH-SWIDTH GLYPH)
|
||||
ITEMS))
|
||||
(DWIDTH (SETF (GLYPH-DWIDTH GLYPH)
|
||||
ITEMS))
|
||||
(SWIDTH1 (SETF (GLYPH-SWIDTH1 GLYPH)
|
||||
ITEMS))
|
||||
(DWIDTH1 (SETF (GLYPH-DWIDTH1 GLYPH)
|
||||
ITEMS))
|
||||
(VVECTOR (SETF (GLYPH-VVECTOR GLYPH)
|
||||
ITEMS))
|
||||
(BBX (SETF (GLYPH-BBW GLYPH)
|
||||
(SETQ BBW (FIRST ITEMS))
|
||||
(GLYPH-BBH GLYPH)
|
||||
(SETQ BBH (SECOND ITEMS))
|
||||
(GLYPH-BBXOFF0 GLYPH)
|
||||
(THIRD ITEMS)
|
||||
(GLYPH-BBYOFF0 GLYPH)
|
||||
(FOURTH ITEMS)))
|
||||
(BITMAP (LET* ((BM (IL: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)))
|
||||
(ENDCHAR (SETQ CHAR-COMPLETE T)))))))
|
||||
GLYPH))
|
||||
|
||||
(DEFINE-FILE-ENVIRONMENT "READ-BDF" :PACKAGE (DEFPACKAGE "BDF" (:USE "XCL" "LISP")
|
||||
(:EXPORT "READ-BDF"))
|
||||
:READTABLE "XCL"
|
||||
:COMPILER :COMPILE-FILE)
|
||||
(IL:PUTPROPS IL:READ-BDF IL:COPYRIGHT (IL:NONE))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL (983 6167 (READ-BDF 983 . 6167)) (6169 6492 (READ-DELIMITED-LIST-FROM-STRING 6169 .
|
||||
6492)) (6494 11972 (READ-GLYPH 6494 . 11972)))))
|
||||
IL:STOP
|
||||
BIN
lispusers/READ-BDF.DFASL
Normal file
BIN
lispusers/READ-BDF.DFASL
Normal file
Binary file not shown.
Reference in New Issue
Block a user