(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" "DISPLAY" 
"FONTDESCRIPTOR" "FONTP" "FONTPROP" "INPUT" "ITALIC" "LIGHT" "LRSH" "MCCS" "MEDIUM" "REGULAR" "TCONC" 
"UTOMCODE?" "MEDLEYFONT.FILENAME" "MEDLEYFONT.WRITE.FONT")) READTABLE "XCL" BASE 10)


(IL:FILECREATED "16-Mar-2026 16:37:31" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;22|
 58094  

      :EDIT-BY "mth"

      :CHANGES-TO (IL:FUNCTIONS READ-GLYPH READ-BDF BDF-TO-FONTDESCRIPTOR GLYPHS-BY-CHARSET 
                         WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE BDF-TO-CHARSETINFO)

      :PREVIOUS-DATE "23-Feb-2026 20:11:48" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;21|
)


(IL:PRETTYCOMPRINT IL:READ-BDFCOMS)

(IL:RPAQQ IL:READ-BDFCOMS

          ((IL:STRUCTURES BDF-FONT GLYPH XLFD)
           (IL:VARIABLES GLYPH-PROCESSING-HOOK 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))

(DEFVAR GLYPH-PROCESSING-HOOK
 NIL)

(DEFCONSTANT MAXCHARSET
 255)

(DEFCONSTANT MAXTHINCHAR
 255)

(DEFCONSTANT NOMAPPINGCHARSET
 (1+ MAXCHARSET))

(DEFUN BDF-TO-CHARSETINFO
 (FONT CSET SLUGWIDTH &KEY AS-UNICODE)

                                                      (IL:* IL:\; "Edited 16-Mar-2026 16:35 by mth")


                                                      (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 :AS-UNICODE AS-UNICODE)))
           (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)
                 (IL:CHARSETPROP CSINFO 'IL:CSCHARENCODING (IF AS-UNICODE
                                                               'IL:UNICODE
                                                               '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 &KEY AS-UNICODE)

                                                      (IL:* IL:\; "Edited 16-Mar-2026 16:16 by mth")


                                                      (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))
                                                     :AS-UNICODE AS-UNICODE)))
       (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)
                                                     :AS-UNICODE AS-UNICODE)))
       (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 :AS-UNICODE AS-UNICODE))
            (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:_ (IF AS-UNICODE
                                                          'IL:UNICODE
                                                          '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)
                                                             :AS-UNICODE AS-UNICODE))
                                         (IL:\\INSTALLCHARSETINFO FONTDESC CSINFO CSET)
                                         (LIST CSET)))))
            (LIST FONTDESC CHARSETS))))

