From e1989850f3a308b67cf29f93323963000ded8d4e Mon Sep 17 00:00:00 2001 From: Matt Heffron Date: Thu, 26 Sep 2024 14:08:36 -0700 Subject: [PATCH] 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 --- lispusers/READ-BDF | 219 +++++++++++++++++++++++++++++++++++++++ lispusers/READ-BDF.DFASL | Bin 0 -> 9773 bytes 2 files changed, 219 insertions(+) create mode 100644 lispusers/READ-BDF create mode 100644 lispusers/READ-BDF.DFASL diff --git a/lispusers/READ-BDF b/lispusers/READ-BDF new file mode 100644 index 00000000..fa4689c9 --- /dev/null +++ b/lispusers/READ-BDF @@ -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 diff --git a/lispusers/READ-BDF.DFASL b/lispusers/READ-BDF.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..3408119194e806ad4feb59000778d70941566178 GIT binary patch literal 9773 zcmbtaYj7Lab>3Y^#)AX7qQHnBTJ^Ykwg&?pLK!R8p04Y(mOH(2(fP_d@ zq|$mECy!5Odd_!OdmhgDw(#a z9rZisE(nmK;-=MO@44qY_jS&__nbY8d8O`PFscVYxmwg z_w3z$r=u^BjLI&`VuLf&<71EB25}wYa}&o7V_0f*Te;O;jw_!ooYiifQSj&J>Z5_E z&6`zb*HguY<+CkQbA_;>VYt4m4;?%|i!GXYjqp)ZzEaV;Nsmz!!S2zWBzC) z8875(pwhx(4Vu;rB@NVJk3!zY;G#yu83*HLB2~!Ol`TL66P*h5M$0Xp%iDSbNyDKQ z^7hAKC$rhd6(~`;rJ_I98!NHM@0W z3Aa+nd$32Og7mUxD*CV4C)&1Q{x^26>d+rDg3&<2@I&W;)JWVQJ=&8a$&@kZ#76Zd zjg&tgNF<@2)kgMvfm~10erzY4j0$uIwo_vjVkB-Coww2%T5at&d;77?J)%<;oi(k6 zMd+(WbSkh_ZQP8+QbvLqn%Kvs%_{Ar(8i|+={&s7>cGU*7C=(%}L)_YtW33RIN3q z|O;@!G-~a*pEnrpE01grm z2H;q2L8=BaLP*3yDn(5@saOQaukq{#tZ~Zr$>l^0ilnQzE)WbF$)uT}8#kUX zLXjZuxm+%%ydWON?ONCKbvmkUMLdi`P+6dIAo{uZ3diJFU%D7V^j7e{d8{4cnWvlAtRC843RArk@8$|DX-zL&b#IY(dpzP ztYH3e%>M~YI?EGlQ(vo1zn*^M$+6cnZ&Wzv({DaGc0TiFg>xbO){|owGH;bRnJ_^5EAx}xbN%Hwqu&1RySyw0N8N>q#2RWx;?+PvZlwps#OjXYS!IEl-&EE%J&kH)`1|> zIsqgqcf8`nHcr{FppxnsUL$sgP*Itclppy%(<UFRY3I_~?!U^l3aKSVv+^`D@4~&As3yXwdki+Vl zgS#4>s4Z|@*9F5yaKO*bu`dvb+B$gV&uat`Z2aWoXIP zZ9q|gxYsH6+V2(j-64MUcHz5K-0u-SRrtssJIT5F6zMd5mK*k2ZrEqH_?GkaS2j|QEHn9_i^u~Y51q)O7=!#|c%d@9z*(n|Xv(AVGP4cv&Lkx=p z;-DB2hrqAt?L7b~CZt=f?d?5i_Vw*#E-E9d6+1$R!2q11c!+$a+`8;GX$LN&lUg2? z{H7Q~)xplunhASG=!iU{IFe%{ewKt}n~Gzk&Q{1@5b=AEa7l^E3aAtITO{#0NI0d$ zRql)M->=|Tc`?FY0p3{MzS^0Qz^fI3t9=>?e7+*E#|zE*xi2_QH=L7)oRb^Q$y1GZfiw}~1=3WFGy`cNq!~y{HPQ;CjgVF# zZPkblq@55QNP9KX0mMg02M}L1(gmcOkS-wI)yQo?b`WwKkR4^0x|3Y$PRph4v|Q>= zcBw7^F|WO7dd`|VO*c8!CZfFLR9lE@Ca2m)R4X~vcA|80sy?DR$favhQM0`n~w#`F?D&q9(eC|QJ2lrJYq^8N;CT}(U4{3+L{~577wJt zT2|O&2<)85B8BiO&IuvgBiJpQI2ko2>K+7K9}EW)fgoPyXqP#Ss6mMdjy7s&`Ja?# ztVznjOHI522N2~8%#yDVVGAhM5rWCXWF^~+Pb}BemZ5QQ-Nl!ewSNzn+}w&EBP#fg zVnm}7fm6xB-L@_)Yo&0ht}J``4?&^MBXdt>1Qi5RB?l|>(#n=_$!_OKAlOoh%i5C_ zY%pB%s5B2}agRQq$)#7WpA46rm*>-;M3L1%JV9JT2UunmdwE&;tM$5Bf=VVY zLmQLnbj!&3a7lad)VX2WlDJae?7y(qt`AM7Ihiy-2PA{1t$Ozkly~odpN;-jbZ~32 zpULy*UWsThiBf!Kt&TB#xTLU5R%5l3j4;vAaqe+rCA*gu!~wAGncn!3CdEG2j^M5o@nJb$jKAL|Fk zLca6Sskbkj`*B3WIX}HR@DiP382#Pt!H@tVbU6xwA#n~X%l zOi=Cfe7pUO$d3TfI&UZPw?NvXMr?m7Ox0{fC=vmbH(H zgH)T9wX`@uwF9yi6~k1!Pu6zQFf^w%nJp5ySqgXs*--g6t|=Dy*G5&Fnc3OQ^wAyE z!)FTl$Ob*E)5B_Cp>6v3%*3odJu{~t8=E_l*2j*_ogB+zn9w%vaJ-NY{SqDi!pZeo zk;DogOzU(iB{v^E>tZM=bnh&r&wT{<6d$i~Tpr|DR`!7?ImY+&Tw2++7IYO?ZX(dd z4d`0HRgNlM3?EN_H2p*xx8Kd&oF#Z@9+1V-EiKQko6Q?^#%;yO8+6JeR_yT;4QAy% z`_uAau206Jk)Ywf=k7W(=x5}PCi3HSKsdP?`;a(t2(?M zYxg75I;hyFlQV_<_6@XuY%EKkobZ{<%G-?az954srwaL6WPlEsiI5$6$7l6t>v8Ec z;^b6vJd~=_?uIoy&?CEB`1sXN2(DmuVr<%f@;HCjnnl1RLoZr%PNf{vCc4rL)kZN$ zpckK$6i)u(^TWOkW?RWLZM1vwjZmL?L_aY$eRN{S6lF?r&gq*Lq8EO1cLi~}P#H#& z65rKChqsXTZ!pZUle2UB;fbS}Y5g}db7`ITJRPnbSbzO$O{2B%!CmFXAaVNGwlQ5Z&l}mOSz66O)(EOdxP6Oj$m%I5G9z$xE+hwK42OrTDbmphU94ddeG?H?$KI zRYok&4S9HO-oMw1J4Ls)_O+&_kau!4Y2Cmua=nj|!)7di4~VtaH!@q47NT4U(QbuZ zD1jZr{||^G9@xzlNbDctu#p9s`8=S@lQCqry;I7 zVfWryb0f?Amy?yL)nX1?*vG8>fQQDEP2XT^bG!Go+1-V_s{hKf4`~mwdX`57A^z_Dq`!KD55 ziycDn{Tnjs;`*pZyQ8x=Db!@LG5#36QT ztomJ`+^kv39lJ81etUl4)PPFCv3kjZUy$ek1xV`Ou4mf8{Kk4FLOpePJ(B|G7uGW= zV*Z51T)EF0Ngd@REKhzwQ%5-$Yt=NBULwjB)V%1yuzGlTS>0*6O!pKY;!zKal@w$` zOiBN#hKz{m%F4GBc_jg$xL#Lg;G&B|avR-7wuqZzaBSEzf;Tq9i|~QtD=uHTS1J#mC7Oy)TY8(%ys`Y=DS8Fp-h=~SeQm%8?gsu4 zE+a?$%z$p&t#m|Q#o4ThhI)y93AC+uBt?OwHcn?s;ZQaKej|TbMgYp+{zzaq3%pCD zbdXz!tG3mdO zQ-cepNKQtnKM+1N)duKYy&t~DABaZH14f9LA@ZwRDMlC5y*oaRP%Q`GoJ%Bsn3O56S2^E^A>K{oW^Qdt~(MleIP({ce`E zdX9dT%Uo0bnP;$qew9CyoUdRo>1^d%P0<-)p|kgkPML06+Aca}#_7yf(J7Noi?#GA zk@{Jnz(@P_LVnu@KK}67xSq{SPayo&rIq*U9}ZB1HY?VlF21*M;!&j#4*!bg?#r0qjAhY%fN86nehpod)UEWV7K$pTiImemA1Gvjan{-;Q}(DP*lvw7EswCY|<%6{PU5hv)}0b#&q=8`vanq2J4R=|yh+ z&rwuyi;5pr*hCZJ5Bvg1)KkSNgAw`&h~+WKxf5M(C}mTO)1(k6$|zk^SKmh0FNmM$C*E%JVRhdi2Vb{{fScAzc6f literal 0 HcmV?d00001