(FILECREATED " 7-Feb-86 11:05:47" {ERIS}<LISPUSERS>KOTO>EDITFONT.;3 42118  

      previous date: "28-Oct-85 09:40:16" {ERIS}<LISPUSERS>KOTO>EDITFONT.;2)


(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT EDITFONTCOMS)

(RPAQQ EDITFONTCOMS ((* EDITFONT -- By Kelly Roach. Need to LOAD EXPORTS.ALL and LOADFROM FONT in 
                        order to compile this file. *)
                     (CONSTANTS (BITSPERWORD 16)
                            (BYTESPERWORD 2)
                            (MAXCODE 255)
                            (DUMMYINDEX 256))
                     (INITVARS (EF.MENU NIL)
                            (EF.TITLEMENU NIL))
                     (RECORDS CHARITEM)
                     (FNS EF.INIT EF.EDIT 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 WRITESTRIKEFONTFILE)
                     (FNS BLANKFONTCREATE EDITFONT)
                     (P (EF.INIT))))



(* EDITFONT -- By Kelly Roach. Need to LOAD EXPORTS.ALL and LOADFROM FONT in order to compile 
this file. *)

(DECLARE: EVAL@COMPILE 

(RPAQQ BITSPERWORD 16)

(RPAQQ BYTESPERWORD 2)

(RPAQQ MAXCODE 255)

(RPAQQ DUMMYINDEX 256)

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

(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 _(QUOTE ((CHANGESIZE (QUOTE EF.CHANGESIZE)
                                                     "Change size of character.")
                                              (DELETE (QUOTE (QUOTE EF.DELETE))
                                                     "Delete character.")
                                              (EDITBM (QUOTE (QUOTE EF.EDITBM))
                                                     "Edit character.")
                                              (REPLACE (QUOTE (QUOTE EF.REPLACE))
                                                     "Prompt for bitmap to replace character.")))))
          (SETQ EF.TITLEMENU (create MENU
                                    ITEMS _(QUOTE ((SAVE (QUOTE EF.SAVE)
                                                         "Save EDITFONT's work back into font."))))))
    ))