(DEFUN BUILD-COMPOSITE
 (FONTS &KEY VERBOSE (BLOCKING T))

                                                      (IL:* IL:\; "Edited 19-Feb-2026 21:45 by mth")


                                                      (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))
             (WHEN BLOCKING (IL:BLOCK)))
            ((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 :WITH FF-NAME :WHEN FILL-FONT :DO
               (FLET ((MERGE-GLYPH (GL &AUX V)
                             (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)))
                             NIL))
                     (COND
                        ((OR (STRINGP FILL-FONT)
                             (PATHNAMEP FILL-FONT))
                         (SETQ FF-NAME (NAMESTRING FILL-FONT))
                         (UNLESS (IL:INFILEP FILL-FONT)
                                (ERROR "Subsequent font ~S doesn't exist or is unreadable." FF-NAME))
                         (WHEN VERBOSE (FORMAT *STANDARD-OUTPUT* 
                                              "~&Loading subsequent font file: ~A~%" FF-NAME))
                         (LET ((GLYPH-PROCESSING-HOOK #'MERGE-GLYPH))
                              (READ-BDF
 FILL-FONT :MCCS-ONLY T :VERBOSE VERBOSE)
                              (SETQ FILL-FONT NIL))
                         (WHEN BLOCKING (IL:BLOCK)))
                        ((NOT (BDF-FONT-P FILL-FONT))
                         (ERROR "Subsequent font (~S) is not a BDF-FONT, nor string, nor pathname." 
                                FF-NAME)))
                     (SETQ PREV-CC CHAR-COUNT)
                     (WHEN FILL-FONT
                         (LOOP :FOR GL :IN (BF-GLYPHS FILL-FONT)
                               :DO
                               (MERGE-GLYPH GL)))
                     (SETQ CHAR-COUNT (COUNT-MCHARS
 BASE-FONT))
                     (WHEN VERBOSE
                         (FORMAT *STANDARD-OUTPUT* 
                                "~&Font ~A supplied ~D additional MCCS characters.~%" FF-NAME
                                (- (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 &KEY AS-UNICODE)
       (IL:* IL:\; "Edited 16-Mar-2026 16:06 by mth")


                                                      (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 AS-UNICODE (EXTERNAL-FORMAT :ISO8859/1))

                                                      (IL:* IL:\; "Edited 16-Mar-2026 16:11 by mth")


                                                      (IL:* IL:\; "Edited 19-Feb-2026 21:42 by mth")


                                                      (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 :MCCS-ONLY MCCS-ONLY :AS-UNICODE
                                               AS-UNICODE))
                               (SETQ ENC (GLYPH-ENCODING GL))
                               (WHEN (AND (LISTP ENC)
                                          (EQL (FIRST ENC)
                                               -1))
                                   (SETQ ENC (OR (SECOND ENC)
                                                 -1)))
                               (COND
                                  (AS-UNICODE 

                                         (IL:* IL:|;;| 

                                         "IS THIS TRUE IF REMAINING IN UNICODE ENCODING?")


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


                                         (IL:* IL:|;;| "For now, assuming NOT TRUE")


                                         (WHEN (AND GLYPH-PROCESSING-HOOK (FUNCTIONP 
                                                                                GLYPH-PROCESSING-HOOK
                                                                                 ))
                                             (SETQ GL (FUNCALL GLYPH-PROCESSING-HOOK GL)))
                                         (WHEN GL

                                             (IL:* IL:|;;| 

                                             "Everything is mappable if in 0000-FFFF range")


                                             (IF (<= 0 ENC 65535)
                                                 (PROGN (SETF (GLYPH-MCODE GL)
                                                              ENC)
                                                        (TCONC MAPPED-GLYPHS GL))
                                                 (TCONC UNMAPPED-GLYPHS GL)))

                                         (IL:* IL:|;;| "Don't bother with MCHAR-PRESENT bits")


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


                                         (WHEN (AND GLYPH-PROCESSING-HOOK (FUNCTIONP 
                                                                                GLYPH-PROCESSING-HOOK
                                                                                 ))
                                             (SETQ CGL (FUNCALL GLYPH-PROCESSING-HOOK CGL)))
                                         (WHEN CGL (TCONC MAPPED-GLYPHS CGL))
                                         (CHAR-PRESENT-BIT
 MCHAR-PRESENT CC 1)))
                                  ((NOT MCCS-ONLY)
                                   (WHEN (AND GLYPH-PROCESSING-HOOK (FUNCTIONP GLYPH-PROCESSING-HOOK)
                                              )
                                       (SETQ GL (FUNCALL GLYPH-PROCESSING-HOOK GL)))
                                   (WHEN GL (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~%Glyphs: ~D~%Unmapped glyphs: ~D~%"
               (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)
               (LENGTH (BF-GLYPHS FONT))
               (LENGTH (BF-UNMAPPED¬GLYPHS FONT))))
    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 &KEY MCCS-ONLY AS-UNICODE)

                                                      (IL:* IL:\; "Edited 16-Mar-2026 15:32 by mth")


                                                      (IL:* IL:\; "Edited 23-Feb-2026 20:11 by mth")


                                                      (IL:* IL:\; "Edited 19-Feb-2026 15:46 by mth")


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

                        (IF (AND (NOT AS-UNICODE)
                                 MCCS-ONLY
                                 (NOT (UTOMCODE? ENC)))
                            (PROGN 
                                   (IL:* IL:|;;| 

                            "This is the case of skipping over non-MCCS encoded glyph when MCCS-ONLY")


                                   (LOOP :REPEAT BBH :DO (READ-LINE FILE-STREAM)))
                            (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 WORDINDEX)
                             (LABELS ((CHAR-HEX-VALUE (C)
                                             (IF (CHARACTERP C)
                                                 (COND
                                                    ((CHAR<= #\0 C #\9)
                                                     (- (CHAR-CODE C)
                                                        (IL:CONSTANT (CHAR-CODE #\0))))
                                                    ((CHAR<= #\A C #\F)

                                                     (IL:* IL:|;;| 

                     "The (- (CHAR-CODE #\\A) 10) accomplishes adding 10 after the outer subtraction")


                                                     (- (CHAR-CODE C)
                                                        (IL:CONSTANT (- (CHAR-CODE #\A)
                                                                        10))))
                                                    ((CHAR<= #\a C #\f)

                                                     (IL:* IL:|;;| 

                     "The (- (CHAR-CODE #\\a) 10) accomplishes adding 10 after the outer subtraction")


                                                     (- (CHAR-CODE C)
                                                        (IL:CONSTANT (- (CHAR-CODE #\a)
                                                                        10))))
                                                    (T 0))
                                                 0))
                                      (PARSE-WORDS
                                       NIL
                                       (LOOP :FOR I :FROM 0 :TO (1- NCHARS)
                                             :BY 4 :WITH C3LIMIT = (- NCHARS 3)
                                             :WITH C4LIMIT = (- NCHARS 4)
                                             :COLLECT
                                             (+ (ASH (CHAR-HEX-VALUE (CHAR LINE I))
                                                     12)
                                                (ASH (CHAR-HEX-VALUE (CHAR LINE (+ 1 I)))
                                                     8)
                                                (ASH (CHAR-HEX-VALUE (AND (<= I C3LIMIT)
                                                                          (CHAR LINE (+ 2 I))))
                                                     4)
                                                (CHAR-HEX-VALUE (AND (<= I C4LIMIT)
                                                                     (CHAR LINE (+ 3 I))))))))
                                    (LOOP :WITH BITROW = 0 :REPEAT BBH :DO
                                          (SETQ LINE (STRING-TRIM '(#\Space #\Tab)
                                                            (READ-LINE FILE-STREAM)))
                                          (UNLESS (EQUAL NCHARS (LENGTH LINE))
                                                 (ERROR "Invalid BDF file - bad line in BITMAP: ~A" 
                                                        LINE))
                                          (SETQ BITS (PARSE-WORDS))
                                          (SETQ WORDINDEX (* BITROW BM.RASTERWIDTH))
                                          (LOOP :REPEAT NWORDS :DO (IL:\\PUTBASE BM.BASE WORDINDEX
                                                                          (POP BITS))
                                                (INCF WORDINDEX))
                                          (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 
                                                  AS-UNICODE TEST &AUX FULLFILENAME)

                                                      (IL:* IL:\; "Edited 16-Mar-2026 16:12 by mth")


                                                      (IL:* IL:\; "Edited 23-Feb-2026 15:57 by mth")


                                                      (IL:* IL:\; "Edited 17-Feb-2026 14:17 by mth")


                                                      (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 :AS-UNICODE AS-UNICODE)
          (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 (IF TEST
                                 "WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE  TEST"
                                 (MEDLEYFONT.WRITE.FONT FONTDESC (MEDLEYFONT.FILENAME NIL 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" 
                                                           "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 (3216 10679 (BDF-TO-CHARSETINFO 3216 . 10679)) (10681 17828 (BDF-TO-FONTDESCRIPTOR 
10681 . 17828)) (17830 22409 (BUILD-COMPOSITE 17830 . 22409)) (22411 23160 (CHAR-PRESENT-BIT 22411 . 
23160)) (23162 23446 (COUNT-MCHARS 23162 . 23446)) (23448 26592 (GLYPHS-BY-CHARSET 23448 . 26592)) (
26594 28019 (PACKFILENAME.STRING 26594 . 28019)) (28021 40051 (READ-BDF 28021 . 40051)) (40053 40376 (
READ-DELIMITED-LIST-FROM-STRING 40053 . 40376)) (40378 49390 (READ-GLYPH 40378 . 49390)) (49392 51271 
(WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE 49392 . 51271)) (51273 53690 (XLFD-SPLIT-FONT-NAME 51273 . 53690)
) (53692 56704 (XLFD-TO-FACE 53692 . 56704)))))
IL:STOP