(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)


(FILECREATED "16-Mar-2026 23:19:02" {WMEDLEY}<lispusers>EDITFONT.;42
 26474  

      :EDIT-BY rmk

      :CHANGES-TO (FNS EDITFONT)
                  (RECORDS CHARITEM)

      :PREVIOUS-DATE "12-Oct-2025 17:39:29" {WMEDLEY}<lispusers>EDITFONT.;41)


(PRETTYCOMPRINT EDITFONTCOMS)

(RPAQQ EDITFONTCOMS

       (
        (* ;; "EDITFONT -- By Kelly Roach.  Need to LOAD EXPORTS.ALL in order to compile this file.")


        (INITVARS (EF.MENU NIL)
               (EF.TITLEMENU NIL))
        (FNS EF.INIT EF.PROMPT EF.MESSAGE EF.CLOSEFN EF.CHARITEMS EF.BUTTONEVENTFN EF.WHENSELECTEDFN
             EF.EDITBM EF.MIDDLEBUTTONFN EF.CHANGESIZE EF.DELETE EF.ENTER EF.REPLACE EF.SAVE COPYFONT
             READSTRIKEFONTFILE)
        (FNS BLANKCHARSETCREATE EDITFONT)
        (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS CHARITEM)
               (FILES (LOADCOMP)
                      FONT))
        (P (EF.INIT))))



(* ;; "EDITFONT -- By Kelly Roach.  Need to LOAD EXPORTS.ALL in order to compile this file.")



(RPAQ? EF.MENU
 NIL)

(RPAQ? EF.TITLEMENU
 NIL)
