(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "BDF" (USE "XCL" "LISP") (EXPORT "READ-BDF" "BUILD-COMPOSITE"
 "WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE") (IMPORT-FROM "IL" "BITBLT" "BITMAPBIT" "BITMAPCREATE" 
"BITMAPHEIGHT" "BITMAPWIDTH" "BLACKSHADE" "BLTSHADE" "BOLD" "COMPRESSED" "CHARSETINFO" "CHARSETPROP" 
"DISPLAY" "FONTDESCRIPTOR" "FONTP" "FONTPROP" "INPUT" "ITALIC" "LIGHT" "LRSH" "MCCS" "MEDIUM" 
"REGULAR" "TCONC" "UTOMCODE?" "MEDLEYFONT.FILENAME" "MEDLEYFONT.WRITE.FONT")) READTABLE "XCL" BASE 
10)


(IL:FILECREATED " 8-Dec-2025 12:13:40" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;9|
 51309  

      :EDIT-BY "mth"

      :CHANGES-TO (IL:FUNCTIONS BDF-TO-CHARSETINFO BDF-TO-FONTDESCRIPTOR)
                  (FILE-ENVIRONMENTS "READ-BDF")

      :PREVIOUS-DATE " 8-Dec-2025 12:12:47" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;8|
)


(IL:PRETTYCOMPRINT IL:READ-BDFCOMS)

(IL:RPAQQ IL:READ-BDFCOMS

          ((IL:STRUCTURES BDF-FONT GLYPH XLFD)
           (IL:VARIABLES MAXCHARSET MAXTHINCHAR NOMAPPINGCHARSET)
           (IL:FUNCTIONS BDF-TO-CHARSETINFO BDF-TO-FONTDESCRIPTOR BUILD-COMPOSITE CHAR-PRESENT-BIT 
                  COUNT-MCHARS GLYPHS-BY-CHARSET PACKFILENAME.STRING READ-BDF 
                  READ-DELIMITED-LIST-FROM-STRING READ-GLYPH WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE 
                  XLFD-SPLIT-FONT-NAME XLFD-TO-FACE)
           (IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY (IL:FILES (IL:SYSLOAD)
                                                            IL:SYSEDIT)
                  (IL:FILES (IL:LOADCOMP)
                         IL:FONT))
           (FILE-ENVIRONMENTS "READ-BDF")
           (IL:PROP (IL:DATABASE)
                  IL:READ-BDF)))

(DEFSTRUCT (BDF-FONT
 (:CONC-NAME "BF-"))
   "Main structure to hold a parsed BDF font file"
   (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)
   (UNMAPPED¬GLYPHS NIL :TYPE LIST)
   (XLFD NIL :TYPE XLFD)
   (MCHAR-PRESENT NIL :TYPE IL:BITMAP))

