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


(FILECREATED "12-Jul-2022 14:18:56" 
{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>EDITFONT.;10
 28741  

      :CHANGES-TO (FNS READSTRIKEFONTFILE)
                  (VARS EDITFONTCOMS)

      :PREVIOUS-DATE "27-Jun-2022 10:59:12" 
{DSK}<users>kaplan>local>medley3.5>working-medley>lispusers>EDITFONT.;5)


(* ; "
Copyright (c) 1985-1986 by Xerox Corporation.
")

(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))
        (RECORDS CHARITEM)
        (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 EF.BLANK
             COPYFONT READSTRIKEFONTFILE)
        (FNS BLANKFONTCREATE EDITFONT)
        (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (BITSPERWORD 16)
                                                (BYTESPERWORD 2)
                                                (MAXCODE 255)
                                                (DUMMYINDEX 256))
               (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)
(DECLARE%: EVAL@COMPILE

(RECORD CHARITEM
 (BITMAP (CHARCODE DUMMYFLG)))
)
(DEFINEQ

(EF.INIT

  [LAMBDA NIL                                                (* kbr%: "21-Oct-85 15:50")

    (PROG NIL
          [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 FROMCHAR8CODE TOCHAR8CODE CHARSET)           (* kbr%: "16-Oct-85 23:11")

                                                             (* Get CHARITEMS for FONT.

                                                             *)

    (PROG (FROMCHARCODE TOCHARCODE OFFSETS DUMMYOFFSET DUMMYBITMAP OFFSET BITMAP CHARITEM CHARITEMS)
                                                             (* Get DUMMY CHARITEM *)


         (* Interlisp assuming 256 is dummy is dumb now because of NS chars.

         Maybe Kaplan and Nuyens will fix. *)


          (SETQ DUMMYBITMAP (GETCHARBITMAP 256 FONT))
          (SETQ CHARITEM (create
 CHARITEM
                                BITMAP _ DUMMYBITMAP
                                CHARCODE _ DUMMYINDEX
                                DUMMYFLG _ T))
          (push
 CHARITEMS CHARITEM)                          (* Get ordinairy CHARITEMs.

                                                             *)

          (SETQ FROMCHARCODE (IPLUS (ITIMES 256 CHARSET)
                                    FROMCHAR8CODE))
          (SETQ TOCHARCODE (IPLUS (ITIMES 256 CHARSET)
                                  TOCHAR8CODE))
          (SETQ OFFSETS (fetch
 (CHARSETINFO OFFSETS) of
 (\GETCHARSETINFO CHARSET FONT)))
          (SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS DUMMYINDEX))
          (for
 I from
 TOCHARCODE to
 FROMCHARCODE by
 -1
             do
 (SETQ OFFSET (\FGETOFFSET OFFSETS I))
                [COND
                   ((EQ OFFSET DUMMYOFFSET)
                    (SETQ CHARITEM (create
 CHARITEM
                                          BITMAP _ DUMMYBITMAP
                                          CHARCODE _ I
                                          DUMMYFLG _ T)))
                   (T (SETQ BITMAP (GETCHARBITMAP I FONT))
                      (SETQ CHARITEM (create
 CHARITEM
                                            BITMAP _ BITMAP
                                            CHARCODE _ I
                                            DUMMYFLG _ NIL]
                (push
 CHARITEMS CHARITEM))                   (* OKEY DOKEY *)

          (RETURN CHARITEMS])

(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)                                    (* kbr%: "15-Dec-84 15:20")

    (PROG (BITMAP CHARCODE DUMMYFLG)
          (RESETLST
              [RESETSAVE (SHADEITEM CHARITEM MENU BLACKSHADE)
                     `(SHADEITEM ,CHARITEM ,MENU ,WHITESHADE]
              (SETQ BITMAP (fetch
 (CHARITEM BITMAP) of
 CHARITEM))
              [COND
                 ((AND (NOT (IEQP (fetch
 (CHARITEM CHARCODE) of
 CHARITEM)
                                  DUMMYINDEX))
                       (fetch
 (CHARITEM DUMMYFLG) of
 CHARITEM))
                                                             (* Undummify this CHARITEM.

                                                             *)

                  (SETQ BITMAP (COPYALL BITMAP))
                  (UNINTERRUPTABLY
                      (replace
 (CHARITEM BITMAP) of
 CHARITEM with
 BITMAP)
                      (replace
 (CHARITEM DUMMYFLG) of
 CHARITEM with
 NIL))]
              (EDITBM BITMAP))

         (* Update MENU image. SHADEITEM's side effects above suffice if we only changed 

         one menu item. (I.e. we edited an ordinairy CHARITEM.) *)


          (COND
             ((IEQP (fetch
 (CHARITEM CHARCODE) of
 CHARITEM)
                    DUMMYINDEX)
              (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)                                    (* 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 DUMMYFLG) of
 CHARITEM with
 NIL))
          (UPDATE/MENU/IMAGE MENU)
          (REDISPLAYW (WFROMMENU MENU])

(EF.DELETE

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

                                                             (* Turn CHARITEM into dummy charitem.

                                                             *)

    (PROG (WINDOW CHARITEMS DUMMYBITMAP)
          (SETQ WINDOW (WFROMMENU MENU))
          (SETQ CHARITEMS (WINDOWPROP WINDOW 'CHARITEMS))
          [SETQ DUMMYBITMAP (fetch
 (CHARITEM BITMAP) of
 (CAR (LAST CHARITEMS]
          (UNINTERRUPTABLY
              (replace
 (CHARITEM BITMAP) of
 CHARITEM with
 DUMMYBITMAP)
              (replace
 (CHARITEM DUMMYFLG) of
 CHARITEM with
 T))
          (UPDATE/MENU/IMAGE MENU)
          (REDISPLAYW (WFROMMENU MENU])

(EF.ENTER

  [LAMBDA (CHARITEM MENU)                                    (* 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 DUMMYFLG) of
 CHARITEM with
 NIL))
              (UPDATE/MENU/IMAGE MENU)
              (REDISPLAYW (WFROMMENU MENU)))
             (T (LISPERROR "ILLEGAL ARG" NEWBITMAP])

(EF.REPLACE

  [LAMBDA (CHARITEM MENU)                                    (* 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 DUMMYFLG) of
 CHARITEM with
 NIL))
              (UPDATE/MENU/IMAGE MENU)
              (REDISPLAYW (WFROMMENU MENU)))
             (T (LISPERROR "ILLEGAL ARG" BITMAP])

(EF.SAVE

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

                                                             (* Save EDITFONT changes to FONT.

                                                             *)

    (PROG (CHARITEMS FONT CB CBWIDTH CBHEIGHT WIDTHS OFFSETS HEIGHT WIDTH DUMMYOFFSET OFFSET BITMAP 
                 FIRSTCHAR LASTCHAR CHARSET CSINFO)
          (SETQ CHARITEMS (WINDOWPROP WINDOW 'CHARITEMS))
          (SETQ FONT (WINDOWPROP WINDOW 'FONT))              (* New allocations. *)

          (SETQ CBWIDTH 0)
          (SETQ CBHEIGHT 0)
          [for
 I from
 0 to
 DUMMYINDEX as
 CHARITEM in
 CHARITEMS
             when
 (OR (NOT (fetch
 (CHARITEM DUMMYFLG) of
 CHARITEM))
                      (IEQP I DUMMYINDEX)) do
 (SETQ BITMAP (fetch
 (CHARITEM BITMAP) of
 CHARITEM))
                                              (SETQ CBWIDTH (IPLUS CBWIDTH (fetch
 (BITMAP BITMAPWIDTH
                                                                                         )
                                                                              of
 BITMAP)))
                                              (SETQ CBHEIGHT (IMAX CBHEIGHT (fetch
 (BITMAP 
                                                                                         BITMAPHEIGHT
                                                                                          )
                                                                               of
 BITMAP]
          (SETQ CSINFO (create
 CHARSETINFO
                              CHARSETASCENT _ (fetch
 (FONTDESCRIPTOR \SFAscent) of
 FONT)
                              CHARSETDESCENT _ (fetch
 (FONTDESCRIPTOR \SFDescent) of
 FONT)))
          (SETQ OFFSETS (fetch
 (CHARSETINFO OFFSETS) of
 CSINFO))
          (SETQ WIDTHS (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO))
                                                             (* Store new info in allocations.

                                                             *)

          (SETQ OFFSET 0)
          [SETQ DUMMYOFFSET (IDIFFERENCE CBWIDTH (fetch
 (BITMAP BITMAPWIDTH)
                                                    of
 (fetch
 (CHARITEM BITMAP)
                                                          of
 (CAR (LAST CHARITEMS]
          (SETQ CB (BITMAPCREATE CBWIDTH CBHEIGHT))
          [for
 I from
 0 to
 DUMMYINDEX as
 CHARITEM in
 CHARITEMS
             do
 (SETQ BITMAP (fetch
 (CHARITEM BITMAP) of
 CHARITEM))
                (SETQ WIDTH (fetch
 (BITMAP BITMAPWIDTH) of
 BITMAP))
                (SETQ HEIGHT (fetch
 (BITMAP BITMAPHEIGHT) of
 BITMAP))
                (\FSETWIDTH WIDTHS I WIDTH)
                (COND
                   ((AND (fetch
 (CHARITEM DUMMYFLG) of
 CHARITEM)
                         (NOT (IEQP I DUMMYINDEX)))
                    (\FSETOFFSET OFFSETS I DUMMYOFFSET))
                   (T (\FSETOFFSET OFFSETS I OFFSET)
                      (BITBLT BITMAP 0 0 CB OFFSET 0 WIDTH HEIGHT 'INPUT 'REPLACE)
                      (SETQ OFFSET (IPLUS OFFSET WIDTH]      (* FIRSTCHAR & LASTCHAR.

                                                             (I wonder what you're suppose to do if 

                                                             there aren't any chars?) *)

          [SETQ FIRSTCHAR (\CHAR8CODE (fetch
 (CHARITEM CHARCODE)
                                         of
 (for
 CHARITEM in
 CHARITEMS
                                               thereis
 (NOT (fetch
 (CHARITEM DUMMYFLG) of
 CHARITEM]
          [SETQ LASTCHAR (\CHAR8CODE (fetch
 (CHARITEM CHARCODE)
                                        of
 (for
 CHARITEM in
 (REVERSE CHARITEMS)
                                              thereis
 (NOT (fetch
 (CHARITEM DUMMYFLG) of
 CHARITEM]
          [SETQ CHARSET (\CHARSET (fetch
 (CHARITEM CHARCODE) of
 (CAR CHARITEMS]
                                                             (* Store new info. *)

          (UNINTERRUPTABLY
              (replace
 (CHARSETINFO CHARSETBITMAP) of
 CSINFO with
 CB)
              (replace
 (CHARSETINFO WIDTHS) of
 CSINFO with
 WIDTHS)
              (replace
 (CHARSETINFO OFFSETS) of
 CSINFO with
 OFFSETS)
              (\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR)
              (replace
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO with
 WIDTHS))
                                                             (* OKEY DOKEY. *)

      ])

(EF.BLANK

  [LAMBDA (FAMILY SIZE FACE FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTH)
                                                             (* kbr%: "21-Oct-85 15:25")

    (PROG (FONT CSINFO WIDTHS DUMMYWIDTH OFFSETS DUMMYOFFSET CB CBWIDTH CBHEIGHT)
          (SETQ FAMILY (U-CASE FAMILY))
          (COND
             ((NOT (FIXP SIZE))
              (LISPERROR "ILLEGAL ARG" SIZE)))
          (SETQ FACE (\FONTFACE FACE))
          (COND
             ((NOT (SMALLP FIRSTCHAR))
              (LISPERROR "ILLEGAL ARG" FIRSTCHAR)))
          (COND
             ((NOT (SMALLP LASTCHAR))
              (LISPERROR "ILLEGAL ARG" LASTCHAR)))
          (COND
             ((NOT (SMALLP ASCENT))
              (LISPERROR "ILLEGAL ARG" ASCENT)))
          (COND
             ((NOT (SMALLP DESCENT))
              (LISPERROR "ILLEGAL ARG" DESCENT)))
          (COND
             ([NOT (OR (FIXP WIDTH)
                       (AND (LISTP WIDTH)
                            [NOT (for
 W in
 WIDTH thereis
 (NOT (FIXP W]
                            (IEQP (LENGTH WIDTH)
                                  (IPLUS LASTCHAR (IMINUS FIRSTCHAR)
                                         1 1]
              (LISPERROR "ILLEGAL ARG" WIDTH)))              (* WIDTHS. *)

          (SETQ CSINFO (create
 CHARSETINFO
                              CHARSETASCENT _ ASCENT
                              CHARSETDESCENT _ DESCENT))
          (SETQ WIDTHS (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO))
          [COND
             ((LISTP WIDTH)
              (SETQ DUMMYWIDTH (CAR (LAST WIDTH)))
              (for
 I from
 0 to
 (SUB1 FIRSTCHAR) do
 (\FSETWIDTH WIDTHS I DUMMYWIDTH))
              (for
 I from
 FIRSTCHAR to
 LASTCHAR as
 W in
 WIDTH do
 (\FSETWIDTH WIDTHS I W))
              (for
 I from
 (ADD1 LASTCHAR) to
 DUMMYINDEX do
 (\FSETWIDTH WIDTHS I DUMMYWIDTH)))
             (T (for
 I from
 0 to
 DUMMYINDEX 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]
          (SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS (ADD1 LASTCHAR)))
          (for
 I from
 0 to
 (SUB1 FIRSTCHAR) do
 (\FSETOFFSET OFFSETS I DUMMYOFFSET))
          (for
 I from
 (ADD1 LASTCHAR) to
 DUMMYINDEX do
 (\FSETOFFSET OFFSETS I DUMMYOFFSET))
                                                             (* Characterbitmap CB.

                                                             *)

          (SETQ CBHEIGHT (IPLUS ASCENT DESCENT))
          (SETQ CBWIDTH (IPLUS (\FGETOFFSET OFFSETS DUMMYINDEX)
                               (\FGETWIDTH WIDTHS DUMMYINDEX)))
          (SETQ CB (BITMAPCREATE CBWIDTH CBHEIGHT))
          (replace
 (CHARSETINFO CHARSETBITMAP) of
 CSINFO with
 CB)
                                                             (* FONT. *)

          (\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR)
          (replace
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO with
 (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO))
          [SETQ FONT
           (create
 FONTDESCRIPTOR
                  FONTDEVICE _ 'DISPLAY
                  FONTFAMILY _ FAMILY
                  FONTSIZE _ SIZE
                  FONTFACE _ FACE
                  \SFAscent _ 0
                  \SFDescent _ 0
                  \SFHeight _ 0
                  ROTATION _ 0
                  FONTDEVICESPEC _ (LIST FAMILY SIZE FACE 0 'DISPLAY]
          (replace
 (FONTDESCRIPTOR \SFAscent) of
 FONT with
 (IMAX (fetch
 (FONTDESCRIPTOR \SFAscent)
                                                                    of
 FONT)
                                                                 (fetch
 (CHARSETINFO CHARSETASCENT)
                                                                    of
 CSINFO)))
          (replace
 (FONTDESCRIPTOR \SFDescent) of
 FONT with
 (IMAX (fetch
 (FONTDESCRIPTOR \SFDescent)
                                                                     of
 FONT)
                                                                  (fetch
 (CHARSETINFO CHARSETDESCENT)
                                                                     of
 CSINFO)))
          [replace
 (FONTDESCRIPTOR \SFHeight) of
 FONT with
 (IMAX (fetch
 (FONTDESCRIPTOR \SFHeight)
                                                                    of
 FONT)
                                                                 (IPLUS (fetch
 (CHARSETINFO 
                                                                                      CHARSETASCENT)
                                                                           of
 CSINFO)
                                                                        (fetch
 (CHARSETINFO 
                                                                                      CHARSETDESCENT)
                                                                           of
 CSINFO]
          (\SETCHARSETINFO (fetch
 (FONTDESCRIPTOR FONTCHARSETVECTOR) of
 FONT)
                 0 CSINFO)
          (replace
 (FONTDESCRIPTOR FONTAVGCHARWIDTH) of
 FONT with
 (\AVGCHARWIDTH FONT))
          (RETURN FONT])

(COPYFONT

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

    (PROG (NEWFONT NEWCHARSETVECTOR OLDCHARSETVECTOR NEWCSINFO OLDCSINFO)
          (SETQ NEWFONT (create
 FONTDESCRIPTOR using
 FONT))
          (SETQ NEWCHARSETVECTOR (\ALLOCBLOCK (ADD1 \MAXCHARSET)
                                        T))
          (SETQ OLDCHARSETVECTOR (fetch
 (FONTDESCRIPTOR FONTCHARSETVECTOR) of
 FONT))
          [for
 CHARSET from
 0 to
 \MAXCHARSET
             do
 (SETQ OLDCSINFO (\GETBASEPTR OLDCHARSETVECTOR (UNFOLD CHARSET 2)))
                (COND
                   (OLDCSINFO [SETQ NEWCSINFO (create
 CHARSETINFO
                                                     CHARSETASCENT _ (fetch
 (CHARSETINFO 
                                                                                   CHARSETASCENT)
                                                                        of
 OLDCSINFO)
                                                     CHARSETDESCENT _ (fetch
 (CHARSETINFO 
                                                                                    CHARSETDESCENT)
                                                                         of
 OLDCSINFO)
                                                     CHARSETBITMAP _ (COPYALL (fetch
 (CHARSETINFO
                                                                                      CHARSETBITMAP)
                                                                                 of
 OLDCSINFO]
                          (\BLT (fetch
 (CHARSETINFO WIDTHS) of
 NEWCSINFO)
                                (fetch
 (CHARSETINFO WIDTHS) of
 OLDCSINFO)
                                (ADD1 DUMMYINDEX))
                          (\BLT (fetch
 (CHARSETINFO OFFSETS) of
 NEWCSINFO)
                                (fetch
 (CHARSETINFO OFFSETS) of
 OLDCSINFO)
                                (ADD1 DUMMYINDEX))
                          (replace
 (CHARSETINFO IMAGEWIDTHS) of
 NEWCSINFO with
 (fetch
 (CHARSETINFO
                                                                                       WIDTHS)
                                                                                  of
 NEWCSINFO))
                          (\RPLPTR NEWCHARSETVECTOR (UNFOLD CHARSET 2)
                                 NEWCSINFO]
          (RETURN NEWFONT])

(READSTRIKEFONTFILE

  [LAMBDA (FAMILY SIZE FACE FILE FONT CHARSET)

    (* ;; "Edited 12-Jul-2022 14:16 by rmk: Removed slightlly different implementations of \READSTRIKEFONTFILE and charset installation in favor of common code in FONT.")


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

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

    (CL:UNLESS CHARSET (SETQ CHARSET 0))                     (* ; "Returns fontdescriptor FONT.  *")

    (LET (STRM CSINFO)
         (SETQ STRM (OPENSTREAM FILE 'INPUT 'OLD))
         (\WIN STRM)
         (SETQ CSINFO (\READSTRIKEFONTFILE STRM FAMILY SIZE FACE))
         (CLOSEF STRM)                                       (* ; 

                                                            "This part imitates \CREATEDISPLAYFONT *")

         (CL:UNLESS FONT
             [SETQ FONT
              (create
 FONTDESCRIPTOR
                     FONTDEVICE _ 'DISPLAY
                     FONTFAMILY _ FAMILY
                     FONTSIZE _ SIZE
                     FONTFACE _ FACE
                     \SFAscent _ 0
                     \SFDescent _ 0
                     \SFHeight _ 0
                     ROTATION _ 0
                     FONTDEVICESPEC _ (LIST FAMILY SIZE FACE 0 'DISPLAY])
         (\INSTALLCHARSETINFO FONT CSINFO CHARSET)
         FONT])
)
(DEFINEQ

(BLANKFONTCREATE

  [LAMBDA (FAMILY SIZE FACE FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTH)
                                                             (* mjs "27-Mar-85 14:48")

    (EF.BLANK
 FAMILY SIZE FACE FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTH])

(EDITFONT

  [LAMBDA (FONT FROMCHARCODE TOCHARCODE CHARSET)
             (* ; "Edited 27-Jun-2022 10:47 by rmk")

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

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

    (SETQ FONT (FONTCREATE FONT))
    (CL:UNLESS FROMCHARCODE (SETQ FROMCHARCODE 0))
    (CL:UNLESS TOCHARCODE (SETQ TOCHARCODE 255))
    (CL:UNLESS CHARSET (SETQ CHARSET 0))
    (PROG (CHARITEMS MENU TITLE HEIGHT WIDTH REGION POS WINDOW)
          (SETQ CHARITEMS (EF.CHARITEMS
 FONT FROMCHARCODE TOCHARCODE CHARSET))
          (SETQ MENU
           (create
 MENU
                  MENUFONT _ FONT
                  CENTERFLG _ T
                  MENUCOLUMNS _ 16
                  ITEMS _ CHARITEMS
                  WHENSELECTEDFN _ (FUNCTION EF.WHENSELECTEDFN)))
          [SETQ TITLE (PACK* (FONTPROP FONT 'FAMILY)
                             (FONTPROP FONT 'SIZE)
                             (PACKC (for
 ATOM in
 (FONTPROP FONT 'FACE) collect
 (CHCON1 ATOM]
          (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)
          (ADDMENU MENU WINDOW (create
 POSITION
                                      XCOORD _ 0
                                      YCOORD _ 0))
          (WINDOWPROP WINDOW 'BUTTONEVENTFN 'EF.BUTTONEVENTFN])
)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(RPAQQ BITSPERWORD
 16)

(RPAQQ BYTESPERWORD
 2)

(RPAQQ MAXCODE
 255)

(RPAQQ DUMMYINDEX
 256)


(CONSTANTS (BITSPERWORD 16)
       (BYTESPERWORD 2)
       (MAXCODE 255)
       (DUMMYINDEX 256))
)


(FILESLOAD (LOADCOMP)
       FONT)
)

(EF.INIT
)
(PUTPROPS EDITFONT COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1567 26117 (EF.INIT 1577 . 2303) (EF.PROMPT 2305 . 2887) (EF.MESSAGE 2889 . 3101) (
EF.CLOSEFN 3103 . 3630) (EF.CHARITEMS 3632 . 5853) (EF.BUTTONEVENTFN 5855 . 6267) (EF.WHENSELECTEDFN 
6269 . 6673) (EF.EDITBM 6675 . 8073) (EF.MIDDLEBUTTONFN 8075 . 8320) (EF.CHANGESIZE 8322 . 9541) (
EF.DELETE 9543 . 10308) (EF.ENTER 10310 . 11141) (EF.REPLACE 11143 . 12006) (EF.SAVE 12008 . 16681) (
EF.BLANK 16683 . 22308) (COPYFONT 22310 . 24750) (READSTRIKEFONTFILE 24752 . 26115)) (26118 28332 (
BLANKFONTCREATE 26128 . 26385) (EDITFONT 26387 . 28330)))))
STOP