Compare commits
2 Commits
medley-240
...
medley-240
| Author | SHA1 | Date | |
|---|---|---|---|
|
e1989850f3 | ||
|
|
fface7d9de |
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.
@@ -1,17 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "19-Jul-2022 23:31:31"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>sources>CMLREAD.;15 12803
|
||||
(FILECREATED "23-Sep-2024 11:55:33" {DSK}<home>matt>Interlisp>medley>sources>CMLREAD.;4 12882
|
||||
|
||||
:CHANGES-TO (FNS CL:PEEK-CHAR)
|
||||
:EDIT-BY "mth"
|
||||
|
||||
:PREVIOUS-DATE "16-Aug-2021 23:42:49"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>sources>CMLREAD.;14)
|
||||
:CHANGES-TO (FNS CL:READ-FROM-STRING)
|
||||
|
||||
:PREVIOUS-DATE "16-Sep-2024 12:26:09" {DSK}<home>matt>Interlisp>medley>sources>CMLREAD.;3)
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1985-1988, 1990, 1993, 2021 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT CMLREADCOMS)
|
||||
|
||||
@@ -188,16 +184,19 @@ Copyright (c) 1985-1988, 1990, 1993, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(CL:READ-FROM-STRING
|
||||
[CL:LAMBDA (STRING &OPTIONAL EOF-ERROR-P EOF-VALUE &KEY START END PRESERVE-WHITESPACE)
|
||||
(* ; "Edited 23-Sep-2024 11:47 by mth")
|
||||
(* ; "Edited 16-Sep-2024 12:22 by mth")
|
||||
(* ; "Edited 8-Jun-90 14:15 by ymasuda")
|
||||
(LET [(STREAM (OPENSTRINGSTREAM (COND
|
||||
[END (SUBSTRING STRING 1 (IMIN END (NCHARS STRING]
|
||||
(T (MKSTRING STRING]
|
||||
(COND
|
||||
(START (SETFILEPTR STREAM START)))
|
||||
[COND
|
||||
(START (SETFILEPTR STREAM (UNFOLD START 2]
|
||||
(CL:VALUES (CL:IF PRESERVE-WHITESPACE
|
||||
(CL:READ-PRESERVING-WHITESPACE STREAM EOF-ERROR-P EOF-VALUE)
|
||||
(CL:READ STREAM EOF-ERROR-P EOF-VALUE))
|
||||
(\GETFILEPTR STREAM])
|
||||
(FOLDLO (\GETFILEPTR STREAM)
|
||||
2])
|
||||
|
||||
(CL:READ-BYTE
|
||||
[CL:LAMBDA (BINARY-INPUT-STREAM &OPTIONAL (EOF-ERRORP T)
|
||||
@@ -287,11 +286,10 @@ Copyright (c) 1985-1988, 1990, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(ADDTOVAR LAMA CL:READ-BYTE CL:READ-FROM-STRING CL:CLEAR-INPUT CL:READ-CHAR-NO-HANG CL:PEEK-CHAR
|
||||
CL:UNREAD-CHAR CL:READ-CHAR CL:READ-LINE CL:COPY-READTABLE)
|
||||
)
|
||||
(PUTPROPS CMLREAD COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1993 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2525 3510 (CL:COPY-READTABLE 2535 . 3508)) (3511 10454 (CL:READ-LINE 3521 . 4393) (
|
||||
CL:READ-CHAR 4395 . 4945) (CL:UNREAD-CHAR 4947 . 5408) (CL:PEEK-CHAR 5410 . 7704) (CL:LISTEN 7706 .
|
||||
7971) (CL:READ-CHAR-NO-HANG 7973 . 8745) (CL:CLEAR-INPUT 8747 . 8984) (CL:READ-FROM-STRING 8986 . 9741
|
||||
) (CL:READ-BYTE 9743 . 10196) (CL:WRITE-BYTE 10198 . 10452)) (11448 11921 (WITH-READER-ENVIRONMENT
|
||||
11448 . 11921)))))
|
||||
(FILEMAP (NIL (2433 3418 (CL:COPY-READTABLE 2443 . 3416)) (3419 10627 (CL:READ-LINE 3429 . 4301) (
|
||||
CL:READ-CHAR 4303 . 4853) (CL:UNREAD-CHAR 4855 . 5316) (CL:PEEK-CHAR 5318 . 7612) (CL:LISTEN 7614 .
|
||||
7879) (CL:READ-CHAR-NO-HANG 7881 . 8653) (CL:CLEAR-INPUT 8655 . 8892) (CL:READ-FROM-STRING 8894 . 9914
|
||||
) (CL:READ-BYTE 9916 . 10369) (CL:WRITE-BYTE 10371 . 10625)) (11621 12094 (WITH-READER-ENVIRONMENT
|
||||
11621 . 12094)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user