(EF.EDIT
  (LAMBDA (FONT FROMCHAR8CODE TOCHAR8CODE CHARSET)                        (* kbr: 
                                                                          "21-Oct-85 15:35")
                                                                          (* Edit FONT.
                                                                          *)
    (COND
       ((NULL FROMCHAR8CODE)
        (SETQ FROMCHAR8CODE 0)))
    (COND
       ((NULL TOCHAR8CODE)
        (SETQ TOCHAR8CODE 255)))
    (COND
       ((NULL CHARSET)
        (SETQ CHARSET 0)))
    (PROG (CHARITEMS MENU TITLE HEIGHT WIDTH REGION POS WINDOW)
          (COND
             ((FONTP FONT)
              (SETQ CHARITEMS (EF.CHARITEMS FONT FROMCHAR8CODE TOCHAR8CODE CHARSET))
              (SETQ MENU
               (create MENU
                      MENUFONT _ FONT
                      CENTERFLG _ T
                      MENUCOLUMNS _ 16
                      ITEMS _ CHARITEMS
                      WHENSELECTEDFN _(FUNCTION EF.WHENSELECTEDFN)))
              (SETQ TITLE (PACK* (FONTPROP FONT (QUOTE FAMILY))
                                 (FONTPROP FONT (QUOTE SIZE))
                                 (PACKC (for ATOM in (FONTPROP FONT (QUOTE 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 (QUOTE CHARITEMS)
                     CHARITEMS)
              (ADDMENU MENU WINDOW (create POSITION
                                          XCOORD _ 0
                                          YCOORD _ 0))
              (WINDOWPROP WINDOW (QUOTE BUTTONEVENTFN)
                     (QUOTE EF.BUTTONEVENTFN)))
             (T (ERROR "Can't edit " 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?")
                  (QUOTE N))
              (RETURN (QUOTE DON'T))))
          (CLOSEW WINDOW)                                                 (* Break circularity.
                                                                          *)
          (WINDOWPROP WINDOW (QUOTE 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)
                           (BQUOTE (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 (QUOTE 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 (QUOTE CHARITEMS)))
          (SETQ FONT (WINDOWPROP WINDOW (QUOTE 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 (QUOTE INPUT)
                             (QUOTE 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 _(QUOTE DISPLAY)
                  FONTFAMILY _ FAMILY
                  FONTSIZE _ SIZE
                  FONTFACE _ FACE
                  \SFAscent _ 0
                  \SFDescent _ 0
                  \SFHeight _ 0
                  ROTATION _ 0
                  FONTDEVICESPEC _(LIST FAMILY SIZE FACE 0 (QUOTE 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)                                                          (* kbr: 
                                                                          "21-Oct-85 14:55")
    (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))
                          (\PUTBASEPTR NEWCHARSETVECTOR (UNFOLD CHARSET 2)
                                 NEWCSINFO))))
          (RETURN NEWFONT))))

(READSTRIKEFONTFILE
  (LAMBDA (FAMILY SIZE FACE FILE FONT CHARSET)                            (* kbr: 
                                                                          "14-Oct-85 11:16")
                                                                          (* Very similar to 
                                                                          \READSTRIKEFONTFILE of 
                                                                          <LISPCORE>SOURCES>FONT.
                                                                          Returns fontdescriptor 
                                                                          FONT. *)
    (PROG (STRM CSINFO NUMBCODES RW BITMAP OFFSETS FIRSTCHAR LASTCHAR HEIGHT WIDTHS)
                                                                          (* This part imitates 
                                                                          \READSTRIKEFONTFILE *)
          (SETQ STRM (OPENSTREAM FILE (QUOTE INPUT)
                            (QUOTE OLD)))
          (SETQ CSINFO (create CHARSETINFO))
          (\WIN STRM)
          (SETQ FIRSTCHAR (\WIN STRM))                                    (* minimum ascii code)
          (SETQ LASTCHAR (\WIN STRM))                                     (* maximum ascii code)
          (\WIN STRM)                                                     (* MaxWidth which isn't 
                                                                          used by anyone.)
          (\WIN STRM)                                                     (* number of words in 
                                                                          this StrikeBody)
          (replace (CHARSETINFO CHARSETASCENT) of CSINFO with (\WIN STRM))(* ascent in scan lines
                                                                          (=FBBdy+FBBoy))
          (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (\WIN STRM))
                                                                          (* descent in scan-lines
                                                                          (=FBBoy))
          (\WIN STRM)                                                     (* offset in bits
                                                                          (<0 for kerning, else 0, 
                                                                          =FBBox))
          (SETQ RW (\WIN STRM))                                           (* raster width of 
                                                                          bitmap)
                                                                          (* height of bitmap)
          (SETQ HEIGHT (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
                              (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)))
          (SETQ BITMAP (BITMAPCREATE (UNFOLD RW BITSPERWORD)
                              HEIGHT))
          (\BINS STRM (fetch (BITMAP BITMAPBASE) of BITMAP)
                 0
                 (UNFOLD (ITIMES RW HEIGHT)
                        BYTESPERWORD))                                    (* read bits into bitmap)
          (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with BITMAP)
          (SETQ NUMBCODES (IPLUS (IDIFFERENCE LASTCHAR FIRSTCHAR)
                                 3))                                      (* SETQ OFFSETS
                                                                          (ARRAY (IPLUS \MAXCHAR 3)
                                                                          (QUOTE SMALLPOSP) 0 0))
          (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))          (* initialise the 
                                                                          offsets to 0)
          (for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETOFFSET OFFSETS I 0))
                                                                          (* AIN OFFSETS FIRSTCHAR 
                                                                          NUMBCODES STRM)
          (for I from FIRSTCHAR as J from 1 to NUMBCODES do (\FSETOFFSET OFFSETS I (\WIN STRM)))
          (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
          (for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETWIDTH WIDTHS I 0))
                                                                          (* replace WIDTHS of 
                                                                          CSINFO with (ARRAY
                                                                          (IPLUS \MAXCHAR 3)
                                                                          (QUOTE SMALLPOSP) 0 0))
          (\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR)
          (replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with (fetch (CHARSETINFO WIDTHS) of CSINFO))
          (CLOSEF STRM)                                                   (* This part imitates 
                                                                          \CREATEDISPLAYFONT *)
          (COND
             ((NULL CHARSET)
              (SETQ CHARSET 0)))
          (COND
             ((NULL FONT)
              (SETQ FONT
               (create FONTDESCRIPTOR
                      FONTDEVICE _(QUOTE DISPLAY)
                      FONTFAMILY _ FAMILY
                      FONTSIZE _ SIZE
                      FONTFACE _ FACE
                      \SFAscent _ 0
                      \SFDescent _ 0
                      \SFHeight _ 0
                      ROTATION _ 0
                      FONTDEVICESPEC _(LIST FAMILY SIZE FACE 0 (QUOTE DISPLAY))))))
                                                                          (* This part imitates 
                                                                          \CREATECHARSET.
                                                                          *)
          (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)
                 CHARSET CSINFO)
          (replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT with (\AVGCHARWIDTH FONT))
          (RETURN FONT))))

(WRITESTRIKEFONTFILE
  (LAMBDA (FONT CHARSET FILE)                                             (* kbr: 
                                                                          "21-Oct-85 15:08")
                                                                          (* Write strike FILE 
                                                                          using info in FONT.
                                                                          *)
    (PROG (STREAM CSINFO FIRSTCHAR LASTCHAR WIDTH MAXWIDTH LENGTH RASTERWIDTH DUMMYCHAR DUMMYOFFSET 
                 OFFSET PREVIOUSOFFSET WIDTH CODE)
          (COND
             ((NOT (FONTP FONT))
              (LISPERROR "ILLEGAL ARG" FONT)))
          (COND
             ((NULL CHARSET)
              (SETQ CHARSET 0))
             ((NOT (AND (IGEQ CHARSET 0)
                        (ILESSP CHARSET \MAXCHARSET)))
              (LISPERROR "ILLEGAL ARG" CHARSET)))
          (SETQ CSINFO (\GETCHARSETINFO CHARSET FONT T))
          (COND
             ((NULL CSINFO)
              (ERROR "Couldn't find charset " CHARSET)))
          (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
          (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
          (SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS DUMMYINDEX))
          (SETQ FIRSTCHAR (for I from 0 to MAXCODE thereis (NOT (EQ (\FGETOFFSET OFFSETS I)
                                                                    DUMMYOFFSET))))
          (SETQ LASTCHAR (for I from MAXCODE to 0 by -1 thereis (NOT (EQ (\FGETOFFSET OFFSETS I)
                                                                         DUMMYOFFSET))))
          (SETQ DUMMYCHAR (ADD1 LASTCHAR))
          (SETQ STREAM (OPENSTREAM FILE (QUOTE OUTPUT)
                              (QUOTE NEW)
                              (QUOTE ((TYPE BINARY)))))                   (* STRIKE HEADER.
                                                                          *)
          (\WOUT STREAM 32768)
          (\WOUT STREAM FIRSTCHAR)
          (\WOUT STREAM LASTCHAR)
          (SETQ MAXWIDTH 0)
          (for I from 0 to DUMMYINDEX do (SETQ MAXWIDTH (IMAX MAXWIDTH (\FGETWIDTH WIDTHS I))))
          (\WOUT STREAM MAXWIDTH)                                         (* STRIKE BODY.
                                                                          *)
                                                                          (* Length. *)
          (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of (fetch (CHARSETINFO CHARSETBITMAP)
                                                                    of CSINFO)))
          (SETQ LENGTH (IPLUS 8 (IDIFFERENCE LASTCHAR FIRSTCHAR)
                              (ITIMES (fetch (FONTDESCRIPTOR \SFHeight) of FONT)
                                     RASTERWIDTH)))
          (\WOUT STREAM LENGTH)                                           (* Ascent, Descent, 
                                                                          Xoffset (no longer used) 
                                                                          and Rasterwidth.
                                                                          *)
          (\WOUT STREAM (fetch (CHARSETINFO CHARSETASCENT) of CSINFO))
          (\WOUT STREAM (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))
          (\WOUT STREAM 0)
          (\WOUT STREAM RASTERWIDTH)                                      (* Bitmap. *)
          (\BOUTS STREAM (fetch (BITMAP BITMAPBASE) of (fetch (CHARSETINFO CHARSETBITMAP)
                                                          of CSINFO))
                 0
                 (ITIMES 2 RASTERWIDTH (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
                                              (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))))
                                                                          (* Offsets. *)
          (SETQ CODE 0)
          (\WOUT STREAM CODE)
          (for I from FIRSTCHAR to DUMMYCHAR do (SETQ OFFSET (\FGETOFFSET OFFSETS I))
                                                (SETQ WIDTH (\FGETWIDTH WIDTHS I))
                                                (COND
                                                   ((AND (IEQP OFFSET DUMMYOFFSET)
                                                         (NOT (IEQP I DUMMYCHAR)))
                                                                          (* CODE stays the same.
                                                                          *)
                                                    )
                                                   (T (SETQ CODE (IPLUS CODE WIDTH))))
                                                (\WOUT STREAM CODE))
          (CLOSEF STREAM))))
)
(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)                                   (* mjs 
                                                                           "27-Mar-85 14:48")
    (EF.EDIT FONT FROMCHARCODE TOCHARCODE)))
)
(EF.INIT)
(PUTPROPS EDITFONT COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (1611 41511 (EF.INIT 1621 . 2730) (EF.EDIT 2732 . 5010) (EF.PROMPT 5012 . 5654) (
EF.MESSAGE 5656 . 5949) (EF.CLOSEFN 5951 . 6700) (EF.CHARITEMS 6702 . 9360) (EF.BUTTONEVENTFN 9362 . 
9857) (EF.WHENSELECTEDFN 9859 . 10421) (EF.EDITBM 10423 . 12313) (EF.MIDDLEBUTTONFN 12315 . 12643) (
EF.CHANGESIZE 12645 . 13916) (EF.DELETE 13918 . 14836) (EF.ENTER 14838 . 15739) (EF.REPLACE 15741 . 
16670) (EF.SAVE 16672 . 21546) (EF.BLANK 21548 . 26894) (COPYFONT 26896 . 29237) (READSTRIKEFONTFILE 
29239 . 36762) (WRITESTRIKEFONTFILE 36764 . 41509)) (41512 42024 (BLANKFONTCREATE 41522 . 41789) (
EDITFONT 41791 . 42022)))))
STOP