(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