(DEFINEQ

(EF.INIT

  [LAMBDA NIL
                                                (* ; "Edited  4-Aug-2025 13:16 by rmk")

    [SETQ EF.MENU (create
 MENU
                         ITEMS _ '((CHANGESIZE 'EF.CHANGESIZE "Change size of character.")
                                   (DELETE 'EF.DELETE "Delete character.")
                                   (EDITBM 'EF.EDITBM "Edit character.")
                                   (REPLACE
 'EF.REPLACE "Prompt for bitmap to replace character."]
    (SETQ EF.TITLEMENU (create
 MENU
                              ITEMS _ '((SAVE 'EF.SAVE "Save EDITFONT's work back into font."])

(EF.PROMPT

  [LAMBDA (STRING WINDOW)                                    (* kbr%: "16-Oct-85 22:48")

    (PROG (PROMPTW ANSWER)
          (SETQ PROMPTW (GETPROMPTWINDOW WINDOW))
          (CLEARW PROMPTW)
          (PRIN1 STRING PROMPTW)
          (PRIN1 " " PROMPTW)
          (SETQ ANSWER (RESETLST
                           (RESETSAVE (TTYDISPLAYSTREAM PROMPTW))
                           (RESETSAVE (TTY.PROCESS (THIS.PROCESS)))
                           (TTYINREAD PROMPTW)))
          (TERPRI PROMPTW)
          (SETQ ANSWER (EVAL ANSWER))
          (RETURN ANSWER])

(EF.MESSAGE

  [LAMBDA (STRING WINDOW)                                    (* kbr%: "16-Oct-85 22:50")

    (PROG (PROMPTW)
          (SETQ PROMPTW (GETPROMPTWINDOW WINDOW))
          (PRIN1 STRING PROMPTW])

(EF.CLOSEFN

  [LAMBDA (WINDOW)                                           (* kbr%: "15-Dec-84 15:20")

                                                             (* Close EF Window. *)

    (PROG NIL
          [COND
             ((EQ (ASKUSER "Close Editfont Window?")
                  'N)
              (RETURN 'DON'T]
          (CLOSEW WINDOW)                                    (* Break circularity.

                                                             *)

          (WINDOWPROP WINDOW 'MENU NIL])

(EF.CHARITEMS

  [LAMBDA (FONT CHARSET ROWMAJOR)
                            (* ; "Edited  5-Oct-2025 14:42 by rmk")


                                                             (* ; "Edited 29-Aug-2025 11:34 by rmk")


                                                             (* ; "Edited 27-Aug-2025 22:50 by rmk")


                                                             (* ; "Edited  4-Aug-2025 00:14 by rmk")


                                                             (* ; "Edited 25-Jul-2025 10:06 by rmk")

                                                             (* kbr%: "16-Oct-85 23:11")


    (* ;; "Get CHARITEMS for CHARSET in FONT.  Sort them in column-major order to build an array that corresponds to the tables in Unicode and XCCS.")


    (if
 ROWMAJOR
        then
 (for
 C8 from
 0 to
 \MAXTHINCHAR as
 C from
 (LLSH CHARSET 8)
                collect
 (create
 CHARITEM
                               BITMAP _ (GETCHARBITMAP C FONT)
                               CHARCODE _ C8
                               SLUGCHARP _ (SLUGCHARP.DISPLAY C FONT)))
      else
 (for
 ROW from
 0 to
 15 join
 (for
 COL CODE from
 0 to
 15
                                         collect
 (SETQ CODE (LOGOR (LLSH CHARSET 8)
                                                                   (IPLUS (TIMES COL 16)
                                                                          ROW)))
                                               (create
 CHARITEM
                                                      BITMAP _ (GETCHARBITMAP CODE FONT)
                                                      CHARCODE _ CODE
                                                      SLUGCHARP _ (SLUGCHARP.DISPLAY CODE FONT])

(EF.BUTTONEVENTFN

  [LAMBDA (WINDOW)                                           (* kbr%: "16-Oct-85 22:19")

    (PROG (COMMAND)
          (COND
             ((INSIDEP (DSPCLIPPINGREGION NIL WINDOW)
                     (LASTMOUSEX WINDOW)
                     (LASTMOUSEY WINDOW))
              (MENUBUTTONFN WINDOW))
             ((SETQ COMMAND (MENU EF.TITLEMENU))
              (APPLY* COMMAND WINDOW])

(EF.WHENSELECTEDFN

  [LAMBDA (CHARITEM MENU KEY)                                (* kbr%: "16-Oct-85 22:26")

    (PROG NIL
          (COND
             (CHARITEM (SELECTQ KEY
                           (LEFT (EF.EDITBM
 CHARITEM MENU))
                           (MIDDLE (EF.MIDDLEBUTTONFN
 CHARITEM MENU))
                                                             (* Do nothing. *)
])

(EF.EDITBM

  [LAMBDA (CHARITEM MENU CHARSET)
                            (* ; "Edited 29-Aug-2025 11:37 by rmk")


                                                             (* ; "Edited  4-Aug-2025 09:11 by rmk")

                                                             (* kbr%: "15-Dec-84 15:20")

    (LET ((SLUGCHARP (fetch
 (CHARITEM BITMAP) of
 CHARITEM))
          (CHARCODE (fetch
 (CHARITEM CHARCODE) of
 CHARITEM))
          BITMAP)
         (RESETLST
             [RESETSAVE (SHADEITEM CHARITEM MENU BLACKSHADE)
                    `(SHADEITEM ,CHARITEM ,MENU ,WHITESHADE]
             (SETQ BITMAP (fetch
 (CHARITEM BITMAP) of
 CHARITEM))
             (CL:WHEN SLUGCHARP                              (* ; "Unslug this CHARITEM ")

                 (SETQ BITMAP (BITMAPCOPY BITMAP))
                 (UNINTERRUPTABLY
                     (replace
 (CHARITEM BITMAP) of
 CHARITEM with
 BITMAP)
                     (replace
 (CHARITEM SLUGCHARP) of
 CHARITEM with
 NIL)))
             [EDITBM BITMAP (CONCAT (CHARCODE.ENCODE CHARCODE T)
                                   " in "
                                   (GETMENUPROP MENU 'EDITFONTTITLE])

         (* ;; "Update MENU image.  SHADEITEM's side effects above suffice if we only changed one menu item.  (I.e.  we edited an ordinary CHARITEM.) ")


         (CL:WHEN SLUGCHARP
             (UPDATE/MENU/IMAGE MENU)
             (REDISPLAYW (WFROMMENU MENU)))])

(EF.MIDDLEBUTTONFN

  [LAMBDA (CHARITEM MENU)                                    (* kbr%: "15-Dec-84 15:20")

    (PROG (COMMAND)
          (SETQ COMMAND (MENU EF.MENU))
          (COND
             (COMMAND (APPLY* COMMAND CHARITEM MENU])

(EF.CHANGESIZE

  [LAMBDA (CHARITEM MENU)
                                    (* ; "Edited  3-Aug-2025 17:44 by rmk")

                                                             (* kbr%: "16-Oct-85 23:03")

                                                             (* Change height & width of CHARITEM's 

                                                             BITMAP *)

    (PROG (HEIGHT WIDTH NEWBITMAP WINDOW)
          (SETQ WINDOW (WFROMMENU MENU))
          (SETQ HEIGHT (EF.PROMPT
 "New height?" WINDOW))
          (COND
             ((NULL HEIGHT)
              (EF.MESSAGE
 "Aborted." WINDOW)
              (RETURN)))
          (SETQ HEIGHT (EVAL HEIGHT))
          (SETQ WIDTH (EF.PROMPT
 "New width?" WINDOW))
          (COND
             ((NULL WIDTH)
              (EF.MESSAGE
 "Aborted." WINDOW)
              (RETURN)))
          (SETQ WIDTH (EVAL WIDTH))
          (SETQ NEWBITMAP (BITMAPCREATE WIDTH HEIGHT))
          (BITBLT (fetch
 (CHARITEM BITMAP) of
 CHARITEM)
                 NIL NIL NEWBITMAP)
          (UNINTERRUPTABLY
              (replace
 (CHARITEM BITMAP) of
 CHARITEM with
 NEWBITMAP)
              (replace
 (CHARITEM SLUGCHARP) of
 CHARITEM with
 NIL))
          (UPDATE/MENU/IMAGE MENU)
          (REDISPLAYW (WFROMMENU MENU])

(EF.DELETE

  [LAMBDA (CHARITEM MENU)
                                    (* ; "Edited  2-Sep-2025 23:03 by rmk")


                                                             (* ; "Edited  4-Aug-2025 13:14 by rmk")

                                                             (* kbr%: "15-Dec-84 15:20")

                                                             (* ; 

                                                             "Turn CHARITEM into a slug charitem.")

    (LET ((WINDOW (WFROMMENU MENU))
          SLUGBITMAP)
         [SETQ SLUGBITMAP (\GETCHARBITMAP.CSINFO SLUGCHARINDEX (\GETCHARSETINFO (WINDOWPROP
                                                                                 WINDOW
                                                                                 'FONT)
                                                                      (WINDOWPROP WINDOW 'CHARSET]
         (UNINTERRUPTABLY
             (replace
 (CHARITEM BITMAP) of
 CHARITEM with
 SLUGBITMAP)
             (replace
 (CHARITEM SLUGCHARP) of
 CHARITEM with
 T))
         (UPDATE/MENU/IMAGE MENU)
         (REDISPLAYW (WFROMMENU MENU])

(EF.ENTER

  [LAMBDA (CHARITEM MENU)
                                    (* ; "Edited  3-Aug-2025 17:44 by rmk")

                                                             (* kbr%: "15-Dec-84 15:20")

                                                             (* Enter BITMAP of CHARITEM.

                                                             *)

    (PROG (NEWBITMAP)
          (SETQ NEWBITMAP (EF.PROMPT
 "Enter new bitmap (evaluated):"))
          (COND
             ((NULL NEWBITMAP)
              (printout T "Aborted." T))
             ((type?
 BITMAP NEWBITMAP)
              (UNINTERRUPTABLY
                  (replace
 (CHARITEM BITMAP) of
 CHARITEM with
 NEWBITMAP)
                  (replace
 (CHARITEM SLUGCHARP) of
 CHARITEM with
 NIL))
              (UPDATE/MENU/IMAGE MENU)
              (REDISPLAYW (WFROMMENU MENU)))
             (T (LISPERROR "ILLEGAL ARG" NEWBITMAP])

(EF.REPLACE

  [LAMBDA (CHARITEM MENU)
                                    (* ; "Edited  3-Aug-2025 17:44 by rmk")

                                                             (* kbr%: "16-Oct-85 23:04")

                                                             (* Replace BITMAP of CHARITEM.

                                                             *)

    (PROG (BITMAP WINDOW)
          (SETQ WINDOW (WFROMMENU MENU))
          (SETQ BITMAP (EF.PROMPT
 "New bitmap?" WINDOW))
          (COND
             ((NULL BITMAP)
              (EF.MESSAGE
 "Aborted." WINDOW))
             ((type?
 BITMAP BITMAP)
              (UNINTERRUPTABLY
                  (replace
 (CHARITEM BITMAP) of
 CHARITEM with
 BITMAP)
                  (replace
 (CHARITEM SLUGCHARP) of
 CHARITEM with
 NIL))
              (UPDATE/MENU/IMAGE MENU)
              (REDISPLAYW (WFROMMENU MENU)))
             (T (LISPERROR "ILLEGAL ARG" BITMAP])

(EF.SAVE

  [LAMBDA (WINDOW)
                                           (* ; "Edited 12-Oct-2025 17:33 by rmk")


                                                             (* ; "Edited  2-Sep-2025 23:03 by rmk")


                                                             (* ; "Edited 29-Aug-2025 11:35 by rmk")


                                                             (* ; "Edited  4-Aug-2025 09:22 by rmk")


                                                             (* ; "Edited  2-Aug-2025 08:47 by rmk")

                                                             (* kbr%: "21-Oct-85 15:39")

                                                             (* ; "Save EDITFONT changes to FONT.  *")

    (LET ((FONT (WINDOWPROP WINDOW 'FONT))
          (CHARITEMS (WINDOWPROP WINDOW 'CHARITEMS))
          (CHARSET (WINDOWPROP WINDOW 'CHARSET))
          (CBWIDTH 0)
          (CBHEIGHT 0)
          CB WIDTHS OFFSETS HEIGHT WIDTH OFFSET CSINFO SLUGBM SLUGOFFSET SLUGWIDTH)
                                                             (* ; "New allocations")


         (* ;; "Get the width of the new bitmap, including the slug")


         [for
 CI BM in
 CHARITEMS unless
 (fetch
 (CHARITEM SLUGCHARP) of
 CI)
            do
 (SETQ BM (fetch
 (CHARITEM BITMAP) of
 CI))
               (SETQ CBWIDTH (IPLUS CBWIDTH (fetch
 (BITMAP BITMAPWIDTH) of
 BM)))
               (SETQ CBHEIGHT (IMAX CBHEIGHT (fetch
 (BITMAP BITMAPHEIGHT) of
 BM]

         (* ;; "We'll install the slugbm at the end, include its dimensions")


         (SETQ SLUGBM (\GETCHARBITMAP.CSINFO SLUGCHARINDEX (\GETCHARSETINFO FONT CHARSET)))
         (SETQ SLUGWIDTH (fetch
 (BITMAP BITMAPWIDTH) of
 SLUGBM))
         (add
 CBWIDTH SLUGWIDTH)
         (SETQ CBHEIGHT (IMAX CBHEIGHT (fetch
 (BITMAP BITMAPHEIGHT) of
 SLUGBM)))
         (SETQ CB (BITMAPCREATE CBWIDTH CBHEIGHT))
         (SETQ CSINFO (create
 CHARSETINFO copying
 (\GETCHARSETINFO FONT CHARSET)
                                                CHARSETBITMAP _ CB))
         (SETQ OFFSETS (fetch
 (CHARSETINFO OFFSETS) of
 CSINFO))
         (SETQ WIDTHS (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO))(* ; "Store new info in allocations")

         (SETQ OFFSET 0)

         (* ;; "Copy all the character bitmaps into CB, setting their offsets and widths.")


         (for
 CI BM C8 in
 CHARITEMS unless
 (fetch
 (CHARITEM SLUGCHARP) of
 CI)
            do
 (SETQ BM (fetch
 (CHARITEM BITMAP) of
 CI))
               (SETQ WIDTH (fetch
 (BITMAP BITMAPWIDTH) of
 BM))
               (BITBLT BM 0 0 CB OFFSET 0 WIDTH (fetch
 (BITMAP BITMAPHEIGHT) of
 BM)
                      'INPUT
                      'REPLACE)
               (SETQ C8 (\CHAR8CODE (fetch
 (CHARITEM CHARCODE) of
 CI)))
               (\FSETOFFSET OFFSETS C8 OFFSET)
               (\FSETWIDTH WIDTHS C8 WIDTH)
               (add
 OFFSET WIDTH))

         (* ;; "OFFSET is now the SLUG offset")


         (SETQ SLUGOFFSET OFFSET)
         (\FSETOFFSET OFFSETS SLUGCHARINDEX SLUGOFFSET)
         (\FSETOFFSET OFFSETS (ADD1 SLUGCHARINDEX)
                (IPLUS SLUGOFFSET SLUGWIDTH))
         (BITBLT SLUGBM 0 0 CB SLUGOFFSET 0 SLUGWIDTH (fetch
 (BITMAP BITMAPHEIGHT) of
 SLUGBM)
                'INPUT
                'REPLACE)
         (for
 CI in
 CHARITEMS when
 (fetch
 (CHARITEM SLUGCHARP) of
 CI)
            do
 (\FSETOFFSET OFFSETS (\CHAR8CODE (fetch
 (CHARITEM CHARCODE) of
 CI))
                      SLUGOFFSET)
               (\FSETOFFSET WIDTHS (\CHAR8CODE (fetch
 (CHARITEM CHARCODE) of
 CI))
                      SLUGWIDTH))                            (* ; "Store new info")

         (replace
 (CHARSETINFO CHARSETBITMAP) of
 CSINFO with
 CB)
         (replace
 (CHARSETINFO WIDTHS) of
 CSINFO with
 WIDTHS)
         (replace
 (CHARSETINFO OFFSETS) of
 CSINFO with
 OFFSETS)
         (replace
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO with
 WIDTHS)

         (* ;; "Can this editing change the descent or ascent?")


         (\SETCHARSETINFO FONT CHARSET CSINFO])

(COPYFONT

  [LAMBDA (FONT)
                                             (* ; "Edited  3-Aug-2025 17:37 by rmk")

                                                             (* jds "26-Aug-86 16:01")

    (create
 FONTDESCRIPTOR copying
 (FONTCREATE FONT])

(READSTRIKEFONTFILE

  [LAMBDA (FAMILY SIZE FACE FILE FONT CHARSET)

    (* ;; "Edited  4-Aug-2025 13:33 by rmk")


    (* ;; "Edited 12-Jul-2022 13:33 by rmk")

                                                             (* kbr%: "14-Oct-85 11:16")

    (HELP "USE MEDLEYFONT.READ.FONT")

    (* ;; "Why specialize to strike fonts?  This is a throwaway.")


    (FONTCREATE FAMILY SIZE FACE FILE FONT CHARSET])
)
(DEFINEQ

(BLANKCHARSETCREATE

  [LAMBDA (FAMILY SIZE FACE CHARSET FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTH)

                                                             (* ; "Edited  2-Sep-2025 23:03 by rmk")


                                                             (* ; "Edited  4-Aug-2025 13:29 by rmk")

                                                             (* mjs "27-Mar-85 14:48")

                                                             (* ; "Edited  3-Aug-2025 17:53 by rmk")


    (* ;; "Adds CHARSET to an existing or created font, if not already there")


    (CL:UNLESS CHARSET (SETQ CHARSET 0))
    (CL:UNLESS FIRSTCHAR (SETQ FIRSTCHAR 0))
    (CL:UNLESS LASTCHAR (SETQ LASTCHAR \MAXTHINCHAR))
    (CL:UNLESS (<= 0 FIRSTCHAR LASTCHAR \MAXTHINCHAR)
        (ERROR "ILLEGAL ARGS" (LIST FIRSTCHAR LASTCHAR)))
    (CL:UNLESS (SMALLP ASCENT)
           (LISPERROR "ILLEGAL ARG" ASCENT))
    (CL:UNLESS (SMALLP DESCENT)
           (LISPERROR "ILLEGAL ARG" DESCENT))
    (PROG (ROTATION DEVICE FONT CSINFO SLUGWIDTH OFFSETS WIDTHS SLUGOFFSET CB CBWIDTH CBHEIGHT)
          (SETQ FONT (\FONT.CHECKARGS FAMILY SIZE FACE 0 'DISPLAY CHARSET))
          [if
 (type?
 FONTDESCRIPTOR FONT)
              then
 (CL:WHEN (SETQ CSINFO (\GETCHARSETINFO FONT CHARSET))
                          (RETURN FONT))
            else
 (SPREADFONTSPEC FONT)
                 (SETQ FONT
                  (create
 FONTDESCRIPTOR
                         FONTDEVICE _ 'DISPLAY
                         FONTFAMILY _ FAMILY
                         FONTSIZE _ SIZE
                         FONTFACE _ FACE
                         \SFHeight _ 0
                         ROTATION _ 0
                         FONTDEVICESPEC _ (LIST FAMILY SIZE FACE 0 'DISPLAY]
          (if
 (NULL WIDTH)
              then
 (SETQ WIDTH (FIXR (FTIMES SIZE 0.6)))
            elseif
 [AND (for
 W inside
 WIDTH always
 (FIXP W))
                        (EQ (LENGTH WIDTH)
                            (ADD1 (IDIFFERENCE (ADD1 LASTCHAR)
                                         FIRSTCHAR]
            else
 
                 (* ;; "The outer ADD1 is for the slug width")


                 (LISPERROR "ILLEGAL ARG" WIDTH))            (* ; "WIDTHS")

          (SETQ CSINFO (create
 CHARSETINFO
                              CHARSETASCENT _ ASCENT
                              CHARSETDESCENT _ DESCENT))
          (SETQ WIDTHS (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO))
          (if
 (LISTP WIDTH)
              then
 (SETQ SLUGWIDTH (CAR (LAST WIDTH)))       (* ; "Last is slugchar width")

                   (for
 I from
 0 to
 (SUB1 FIRSTCHAR) do
 (\FSETWIDTH WIDTHS I SLUGWIDTH))
                   (for
 I from
 FIRSTCHAR to
 LASTCHAR as
 W in
 WIDTH do
 (\FSETWIDTH WIDTHS I W))
                   (for
 I from
 (ADD1 LASTCHAR) to
 \MAXTHINCHAR do
 (\FSETWIDTH WIDTHS I SLUGWIDTH))
            else
 (SETQ SLUGWIDTH WIDTH)
                 (for
 I from
 0 to
 \MAXTHINCHAR do
 (\FSETWIDTH WIDTHS I WIDTH)))
                                                             (* ; "OFFSETS")

          (SETQ OFFSETS (fetch
 (CHARSETINFO OFFSETS) of
 CSINFO))
          [for
 I from
 FIRSTCHAR to
 (ADD1 LASTCHAR) do
 (\FSETOFFSET OFFSETS (ADD1 I)
                                                             (IPLUS (\FGETOFFSET OFFSETS I)
                                                                    (\FGETWIDTH WIDTHS I]
          (\FSETWIDTH WIDTHS SLUGCHARINDEX SLUGWIDTH)
          (SETQ SLUGOFFSET (IPLUS (\FGETOFFSET OFFSETS LASTCHAR)
                                  (\FGETWIDTH WIDTHS LASTCHAR)))
          (\FSETOFFSET OFFSETS SLUGCHARINDEX SLUGOFFSET)
          (\FSETOFFSET OFFSETS (ADD1 SLUGCHARINDEX)
                 (IPLUS SLUGOFFSET SLUGWIDTH))
          (for
 I from
 0 to
 (SUB1 FIRSTCHAR) do
 (\FSETOFFSET OFFSETS I SLUGOFFSET))
          (for
 I from
 (ADD1 LASTCHAR) to
 SLUGCHARINDEX do
 (\FSETOFFSET OFFSETS I SLUGOFFSET))
          (SETQ ASCENT (IMAX (OR (fetch
 (FONTDESCRIPTOR \SFDescent) of
 FONT)
                                 0)
                             (fetch
 (CHARSETINFO CHARSETDESCENT) of
 CSINFO)))
          (SETQ DESCENT (IMAX (OR (fetch
 (FONTDESCRIPTOR \SFDescent) of
 FONT)
                                  0)
                              (fetch
 (CHARSETINFO CHARSETDESCENT) of
 CSINFO)))
                                                             (* ; "Characterbitmap CB")

          (SETQ CBHEIGHT (IPLUS ASCENT DESCENT))
          (SETQ CBWIDTH (IPLUS (\FGETOFFSET OFFSETS SLUGCHARINDEX)
                               (\FGETWIDTH WIDTHS SLUGCHARINDEX)))
          (SETQ CB (BITMAPCREATE CBWIDTH CBHEIGHT))
          (BLTSHADE BLACKSHADE CB SLUGOFFSET 0 SLUGWIDTH (fetch
 (BITMAP BITMAPHEIGHT) of
 CB)
                 'REPLACE)
          (replace
 (CHARSETINFO CHARSETBITMAP) of
 CSINFO with
 CB)
                                                             (* ; "FONT")

          (\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR)
          (replace
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO with
 (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO))
          (replace
 (FONTDESCRIPTOR \SFAscent) of
 FONT with
 ASCENT)
          (replace
 (FONTDESCRIPTOR \SFDescent) of
 FONT with
 DESCENT)
          (replace
 (FONTDESCRIPTOR \SFHeight) of
 FONT with
 (IMAX (OR (fetch
 (FONTDESCRIPTOR \SFHeight
                                                                                   ) of
 FONT)
                                                                     0)
                                                                 CBHEIGHT))
          (\SETCHARSETINFO (fetch
 (FONTDESCRIPTOR FONTCHARSETVECTOR) of
 FONT)
                 CHARSET CSINFO)
          (replace
 (FONTDESCRIPTOR FONTAVGCHARWIDTH) of
 FONT with
 (\AVGCHARWIDTH FONT))
          (RETURN FONT])

(EDITFONT

  [LAMBDA (FONT CHARSET ROWMAJOR NCOLUMNS TITLETAG)
          (* ; "Edited 16-Mar-2026 23:17 by rmk")


                                                             (* ; "Edited  7-Oct-2025 14:55 by rmk")


                                                             (* ; "Edited  5-Oct-2025 15:06 by rmk")


                                                             (* ; "Edited  4-Sep-2025 09:27 by rmk")


                                                             (* ; "Edited 29-Aug-2025 22:34 by rmk")


                                                             (* ; "Edited 17-Aug-2025 12:03 by rmk")


                                                             (* ; "Edited  3-Aug-2025 23:25 by rmk")


                                                             (* ; "Edited  2-Aug-2025 10:11 by rmk")

                                                             (* mjs "27-Mar-85 14:48")

                                                             (* kbr%: "21-Oct-85 15:35")

                                                             (* kbr%: "21-Oct-85 15:35")

    (SETQ FONT (FONTCREATE FONT))
    (CL:UNLESS (EQ 'DISPLAY (FONTPROP FONT 'DEVICE))
           (ERROR FONT " is not a display font"))
    (SETQ CHARSET (OR (CHARSET.DECODE CHARSET)
                      0))
    (LET (CHARITEMS MENU TITLE HEIGHT WIDTH REGION POS WINDOW)
         (SETQ CHARITEMS (EF.CHARITEMS
 FONT CHARSET ROWMAJOR))
         (SETQ MENU (create
 MENU
                           MENUFONT _ FONT
                           CENTERFLG _ T
                           MENUCOLUMNS _ (OR NCOLUMNS 16)
                           ITEMS _ CHARITEMS
                           WHENSELECTEDFN _ (FUNCTION EF.WHENSELECTEDFN)))
         (SETQ TITLE (PACK* (FONTPROP FONT 'FAMILY)
                            " "
                            (FONTPROP FONT 'SIZE)
                            " "
                            (FONTFACETOATOM (FONTPROP FONT 'FACE))
                            " "
                            (OCTALSTRING CHARSET)
                            (CL:IF TITLETAG
                                (CONCAT " " TITLETAG)
                                "")))
         (PUTMENUPROP MENU 'EDITFONTTITLE TITLE)
         (SETQ HEIGHT (HEIGHTIFWINDOW (fetch
 (MENU IMAGEHEIGHT) of
 MENU)
                             T))
         (SETQ WIDTH (WIDTHIFWINDOW (fetch
 (MENU IMAGEWIDTH) of
 MENU)))
         (SETQ POS (GETBOXPOSITION WIDTH HEIGHT))
         (SETQ REGION (create
 REGION
                             LEFT _ (fetch
 (POSITION XCOORD) of
 POS)
                             BOTTOM _ (fetch
 (POSITION YCOORD) of
 POS)
                             WIDTH _ WIDTH
                             HEIGHT _ HEIGHT))
         (SETQ WINDOW (CREATEW REGION TITLE))
         (WINDOWPROP WINDOW 'CHARITEMS CHARITEMS)
         (WINDOWPROP WINDOW 'FONT FONT)
         (WINDOWPROP WINDOW 'CHARSET CHARSET)
         (ADDMENU MENU WINDOW (create
 POSITION
                                     XCOORD _ 0
                                     YCOORD _ 0))
         (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION EF.BUTTONEVENTFN))
         (MODERNWINDOW WINDOW)
         FONT])
)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(RECORD CHARITEM
 (BITMAP CHARCODE SLUGCHARP))
)


(FILESLOAD (LOADCOMP)
       FONT)
)

(EF.INIT
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1147 16904 (EF.INIT 1157 . 1791) (EF.PROMPT 1793 . 2375) (EF.MESSAGE 2377 . 2589) (
EF.CLOSEFN 2591 . 3118) (EF.CHARITEMS 3120 . 4956) (EF.BUTTONEVENTFN 4958 . 5370) (EF.WHENSELECTEDFN 
5372 . 5776) (EF.EDITBM 5778 . 7272) (EF.MIDDLEBUTTONFN 7274 . 7519) (EF.CHANGESIZE 7521 . 8850) (
EF.DELETE 8852 . 10033) (EF.ENTER 10035 . 10976) (EF.REPLACE 10978 . 11951) (EF.SAVE 11953 . 16196) (
COPYFONT 16198 . 16473) (READSTRIKEFONTFILE 16475 . 16902)) (16905 26286 (BLANKCHARSETCREATE 16915 . 
23000) (EDITFONT 23002 . 26284)))))
STOP