-
-
Notifications
You must be signed in to change notification settings - Fork 22
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
* 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
- Loading branch information
1 parent
fface7d
commit e198985
Showing
2 changed files
with
219 additions
and
0 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -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 |
Binary file not shown.