(DEFSTRUCT GLYPH

   "This is an individual BDF glyph. Includes some values calculated for creating CHARSETINFO"
   (NAME NIL :TYPE STRING)
   ENCODING SWIDTH DWIDTH SWIDTH1 DWIDTH1 VVECTOR BBW BBH BBXOFF0 BBYOFF0 BITMAP
   (MCODE 0 :TYPE INTEGER)
   (WIDTH 0 :TYPE INTEGER)
   (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)
   (SETWIDTH¬NAME 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)

(DEFCONSTANT NOMAPPINGCHARSET
 (1+ MAXCHARSET))

(DEFUN BDF-TO-CHARSETINFO
 (FONT CSET SLUGWIDTH)
       (IL:* IL:\; "Edited  8-Dec-2025 12:13 by mth")


                                                      (IL:* IL:\; "Edited 30-Nov-2025 00:12 by mth")


                                                      (IL:* IL:\; "Edited 28-Nov-2025 16:37 by mth")


                                                      (IL:* IL:\; "Edited 26-Nov-2025 21:18 by mth")


                                                      (IL:* IL:\; "Edited 20-Nov-2025 12:19 by mth")


                                                      (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")


                                                      (IL:* IL:\; "Edited 30-Jan-2025 16:40 by mth")

   (LET (GBCS CSGLYPHS CSLIMITS SW)
        (UNLESS (AND (INTEGERP CSET)
                     (<= 0 CSET MAXCHARSET))
            (ERROR "Invalid Character set: ~S" CSET)

            (IL:* IL:|;;| "Can we get here? I think not!!")


            (SETQ CSET 0))
        (COND
           ((LISTP FONT)

            (IL:* IL:|;;| 

            "Assuming that FONT is already the LIST of ALIST form of result from GLYPHS-BY-CHARSET")


            (SETQ GBCS FONT))
           ((BDF-FONT-P FONT)

            (IL:* IL:|;;| "If passed a BDF-FONT, look only at glyphs in the mapped charsets")


            (DESTRUCTURING-SETQ (GBCS SW)
                   (GLYPHS-BY-CHARSET
 FONT)))
           (T (ERROR "Invalid FONT: ~S" FONT)))
        (UNLESS (AND (INTEGERP SLUGWIDTH)
                     (PLUSP SLUGWIDTH))
            (IF (AND (INTEGERP SW)
                     (PLUSP SW))
                (SETQ SLUGWIDTH SW)
                (ERROR "Invalid SLUGWIDTH: ~D" SLUGWIDTH)))
        (WHEN (SETQ CSGLYPHS (SECOND (ASSOC CSET GBCS)))
            (LET ((TOTAL-WIDTH 0)
                  (ASCENT 0)
                  (DESCENT 0)
                  (FIRSTCHAR MOST-POSITIVE-FIXNUM)
                  (LASTCHAR MOST-NEGATIVE-FIXNUM)
                  (CSINFO (IL:|create|
 CHARSETINFO
                                 IL:CHARSETNO IL:_ CSET))
                  (IMAGEWIDTHS (IL:\\CREATECSINFOELEMENT))
                  (DLEFT 0)
                  GLYPHS-LIMITS BMAP OFFSETS HEIGHT WIDTHS)
                 (CHARSETPROP CSINFO 'IL:CSCHARENCODING 'MCCS)
                 (LOOP :FOR XGL :IN CSGLYPHS :DO (LET* ((MCODE (CAR XGL))
                                                        (GL (CDR XGL))
                                                        (GWIDTH (GLYPH-WIDTH GL))
                                                        (ASC (GLYPH-ASCENT GL))
                                                        (DSC (GLYPH-DESCENT GL)))

                                 (IL:* IL:|;;| "It's possible that ALL glyphs in the character set are above the baseline. In that case, the GLYPH-DESCENT calculated by READ-GLYPH will not give a useful value, since it is >= 0.  Investigate correcting this.")


                                                       (IL:* IL:|;;| 

                                                       "Is the above statement actually true?")


                                                       (SETQ FIRSTCHAR (MIN FIRSTCHAR MCODE))
                                                       (SETQ LASTCHAR (MAX LASTCHAR MCODE))
                                                       (INCF TOTAL-WIDTH GWIDTH)
                                                       (SETQ ASCENT (MAX ASCENT ASC))
                                                       (SETQ DESCENT (MAX DESCENT DSC))))
                 (IL:|replace|
 (CHARSETINFO IL:CHARSETASCENT) IL:|of|
 CSINFO IL:|with|
 ASCENT)
                 (IL:|replace|
 (CHARSETINFO IL:CHARSETDESCENT) IL:|of|
 CSINFO IL:|with|
 DESCENT)
                 (SETQ OFFSETS (IL:|fetch|
 (CHARSETINFO IL:OFFSETS) IL:|of|
 CSINFO))

                 (IL:* IL:|;;| 

               "Initialize the offsets to the TOTAL-WIDTH (without the SLUG. It will be added later)")


                 (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 
                                                                                  IMAGEWIDTHS I 
                                                                                  SLUGWIDTH))
                 (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. ")


                 (IL:* IL:|;;| " From \\READSTRIKEFONTFILE, so -ve DESCENT is possible?")


                 (SETQ HEIGHT (+ ASCENT DESCENT))
                 (SETQ BMAP (BITMAPCREATE (+ TOTAL-WIDTH SLUGWIDTH)
                                   HEIGHT 1))
                 (IL:|replace|
 (CHARSETINFO IL:CHARSETBITMAP) IL:|of|
 CSINFO IL:|with|
 BMAP)
                 (LOOP :FOR XGL :IN CSGLYPHS :WITH GL :WITH GLBM :WITH GLW :WITH MCODE :DO
                       (SETQ MCODE (CAR XGL))
                       (SETQ GL (CDR XGL))
                       (SETQ GLBM (GLYPH-BITMAP GL))
                       (SETQ GLW (GLYPH-WIDTH GL))
                       (WHEN GLBM

                           (IL:* IL:|;;| "Empty bitmap, nothing to copy.")


                           (BITBLT GLBM 0 0 BMAP (+ DLEFT (MAX 0 (GLYPH-BBXOFF0 GL)))
                                  (+ DESCENT (GLYPH-BBYOFF0 GL))
                                  (BITMAPWIDTH GLBM)
                                  (BITMAPHEIGHT GLBM)
                                  'INPUT
                                  'IL:REPLACE))
                       (IL:\\FSETOFFSET OFFSETS MCODE DLEFT)
                       (IL:\\FSETOFFSET IMAGEWIDTHS MCODE GLW)
                       (IL:\\FSETOFFSET WIDTHS MCODE (FIRST (GLYPH-DWIDTH GL)))
                       (INCF DLEFT GLW))

                 (IL:* IL:|;;| "Now make a slug (block)")


                 (BLTSHADE BLACKSHADE BMAP (1+ TOTAL-WIDTH)
                        0
                        (1- SLUGWIDTH)
                        (+ ASCENT DESCENT)
                        'IL:REPLACE)
                 CSINFO))))

(DEFUN BDF-TO-FONTDESCRIPTOR
 (BDFONT FAMILY SIZE FACE ROTATION DEVICE)

                                                      (IL:* IL:\; "Edited  8-Dec-2025 12:11 by mth")


                                                      (IL:* IL:\; "Edited  2-Dec-2025 16:10 by mth")


                                                      (IL:* IL:\; "Edited 30-Nov-2025 15:59 by mth")


                                                      (IL:* IL:\; "Edited 28-Nov-2025 18:03 by mth")


                                                      (IL:* IL:\; "Edited 20-Nov-2025 12:46 by mth")


                                                      (IL:* IL:\; "Edited  5-Nov-2025 16:09 by mth")


                                                      (IL:* IL:\; "Edited 21-Apr-2025 16:03 by mth")


                                                      (IL:* IL:\; "Edited 30-Jan-2025 21:27 by mth")


   (IL:* IL:|;;| "Check valid required argument")


   (WHEN (BDF-FONT-P BDFONT)
       (WHEN (FONTP FAMILY)
           (RETURN-FROM BDF-TO-FONTDESCRIPTOR (BDF-TO-FONTDESCRIPTOR
 BDFONT (FONTPROP FAMILY
                                                                                   'IL:FAMILY)
                                                     (OR SIZE (FONTPROP FAMILY 'IL:SIZE))
                                                     (OR FACE (FONTPROP FAMILY 'IL:FACE))
                                                     (OR ROTATION (FONTPROP FAMILY 'IL:ROTATION))
                                                     (OR DEVICE (FONTPROP FAMILY 'IL:DEVICE)))))
       (WHEN (CONSP FAMILY)                                  (IL:* IL:\; 

                                                             "Because (LISTP NIL) == T !!!")


           (IL:* IL:|;;| "Assume this is a FONTSPEC.")


           (RETURN-FROM BDF-TO-FONTDESCRIPTOR (BDF-TO-FONTDESCRIPTOR
 BDFONT (IL:|fetch|
 (IL:FONTSPEC
                                                                                         IL:FSFAMILY)
                                                                               IL:|of|
 FAMILY)
                                                     (OR SIZE (IL:|fetch|
 (IL:FONTSPEC IL:FSSIZE)
                                                                 IL:|of|
 FAMILY))
                                                     (OR FACE (IL:|fetch|
 (IL:FONTSPEC IL:FSFACE)
                                                                 IL:|of|
 FAMILY)
                                                         'IL:MRR)
                                                     (OR ROTATION (IL:|fetch|
 (IL:FONTSPEC 
                                                                                     IL:FSROTATION)
                                                                     IL:|of|
 FAMILY)
                                                         0)
                                                     (OR DEVICE (IL:|fetch|
 (IL:FONTSPEC IL:FSDEVICE)
                                                                   IL:|of|
 FAMILY)
                                                         'DISPLAY))))
       (LET ((XLFD (BF-XLFD BDFONT))
             FONTDESC GBCSL CHARSETS SLUGWIDTH)
            (SETQ FAMILY (IL:\\FONTSYMBOL (OR FAMILY (XLFD-FAMILY XLFD))))
            (SETQ FACE (OR FACE (XLFD-TO-FACE
 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))))
            (COND
               ((NULL ROTATION)
                (SETQ ROTATION 0))
               ((NOT (AND (IL:SMALLP ROTATION)
                          (>= ROTATION 0)))
                (IL:\\ILLEGAL.ARG ROTATION)))
            (SETQ DEVICE (COND
                            ((OR (NULL DEVICE)
                                 (EQ DEVICE T))
                             'DISPLAY)
                            ((SYMBOLP DEVICE)

                             (IL:* IL:|;;| 

                            "This PROBABLY isn't a good assumption... BUT it's a very unlikely case.")


                             (IL:* IL:|;;| 

   "Maybe wrong case or package, but we bet it's OK and defer expensive coercion until we've failed.")


                             DEVICE)
                            ((STRINGP DEVICE)
                             (INTERN (STRING-UPCASE DEVICE)
                                    "IL"))
                            (T (IL:\\ILLEGAL.ARG DEVICE))))
            (SETQ FACE (IL:\\FONTFACE (OR FACE (XLFD-TO-FACE
 XLFD)
                                          'IL:MRR)
                              NIL DEVICE))
            (DESTRUCTURING-SETQ (GBCSL SLUGWIDTH)
                   (GLYPHS-BY-CHARSET
 BDFONT))
            (UNLESS SLUGWIDTH

                (IL:* IL:|;;| 

               "If GLYPHS-BY-CHARSET didn't determine the SLUGWIDTH, use 60% of the SIZE, at least 1")


                (SETQ SLUGWIDTH (MAX 1 (ROUND (* 0.6 SIZE)))))
            (WHEN GBCSL
                (SETQ FONTDESC
                      (IL:|create|
 FONTDESCRIPTOR
                             IL:FONTDEVICE IL:_ DEVICE
                             IL:FONTFAMILY IL:_ FAMILY
                             IL:FONTSIZE IL:_ SIZE
                             IL:FONTFACE IL:_ FACE
                             IL:|\\SFAscent| IL:_ 0
                             IL:|\\SFDescent| IL:_ 0
                             IL:|\\SFHeight| IL:_ 0
                             IL:ROTATION IL:_ ROTATION
                             IL:FONTDEVICESPEC IL:_ (LIST FAMILY SIZE FACE ROTATION DEVICE)
                             IL:FONTSLUGWIDTH IL:_ SLUGWIDTH
                             IL:FONTCHARENCODING IL:_ 'MCCS))
                (SETQ CHARSETS (LOOP :FOR CS :IN GBCSL :WITH CSET :WITH CSINFO :NCONC
                                     (WHEN (<= 0 (SETQ CSET (FIRST CS))
                                               MAXCHARSET)
                                         (SETQ CSINFO (BDF-TO-CHARSETINFO
 GBCSL CSET (1+ SLUGWIDTH)))
                                         (IL:\\INSTALLCHARSETINFO FONTDESC CSINFO CSET)
                                         (LIST CSET)))))
            (LIST FONTDESC CHARSETS))))

(DEFUN BUILD-COMPOSITE
 (FONTS &KEY VERBOSE)
           (IL:* IL:\; "Edited  1-Dec-2025 23:07 by mth")


                                                      (IL:* IL:\; "Edited 30-Nov-2025 12:32 by mth")


                                                      (IL:* IL:\; "Edited 26-Nov-2025 21:23 by mth")


                                                      (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* ((BASE-FONT (FIRST (SETQ FONTS (IL:MKLIST FONTS))))
          (FILL-FROM (REST FONTS))
          MCHAR-PRESENT CHAR-COUNT FONT)
         (COND
            ((OR (STRINGP BASE-FONT)
                 (PATHNAMEP BASE-FONT))
             (UNLESS (IL:INFILEP BASE-FONT)
                 (ERROR "Initial font file ~S doesn't exist or is unreadable." (NAMESTRING BASE-FONT)
                        ))
             (WHEN VERBOSE
                 (FORMAT *STANDARD-OUTPUT* "~&Loading initial font file: ~A~%" (NAMESTRING BASE-FONT)
                        ))
             (SETQ BASE-FONT (READ-BDF
 BASE-FONT :MCCS-ONLY T :VERBOSE VERBOSE)))
            ((NOT (BDF-FONT-P BASE-FONT))
             (ERROR "Initial font (~S) is not a BDF-FONT, nor string, nor pathname." BASE-FONT)))
         (WHEN VERBOSE
             (FORMAT *STANDARD-OUTPUT* "~&Initial font contains ~D MCCS characters.~%"
                    (SETQ CHAR-COUNT (COUNT-MCHARS
 BASE-FONT))))
         (SETQ MCHAR-PRESENT (BF-MCHAR-PRESENT BASE-FONT))
         (LOOP :FOR FILL-FONT :IN FILL-FROM :WITH PREV-CC :WHEN FILL-FONT :DO
               (COND
                  ((OR (STRINGP FILL-FONT)
                       (PATHNAMEP FILL-FONT))
                   (UNLESS (IL:INFILEP FILL-FONT)
                       (ERROR "Subsequent font ~S doesn't exist or is unreadable." (NAMESTRING 
                                                                                          FILL-FONT)))
                   (WHEN VERBOSE
                       (FORMAT *STANDARD-OUTPUT* "~&Loading subsequent font file: ~A~%" (NAMESTRING
                                                                                         FILL-FONT)))
                   (SETQ FILL-FONT (READ-BDF
 FILL-FONT :MCCS-ONLY T :VERBOSE VERBOSE)))
                  ((NOT (BDF-FONT-P FILL-FONT))
                   (ERROR "Subsequent font (~S) is not a BDF-FONT, nor string, nor pathname." 
                          FILL-FONT)))
               (SETQ PREV-CC CHAR-COUNT)
               (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 (CHAR-PRESENT-BIT
 MCHAR-PRESENT V)))
                         (CHAR-PRESENT-BIT
 MCHAR-PRESENT V 1)

                         (IL:* IL:|;;| 

                      "What other bookkeping of BASE-FONT needs to be done when adding a glyph? Any?")


                         (PUSH GL (BF-GLYPHS BASE-FONT))))
               (SETQ CHAR-COUNT (COUNT-MCHARS
 BASE-FONT))
               (WHEN VERBOSE
                   (FORMAT *STANDARD-OUTPUT* "~&Font ~A supplied ~D additional MCCS characters.~%"
                          (NAMESTRING FILL-FONT)
                          (- (SETQ CHAR-COUNT (COUNT-MCHARS
 BASE-FONT))
                             PREV-CC))))
         BASE-FONT))

(DEFUN CHAR-PRESENT-BIT
 (BM MCODE &OPTIONAL (NEWBIT -1 SBIT)
                            &AUX CS CC)
               (IL:* IL:\; "Edited 26-Nov-2025 09:29 by mth")

   (COND
      ((NOT (TYPEP BM 'IL:BITMAP))
       (ERROR "BM is not a BITMAP"))
      ((NOT (AND (INTEGERP MCODE)
                 (<= 0 MCODE 65535)))
       (ERROR "Invalid MCODE"))
      (SBIT (COND
               ((OR (EQL NEWBIT 1)
                    (EQ NEWBIT T))
                (SETQ NEWBIT 1))
               ((OR (EQL NEWBIT 0)
                    (NULL NEWBIT))
                (SETQ NEWBIT 0))
               (T (ERROR "Invalid NEWBIT")))))
   (LET ((CS (- 255 (LRSH MCODE 8)))
         (CC (LOGAND MCODE 255)))
        (BITMAPBIT BM CC CS (AND SBIT NEWBIT))))

(DEFUN COUNT-MCHARS
 (BDFONT)
                          (IL:* IL:\; "Edited 29-Nov-2025 23:52 by mth")

   (WHEN (BDF-FONT-P BDFONT)
       (LET ((MCPBM (BF-MCHAR-PRESENT BDFONT)))
            (LOOP :FOR MC :FROM 0 :TO 65535 :COUNT (PLUSP (CHAR-PRESENT-BIT
 MCPBM MC))))))

(DEFUN GLYPHS-BY-CHARSET
 (FONT)
                       (IL:* IL:\; "Edited 30-Nov-2025 17:36 by mth")


                                                      (IL:* IL:\; "Edited 28-Nov-2025 17:24 by mth")


                                                      (IL:* IL:\; "Edited 26-Nov-2025 20:50 by mth")


                                                      (IL:* IL:\; "Edited 20-Nov-2025 12:01 by mth")


                                                      (IL:* IL:\; "Edited  6-Nov-2025 18:11 by mth")


                                                      (IL:* IL:\; "Edited  5-Nov-2025 16:18 by mth")


                                                      (IL:* IL:\; "Edited 21-Apr-2025 15:48 by mth")


                                                      (IL:* IL:\; "Edited  9-Jan-2025 11:23 by mth")

   (LET* ((NCSETS (+ MAXCHARSET 2))
          (CSETS (MAKE-ARRAY NCSETS :INITIAL-CONTENTS (LOOP :REPEAT NCSETS :COLLECT (CONS NIL))))
          SLUGWIDTH ENC MCODE CS-USED)
         (FLET ((PUT-GLYPH-IN-CHARSET-ARRAY (CODE GLYPH CSARRAY &AUX CS)
                       (TCONC (AREF CSARRAY (SETQ CS (LRSH CODE 8)))
                              (CONS (LOGAND CODE 255)
                                    GLYPH))
                       (PUSHNEW CS CS-USED :TEST #'EQL)))
               (LOOP :FOR GL :IN (BF-GLYPHS FONT)
                     :DO
                     (SETQ MCODE (GLYPH-MCODE GL))
                     (COND
                        ((AND (INTEGERP MCODE)
                              (<= 0 MCODE 65535))

                         (IL:* IL:|;;| "These assoc with the 8 bit character code within the charset")


                         (PUT-GLYPH-IN-CHARSET-ARRAY MCODE GL CSETS)

                         (IL:* IL:|;;| "Default SLUG width is width of A, in charset 0")


                         (WHEN (AND (NOT SLUGWIDTH)
                                    (ZEROP (LRSH MCODE 8))
                                    (EQL MCODE (CHAR-CODE #\A)))
                             (SETQ SLUGWIDTH (GLYPH-WIDTH GL))))
                        (T 
                           (IL:* IL:|;;| "Shouldn't happen!")


                           (ERROR "Invalid MCODE: ~A~%")))))
         (SETQ CSETS (LOOP :FOR I :IN CS-USED :NCONC (LET ((CS (CAR (AREF CSETS I))))

                                                          (IL:* IL:|;;| 

                                                          "Extract the lists from the TCONC pointers")


                                                          (SETQ CS (SORT (REMOVE-DUPLICATES
                                                                          CS :TEST #'EQUAL)
                                                                         #'< :KEY #'CAR))
                                                          (WHEN CS
                                                              (LIST (LIST I CS))))))
         (LIST (SORT CSETS #'< :KEY #'CAR)
               SLUGWIDTH)))

(DEFMACRO PACKFILENAME.STRING
 (&WHOLE WHOLE)
          (IL:* IL:\; "Edited  1-Feb-2025 23:17 by mth")

   `(IL:PACKFILENAME.STRING ,@(LOOP :FOR X :IN (CDR WHOLE)
                                    :BY
                                    #'CDDR :AS Y :IN (CDDR WHOLE)
                                    :BY
                                    #'CDDR :NCONC (LIST (COND
                                                           ((KEYWORDP X)
                                                            (LIST 'QUOTE (INTERN (STRING X)
                                                                                "IL")))
                                                           ((AND (LISTP X)
                                                                 (EQ (FIRST X)
                                                                     'QUOTE)
                                                                 (SYMBOLP (CADR X)))
                                                            (LIST 'QUOTE (INTERN (STRING (CADR X))
                                                                                "IL")))
                                                           (T 
                                                             (IL:* IL:\; "Hope for the best!")

                                                              X))
                                                        Y))))

(DEFUN READ-BDF
 (PATH &KEY VERBOSE MCCS-ONLY (EXTERNAL-FORMAT :ISO8859/1))

                                                      (IL:* IL:\; "Edited  1-Dec-2025 22:40 by mth")


                                                      (IL:* IL:\; "Edited 30-Nov-2025 11:59 by mth")


                                                      (IL:* IL:\; "Edited 28-Nov-2025 17:39 by mth")


                                                      (IL:* IL:\; "Edited 26-Nov-2025 22:47 by mth")


                                                      (IL:* IL:\; "Edited 19-Nov-2025 23:15 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
    ((NGLYPHS 0)
     (MCHAR-PRESENT (BITMAPCREATE 256 256 1))
     (*PACKAGE* (FIND-PACKAGE "BDF"))
     (MAPPED-GLYPHS (LIST NIL))
     (UNMAPPED-GLYPHS (LIST NIL))
     PROPS PROPS-COMPLETE CHARS-COUNT FONT-COMPLETE FONT POS KEY V VV LINE ITEMS GL XLFD)

    (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 :EXTERNAL-FORMAT EXTERNAL-FORMAT)
     (LOOP :WHILE (STRING-EQUAL "COMMENT" (SETQ KEY (READ FILE-STREAM)))
           :DO

           (IL:* IL:|;;| "Ignore initial COMMENT lines.")


           (READ-LINE FILE-STREAM))
     (UNLESS (STRING-EQUAL "STARTFONT" KEY)
            (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 :MCHAR-PRESENT MCHAR-PRESENT))
     (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)))
              (COND
                 ((EQ KEY 'FONT)
                  (SETF (BF-NAME FONT)
                        LINE)
                  (SETF (BF-XLFD FONT)
                        (SETQ XLFD (XLFD-SPLIT-FONT-NAME
 LINE))))
                 (T
                  (SETQ ITEMS (READ-DELIMITED-LIST-FROM-STRING
 LINE))
                  (CASE KEY
                      (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)))

                                          (IL:* IL:|;;| "As of now, COMMENTS not allowed here.")


                                          (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))
                         (LOOP :REPEAT NGLYPHS :WITH ENC :WITH MC :DO (SETQ GL (READ-GLYPH
 
                                                                                      FILE-STREAM 
                                                                                      FONT))
                               (SETQ ENC (GLYPH-ENCODING GL))
                               (WHEN (AND (LISTP ENC)
                                          (EQ (FIRST ENC)
                                              -1))
                                   (SETQ ENC (OR (SECOND ENC)
                                                 -1)))
                               (COND
                                  ((AND (OR (PLUSP (GLYPH-BBW GL))
                                            (PLUSP (FIRST (GLYPH-DWIDTH GL))))
                                        (SETQ MC (UTOMCODE? ENC)))

                                 (IL:* IL:|;;| "This glyph must have either a non-zero-width \"image\" or a non-zero-width \"escapement\", otherwise it cannot be mapped, no matter the UTOMCODE? value.")


                                   (LOOP :FOR CC :IN (IL:MKLIST MC)
                                         :WITH CGL :DO 

                                         (IL:* IL:|;;| "Copy GL if multiple MCODEs")


                                         (SETQ CGL (IF (LISTP MC)
                                                       (COPY-GLYPH GL)
                                                       GL))
                                         (SETF (GLYPH-MCODE CGL)
                                               CC)

                                         (IL:* IL:|;;| "It ought to be safe to share the bitmap")


                                         (TCONC MAPPED-GLYPHS CGL)
                                         (CHAR-PRESENT-BIT
 MCHAR-PRESENT CC 1)))
                                  (T (TCONC UNMAPPED-GLYPHS GL))))
                         (SETF (BF-GLYPHS FONT)
                               (CAR MAPPED-GLYPHS))
                         (SETF (BF-UNMAPPED¬GLYPHS FONT)
                               (CAR UNMAPPED-GLYPHS)))
                      (ENDFONT (SETQ FONT-COMPLETE T))))))))
     (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-SETWIDTH¬NAME XLFD)))
     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 26-Nov-2025 23:32 by mth")


                                                      (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")


                                                      (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)))
                  (COND
                     ((EQ KEY 'COMMENT)                      (IL:* IL:\; "Ignore COMMENT lines")

                                                             (IL:* IL:\; 

                                                            "Probably aren't \"legal\" here, anyway.")

                      )
                     ((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 not been started. STARTCHAR missing."
                                               ))
                        (SETQ ITEMS (READ-DELIMITED-LIST-FROM-STRING
 LINE))
                        (CASE KEY
                            (ENCODING (SETF (GLYPH-ENCODING GLYPH)
                                            (IF (EQL -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 (UNLESS (ZEROP (* BBW BBH))

                                        (IL:* IL:|;;| "Don't bother creating a BITMAP with no area")


                                        (LET* ((BM (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)))))))
        (SETF (GLYPH-ASCENT GLYPH)
              (+ (GLYPH-BBH GLYPH)
                 (GLYPH-BBYOFF0 GLYPH)))
        (SETF (GLYPH-DESCENT GLYPH)
              (ABS (MIN 0 (GLYPH-BBYOFF0 GLYPH))))
        (SETF (GLYPH-WIDTH GLYPH)
              (MAX (+ (MAX 0 (GLYPH-BBXOFF0 GLYPH))
                      (GLYPH-BBW GLYPH))
                   (FIRST (GLYPH-DWIDTH GLYPH))))
        GLYPH))

(DEFUN WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE
 (BDFONT DEST-DIR &KEY FAMILY SIZE FACE ROTATION DEVICE 
                                                  &AUX FULLFILENAME)

                                                      (IL:* IL:\; "Edited  2-Dec-2025 14:47 by mth")


                                                      (IL:* IL:\; "Edited 30-Nov-2025 16:03 by mth")


                                                      (IL:* IL:\; "Edited 28-Nov-2025 17:56 by mth")


                                                      (IL:* IL:\; "Edited 26-Nov-2025 21:07 by mth")


                                                      (IL:* IL:\; "Edited 16-Nov-2025 17:32 by mth")

   (UNLESS (BDF-FONT-P BDFONT)
          (ERROR "Not a BDF-FONT: ~S ~%" BDFONT))
   (DESTRUCTURING-BIND (FONTDESC CSETS)
          (BDF-TO-FONTDESCRIPTOR
 BDFONT FAMILY SIZE FACE ROTATION DEVICE)
          (UNLESS FONTDESC

              (IL:* IL:|;;| "Creation of the FONTDESCRIPTOR failed!")


              (HELP "FONTDESC IS NIL"))

          (IL:* IL:|;;| "CSETS correspond to the charsets actually present in the FONTDESC.")


          (SETQ FULLFILENAME (MEDLEYFONT.WRITE.FONT FONTDESC (MEDLEYFONT.FILENAME FONTDESC NIL NIL 
                                                                    DEST-DIR)))
          (LIST FULLFILENAME FONTDESC CSETS)))

(DEFUN XLFD-SPLIT-FONT-NAME
 (NAME)
                    (IL:* IL:\; "Edited 26-Nov-2025 09:43 by mth")


                                                      (IL:* IL:\; "Edited 23-Apr-2025 16:22 by mth")


                                                      (IL:* IL:\; "Edited 31-Jan-2025 22:20 by mth")

   (LET (PARTS (XLFD (MAKE-XLFD)))

        (IL:* IL:|;;| "First, check if it COULD be in XLFD format")


        (SETQ PARTS (IF (POSITION #\- NAME :TEST #'CHAR=)
                        (LOOP :FOR I = (IF (CHAR= #\- (ELT NAME 0))
                                           1
                                           0)
                              THEN
                              (1+ J)
                              :AS J = (POSITION #\- NAME :START I :TEST #'CHAR=)
                              :COLLECT
                              (SUBSEQ NAME I J)
                              :WHILE J)
                        (PROGN 
                               (IL:* IL:|;;| 

                               "There are no -'s, so use the NAME as the FAMILY with a NIL FOUNDRY")


                               (LIST NIL NAME))))
        (FLET ((PARSE-P-SIZE (SZSTR)
                      (COND
                         ((ZEROP (LENGTH SZSTR))
                          -1)
                         ((PARSE-INTEGER SZSTR :JUNK-ALLOWED T))
                         (T -1))))
              (DESTRUCTURING-BIND (FOUNDRY FAMILY WEIGHT SLANT SETWIDTH¬NAME ADD¬STYLE¬NAME 
                                         PIXEL¬SIZE POINT¬SIZE RESOLUTION¬X RESOLUTION¬Y SPACING 
                                         AVERAGE¬WIDTH CHARSET¬REGISTRY CHARSET¬ENCODING)
                     PARTS
                     (SETQ FAMILY (REMOVE #\Space FAMILY :TEST #'CHAR=))
                     (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 
                            :SETWIDTH¬NAME SETWIDTH¬NAME :ADD¬STYLE¬NAME ADD¬STYLE¬NAME :PIXEL¬SIZE 
                            PIXEL¬SIZE :POINT¬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 XLFD-TO-FACE
 (XLFD)
                            (IL:* IL:\; "Edited 25-Nov-2025 17:50 by mth")

   (UNLESS (TYPEP XLFD 'XLFD)
          (ERROR "Not an XLFD object: ~S ~%" XLFD))
   (LET ((WEIGHT (XLFD-WEIGHT XLFD))
         (SLANT (XLFD-SLANT XLFD))
         (EXPANSION (XLFD-SETWIDTH¬NAME XLFD)))

        (IL:* IL:|;;| "mth 11-25-2025 Brute force hackery now. This needs to be made smarter.")


        (SETQ WEIGHT (OR (AND WEIGHT (CADR (ASSOC (CHAR-UPCASE (ELT WEIGHT 0))
                                                  '((#\R MEDIUM)
                                                    (#\M MEDIUM)
                                                    (#\N MEDIUM)
                                                    (#\B BOLD)
                                                    (#\D BOLD 
                                                             (IL:* IL:\; "DemiBold => BOLD")
)
                                                    (#\L LIGHT)))))
                         'MEDIUM))
        (SETQ SLANT (OR (AND SLANT (CADR (ASSOC (CHAR-UPCASE (ELT SLANT 0))
                                                '((REGULAR)
                                                  (#\R REGULAR)
                                                  (#\I ITALIC)
                                                  (#\O ITALIC 
                                                             (IL:* IL:\; "Oblique => ITALIC")
)))))
                        'REGULAR))                           (IL:* IL:\; "Ignore other SLANTs")


        (IL:* IL:|;;| "Expansion (SETWIDTH¬NAME) has many more options than these, and they aren't 1st character unique! Apparently, there's no set of (semi-)standard names.")


        (SETQ EXPANSION (OR (AND EXPANSION (CADR (ASSOC (CHAR-UPCASE (ELT EXPANSION 0))
                                                        '((#\R REGULAR)
                                                          (#\N REGULAR)
                                                          (#\E EXPANDED 
                                                             (IL:* IL:\; 

                                              "E could be ExtraCondensed, Expanded, ExtraExpanded!!!")

                                                               )
                                                          (#\S COMPRESSED 
                                                             (IL:* IL:\; 

                                                   "S is for \"SemiCompressed\", Using \"Condensed\"")

                                                               )
                                                          (#\C COMPRESSED)))))
                            '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))
        (LIST WEIGHT SLANT EXPANSION)))
(IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY 

(IL:FILESLOAD (IL:SYSLOAD)
       IL:SYSEDIT)


(IL:FILESLOAD (IL:LOADCOMP)
       IL:FONT)
)

(DEFINE-FILE-ENVIRONMENT "READ-BDF"
 :PACKAGE (DEFPACKAGE "BDF" (:USE "XCL" "LISP")
                                                    (:EXPORT "READ-BDF" "BUILD-COMPOSITE" 
                                                           "WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE")
                                                    (:IMPORT-FROM "IL" "BITBLT" "BITMAPBIT" 
                                                           "BITMAPCREATE" "BITMAPHEIGHT" 
                                                           "BITMAPWIDTH" "BLACKSHADE" "BLTSHADE" 
                                                           "BOLD" "COMPRESSED" "CHARSETINFO" 
                                                           "CHARSETPROP" "DISPLAY" "FONTDESCRIPTOR" 
                                                           "FONTP" "FONTPROP" "INPUT" "ITALIC" 
                                                           "LIGHT" "LRSH" "MCCS" "MEDIUM" "REGULAR" 
                                                           "TCONC" "UTOMCODE?" "MEDLEYFONT.FILENAME"
                                                           "MEDLEYFONT.WRITE.FONT"))
   :READTABLE "XCL"
   :COMPILER :COMPILE-FILE)

(IL:PUTPROPS IL:READ-BDF
 IL:DATABASE
 IL:NO)
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (3116 10226 (BDF-TO-CHARSETINFO 3116 . 10226)) (10228 16847 (BDF-TO-FONTDESCRIPTOR 
10228 . 16847)) (16849 20782 (BUILD-COMPOSITE 16849 . 20782)) (20784 21533 (CHAR-PRESENT-BIT 20784 . 
21533)) (21535 21819 (COUNT-MCHARS 21535 . 21819)) (21821 24856 (GLYPHS-BY-CHARSET 21821 . 24856)) (
24858 26283 (PACKFILENAME.STRING 24858 . 26283)) (26285 35760 (READ-BDF 26285 . 35760)) (35762 36085 (
READ-DELIMITED-LIST-FROM-STRING 35762 . 36085)) (36087 43085 (READ-GLYPH 36087 . 43085)) (43087 44472 
(WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE 43087 . 44472)) (44474 46891 (XLFD-SPLIT-FONT-NAME 44474 . 46891)
) (46893 49905 (XLFD-TO-FACE 46893 . 49905)))))
IL:STOP