(FILECREATED "14-Feb-85 17:55:17" {ERIS}<LISPCORE>LISPUSERS>EDITFONT.;2 31239
changes to: (VARS EDITFONTCOMS)
(FNS WRITESTRIKEFONTFILE)
previous date: "15-Dec-84 15:21:20" {ERIS}<LISPCORE>LISPUSERS>EDITFONT.;1)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT EDITFONTCOMS)
(RPAQQ EDITFONTCOMS ((CONSTANTS (BITSPERWORD 16)
(BYTESPERWORD 2)
(MAXCODE 255)
(DUMMYINDEX 256)
(LASTINDEX 257)
(NINDEXS 258))
(INITVARS (EF.MENU NIL))
(RECORDS CHARITEM)
(FNS EF.INIT EF.EDIT EF.PROMPT EF.MESSAGE EF.CLOSEFN EF.CHARITEMS EF.WHENSELECTEDFN EF.EDITBM
EF.MIDDLEBUTTONFN EF.CHANGESIZE EF.DELETE EF.ENTER EF.REPLACE EF.SWITCH EF.EXIT EF.BLANK
EF.EXPAND EF.OUTLINE READSTRIKEFONTFILE WRITESTRIKEFONTFILE \WIN \WOUT)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (EF.INIT)))))
(DECLARE: EVAL@COMPILE
(RPAQQ BITSPERWORD 16)
(RPAQQ BYTESPERWORD 2)
(RPAQQ MAXCODE 255)
(RPAQQ DUMMYINDEX 256)
(RPAQQ LASTINDEX 257)
(RPAQQ NINDEXS 258)
(CONSTANTS (BITSPERWORD 16)
(BYTESPERWORD 2)
(MAXCODE 255)
(DUMMYINDEX 256)
(LASTINDEX 257)
(NINDEXS 258))
)
(RPAQ? EF.MENU NIL)
[DECLARE: EVAL@COMPILE
(RECORD CHARITEM (BITMAP (CHARCODE DUMMYFLG)))
]
(DEFINEQ
(EF.INIT
(LAMBDA NIL (* kbr: "15-Dec-84 15:20")
(PROG NIL
(SETQ EF.MENU (CREATE MENU
ITEMS ← '((CHANGESIZE 'EF.CHANGESIZE)
(DELETE 'EF.DELETE)
(EDITBM 'EF.EDITBM)
(ENTER 'EF.ENTER)
(REPLACE 'EF.REPLACE)
(SWITCH 'EF.SWITCH)
(EXIT 'EF.EXIT)))))))
(EF.EDIT
(LAMBDA (FONT FROMCHARCODE TOCHARCODE) (* kbr: "15-Dec-84 15:20")
(* Edit FONT. *)
(COND
((NULL FROMCHARCODE)
(SETQ FROMCHARCODE 0)))
(COND
((NULL TOCHARCODE)
(SETQ TOCHARCODE 256)))
(PROG (CHARITEMS MENU TITLE HEIGHT WIDTH REGION POS WINDOW)
(COND
((AND (FONTP FONT)
(fetch (FONTDESCRIPTOR CHARACTERBITMAP) of FONT)
(fetch (FONTDESCRIPTOR \SFWidths) of FONT)
(fetch (FONTDESCRIPTOR \SFOffsets) of FONT))
(SETQ CHARITEMS (EF.CHARITEMS FONT))
(SETQ MENU (CREATE MENU
MENUFONT ← FONT
CENTERFLG ← T
MENUCOLUMNS ← 16
ITEMS ← (FOR CHARITEM IN CHARITEMS AS I FROM 0 TO 256
WHEN (AND (ILEQ FROMCHARCODE I)
(ILEQ I TOCHARCODE))
COLLECT CHARITEM)
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)))
(T (printout T "Can't edit " FONT T)
(BREAK1 NIL T))))))
(EF.PROMPT
(LAMBDA (STRING) (* kbr: "15-Dec-84 15:20")
(PROG (ANSWER)
(SETQ ANSWER (MKATOM (PROMPTFORWORD STRING NIL NIL PROMPTWINDOW)))
(TERPRI PROMPTWINDOW)
(SETQ ANSWER (EVAL ANSWER))
(RETURN ANSWER))))
(EF.MESSAGE
(LAMBDA (STRING) (* kbr: "15-Dec-84 15:20")
(PROG NIL
(PRIN1 STRING PROMPTWINDOW)
(TERPRI PROMPTWINDOW))))
(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) (* kbr: "15-Dec-84 15:20")
(* Get CHARITEMS for FONT. *)
(PROG (DUMMYOFFSET DUMMYBITMAP WIDTH HEIGHT OFFSET BITMAP CHARITEM CHARITEMS)
(* Get DUMMY CHARITEM *)
(SETQ DUMMYOFFSET (ELT (fetch (FONTDESCRIPTOR \SFOffsets) of FONT)
DUMMYINDEX))
(SETQ WIDTH (ELT (fetch (FONTDESCRIPTOR \SFWidths) of FONT)
DUMMYINDEX))
(SETQ HEIGHT (fetch (FONTDESCRIPTOR \SFHeight) of FONT))
(SETQ DUMMYBITMAP (BITMAPCREATE WIDTH HEIGHT))
(BITBLT (fetch (FONTDESCRIPTOR CHARACTERBITMAP) of FONT)
DUMMYOFFSET 0 DUMMYBITMAP 0 0 WIDTH HEIGHT 'INPUT 'REPLACE)
(SETQ CHARITEM (CREATE CHARITEM
BITMAP ← DUMMYBITMAP
CHARCODE ← DUMMYINDEX
DUMMYFLG ← T))
(PUSH CHARITEMS CHARITEM) (* Get ordinairy CHARITEMs. *)
(FOR I FROM MAXCODE TO 0 BY -1
DO (SETQ OFFSET (ELT (fetch (FONTDESCRIPTOR \SFOffsets) of FONT)
I))
(COND
((IEQP OFFSET DUMMYOFFSET)
(SETQ CHARITEM (CREATE CHARITEM
BITMAP ← DUMMYBITMAP
CHARCODE ← I
DUMMYFLG ← T)))
(T (SETQ WIDTH (ELT (fetch (FONTDESCRIPTOR \SFWidths) of FONT)
I))
(SETQ HEIGHT (fetch (FONTDESCRIPTOR \SFHeight) of FONT))
(SETQ BITMAP (BITMAPCREATE WIDTH HEIGHT))
(BITBLT (fetch (FONTDESCRIPTOR CHARACTERBITMAP) of FONT)
OFFSET 0 BITMAP 0 0 WIDTH HEIGHT 'INPUT 'REPLACE)
(SETQ CHARITEM (CREATE CHARITEM
BITMAP ← BITMAP
CHARCODE ← I
DUMMYFLG ← NIL))))
(PUSH CHARITEMS CHARITEM)) (* OKEY DOKEY *)
(RETURN CHARITEMS))))
(EF.WHENSELECTEDFN
(LAMBDA (CHARITEM MENU KEY) (* kbr: "15-Dec-84 15:20")
(PROG NIL
(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: "15-Dec-84 15:20")
(* Change height & width of CHARITEM%'s BITMAP *)
(PROG (HEIGHT WIDTH NEWBITMAP)
(SETQ HEIGHT (EF.PROMPT "New height (evaluated):"))
(COND
((NULL HEIGHT)
(EF.MESSAGE "Aborted.")
(RETURN)))
(SETQ HEIGHT (EVAL HEIGHT))
(SETQ WIDTH (EF.PROMPT "New width (evaluated):"))
(COND
((NULL WIDTH)
(EF.MESSAGE "Aborted.")
(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: "15-Dec-84 15:20")
(* Replace BITMAP of CHARITEM.
*)
(PROG (BITMAP)
(SETQ BITMAP (EF.PROMPT "New bitmap (evaluated):"))
(COND
((NULL BITMAP)
(EF.MESSAGE "Aborted."))
((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.SWITCH
(LAMBDA (CHARITEM MENU) (* kbr: "15-Dec-84 15:20")
(* Switch bitmaps of two charcodes *)
(PROG (CHARCODE1 CHARCODE2 WINDOW CHARITEMS CHARITEM1 CHARITEM2 BITMAP1 BITMAP2 DUMMYFLG1
DUMMYFLG2)
(SETQ CHARCODE1 (EF.PROMPT "First charcode (evaluated):"))
(COND
((NOT (NUMBERP CHARCODE1))
(EF.MESSAGE "Aborted.")
(RETURN)))
(SETQ CHARCODE2 (EF.PROMPT "Second charcode (evaluated):"))
(COND
((NOT (NUMBERP CHARCODE2))
(EF.MESSAGE "Aborted.")
(RETURN)))
(SETQ WINDOW (WFROMMENU MENU))
(SETQ CHARITEMS (WINDOWPROP WINDOW 'CHARITEMS))
(SETQ CHARITEM1 (CAR (NTH CHARITEMS (ADD1 CHARCODE1))))
(SETQ CHARITEM2 (CAR (NTH CHARITEMS (ADD1 CHARCODE2))))
(SETQ BITMAP1 (fetch (CHARITEM BITMAP) of CHARITEM1))
(SETQ BITMAP2 (fetch (CHARITEM BITMAP) of CHARITEM2))
(SETQ DUMMYFLG1 (fetch (CHARITEM DUMMYFLG) of CHARITEM1))
(SETQ DUMMYFLG2 (fetch (CHARITEM DUMMYFLG) of CHARITEM2))
(UNINTERRUPTABLY
(replace (CHARITEM BITMAP) of CHARITEM1 with BITMAP2)
(replace (CHARITEM DUMMYFLG) of CHARITEM1 with DUMMYFLG2)
(replace (CHARITEM BITMAP) of CHARITEM2 with BITMAP1)
(replace (CHARITEM DUMMYFLG) of CHARITEM2 with DUMMYFLG1))
(UPDATE/MENU/IMAGE MENU)
(REDISPLAYW (WFROMMENU MENU)))))
(EF.EXIT
(LAMBDA (CHARITEM MENU) (* kbr: "15-Dec-84 15:20")
(* Save EDITFONT changes to FONT.
*)
(PROG (WINDOW CHARITEMS FONT CB CBWIDTH CBHEIGHT WIDTHS OFFSETS HEIGHT WIDTH DUMMYOFFSET OFFSET
BITMAP FIRSTCHAR LASTCHAR)
(SETQ WINDOW (WFROMMENU MENU))
(SETQ CHARITEMS (WINDOWPROP WINDOW 'CHARITEMS))
(SETQ FONT (fetch (MENU MENUFONT) of MENU)) (* 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 CB (BITMAPCREATE CBWIDTH CBHEIGHT))
(SETQ OFFSETS (ARRAY NINDEXS 'SMALLPOSP 0 0))
(SETQ WIDTHS (ARRAY NINDEXS 'SMALLPOSP 0 0)) (* Store new info in allocations.
*)
(SETQ OFFSET 0)
(SETQ DUMMYOFFSET (IDIFFERENCE CBWIDTH (fetch (BITMAP BITMAPWIDTH)
of (fetch (CHARITEM BITMAP)
of (CAR (LAST CHARITEMS))))))
(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))
(SETA WIDTHS I WIDTH)
(COND
((AND (fetch (CHARITEM DUMMYFLG) of CHARITEM)
(NOT (IEQP I DUMMYINDEX)))
(SETA OFFSETS I DUMMYOFFSET))
(T (SETA OFFSETS I OFFSET)
(BITBLT BITMAP 0 0 CB OFFSET 0 WIDTH HEIGHT 'INPUT 'REPLACE)
(SETQ OFFSET (IPLUS OFFSET WIDTH)))))
(SETA OFFSETS LASTINDEX CBWIDTH)
(SETA WIDTHS LASTINDEX 0) (* FIRSTCHAR & LASTCHAR. (I wonder what you%'re suppose
to do if there aren%'t any chars?) *)
(SETQ FIRSTCHAR (fetch (CHARITEM CHARCODE) of (FOR CHARITEM IN CHARITEMS
THEREIS (NOT (fetch (CHARITEM DUMMYFLG)
of CHARITEM)))))
(SETQ LASTCHAR (fetch (CHARITEM CHARCODE) of (FOR CHARITEM IN (REVERSE CHARITEMS)
THEREIS (NOT (fetch (CHARITEM DUMMYFLG)
of CHARITEM)))))
(* Store new info. *)
(UNINTERRUPTABLY
(replace (FONTDESCRIPTOR CHARACTERBITMAP) of FONT with CB)
(replace (FONTDESCRIPTOR \SFWidths) of FONT with WIDTHS)
(replace (FONTDESCRIPTOR \SFOffsets) of FONT with OFFSETS)
(replace (FONTDESCRIPTOR FIRSTCHAR) of FONT with FIRSTCHAR)
(replace (FONTDESCRIPTOR LASTCHAR) of FONT with LASTCHAR))
(* OKEY DOKEY. *)
)))
(EF.BLANK
(LAMBDA (FAMILY SIZE FACE FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTH)
(* kbr: "15-Dec-84 15:20")
(PROG (FONT 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 (SMALLPOSP FIRSTCHAR))
(LISPERROR "ILLEGAL ARG" FIRSTCHAR)))
(COND
((NOT (SMALLPOSP LASTCHAR))
(LISPERROR "ILLEGAL ARG" LASTCHAR)))
(COND
((NOT (SMALLPOSP ASCENT))
(LISPERROR "ILLEGAL ARG" ASCENT)))
(COND
((NOT (SMALLPOSP 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 WIDTHS (ARRAY NINDEXS 'SMALLPOSP 0 0))
(COND
((LISTP WIDTH)
(SETQ DUMMYWIDTH (CAR (LAST WIDTH)))
(FOR I FROM 0 TO (SUB1 FIRSTCHAR) DO (SETA WIDTHS I DUMMYWIDTH))
(FOR I FROM FIRSTCHAR TO LASTCHAR AS W IN WIDTH DO (SETA WIDTHS I W))
(FOR I FROM (ADD1 LASTCHAR) TO DUMMYINDEX DO (SETA WIDTHS I DUMMYWIDTH)))
(T (FOR I FROM 0 TO DUMMYINDEX DO (SETA WIDTHS I WIDTH))))
(* OFFSETS. *)
(SETQ OFFSETS (ARRAY NINDEXS 'SMALLPOSP 0 0))
(FOR I FROM FIRSTCHAR TO (ADD1 LASTCHAR) DO (SETA OFFSETS (ADD1 I)
(IPLUS (ELT OFFSETS I)
(ELT WIDTHS I))))
(SETQ DUMMYOFFSET (ELT OFFSETS (ADD1 LASTCHAR)))
(SETA OFFSETS LASTINDEX (ELT OFFSETS (ADD1 (ADD1 LASTCHAR))))
(FOR I FROM 0 TO (SUB1 FIRSTCHAR) DO (SETA OFFSETS I DUMMYOFFSET))
(FOR I FROM (ADD1 LASTCHAR) TO DUMMYINDEX DO (SETA OFFSETS I DUMMYOFFSET))
(* Characterbitmap CB. *)
(SETQ CBHEIGHT (IPLUS ASCENT DESCENT))
(SETQ CBWIDTH (ELT OFFSETS LASTINDEX))
(SETQ CB (BITMAPCREATE CBWIDTH CBHEIGHT)) (* FONT. *)
(SETQ FONT (CREATE FONTDESCRIPTOR
FONTDEVICE ← 'DISPLAY
CHARACTERBITMAP ← CB
FONTFAMILY ← FAMILY
FONTSIZE ← SIZE
FONTFACE ← FACE
\SFWidths ← WIDTHS
\SFOffsets ← OFFSETS
FIRSTCHAR ← FIRSTCHAR
LASTCHAR ← LASTCHAR
\SFAscent ← ASCENT
\SFDescent ← DESCENT
\SFHeight ← CBHEIGHT
ROTATION ← 0
FONTSCALE ← 1))
(replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT with (\AVGCHARWIDTH FONT))
(RETURN FONT))))
(EF.EXPAND
(LAMBDA (FONT WIDTHFACTOR HEIGHTFACTOR) (* kbr: "15-Dec-84 15:20")
(PROG (CB WIDTHS OFFSETS)
(COND
((NOT (FONTP FONT))
(LISPERROR "ILLEGAL ARG" FONT)))
(SETQ FONT (COPYALL FONT))
(SETQ CB (fetch (FONTDESCRIPTOR CHARACTERBITMAP) of FONT))
(SETQ WIDTHS (fetch (FONTDESCRIPTOR \SFWidths) of FONT))
(SETQ OFFSETS (fetch (FONTDESCRIPTOR \SFOffsets) of FONT))
(SETQ CB (EXPANDBITMAP CB WIDTHFACTOR HEIGHTFACTOR))
(replace (FONTDESCRIPTOR CHARACTERBITMAP) of FONT with CB)
(FOR I FROM 0 TO 256
DO (SETA WIDTHS I (ITIMES WIDTHFACTOR (ELT WIDTHS I)))
(SETA OFFSETS I (ITIMES WIDTHFACTOR (ELT OFFSETS I))))
(replace (FONTDESCRIPTOR FONTSIZE) of FONT with (ITIMES HEIGHTFACTOR (fetch (FONTDESCRIPTOR
FONTSIZE)
of FONT)))
(replace (FONTDESCRIPTOR \SFAscent) of FONT with (ITIMES HEIGHTFACTOR (fetch (FONTDESCRIPTOR
\SFAscent)
of FONT)))
(replace (FONTDESCRIPTOR \SFDescent) of FONT with (ITIMES HEIGHTFACTOR (fetch (
FONTDESCRIPTOR \SFDescent) of FONT)))
(replace (FONTDESCRIPTOR \SFHeight) of FONT with (ITIMES HEIGHTFACTOR (fetch (FONTDESCRIPTOR
\SFHeight)
of FONT)))
(RETURN FONT))))
(EF.OUTLINE
(LAMBDA (FONT) (* kbr: "15-Dec-84 15:20")
(PROG (FIRSTCHAR LASTCHAR WIDTHS SB DB NEWFAMILY NEWFONT)
(COND
((NOT (FONTP FONT))
(LISPERROR "ILLEGAL ARG" FONT)))
(SETQ FIRSTCHAR (fetch (FONTDESCRIPTOR FIRSTCHAR) of FONT))
(SETQ LASTCHAR (fetch (FONTDESCRIPTOR LASTCHAR) of FONT))
(SETQ WIDTHS (fetch (FONTDESCRIPTOR \SFWidths) of FONT))
(SETQ NEWFAMILY (PACK* (FONTPROP FONT 'FAMILY)
'OUTLINE))
(SETQ NEWFONT (EF.BLANK NEWFAMILY (IPLUS (FONTPROP FONT 'SIZE)
2)
(FONTPROP FONT 'FACE)
FIRSTCHAR LASTCHAR (IPLUS (FONTPROP FONT 'ASCENT)
2)
(FONTPROP FONT 'DESCENT)
(FOR I FROM FIRSTCHAR TO (ADD1 LASTCHAR)
COLLECT (IPLUS 2 (ELT WIDTHS I)))))
(* DB = Destination Bitmap. SB = Source Bitmap.
*)
(FOR I FROM FIRSTCHAR TO (ADD1 LASTCHAR)
DO (SETQ SB (GETCHARBITMAP I FONT))
(SETQ DB (GETCHARBITMAP I NEWFONT))
(BITBLT SB NIL NIL DB 0 0 NIL NIL 'INPUT 'PAINT)
(BITBLT SB NIL NIL DB 0 1 NIL NIL 'INPUT 'PAINT)
(BITBLT SB NIL NIL DB 0 2 NIL NIL 'INPUT 'PAINT)
(BITBLT SB NIL NIL DB 1 0 NIL NIL 'INPUT 'PAINT)
(BITBLT SB NIL NIL DB 1 1 NIL NIL 'INPUT 'PAINT)
(BITBLT SB NIL NIL DB 1 2 NIL NIL 'INPUT 'PAINT)
(BITBLT SB NIL NIL DB 2 0 NIL NIL 'INPUT 'PAINT)
(BITBLT SB NIL NIL DB 2 1 NIL NIL 'INPUT 'PAINT)
(BITBLT SB NIL NIL DB 2 2 NIL NIL 'INPUT 'PAINT)
(BITBLT SB NIL NIL DB 1 1 NIL NIL 'INPUT 'ERASE)
(PUTCHARBITMAP I NEWFONT DB)) (* OKEY DOKEY. *)
(RETURN NEWFONT))))
(READSTRIKEFONTFILE
(LAMBDA (FAMILY SIZE FACE FILE) (* kbr: "15-Dec-84 15:20")
(* Very similar to \READSTRIKEFONTFILE of
<LISPCORE>SOURCES>FONT. Returns fontdescriptor FONT.
*)
(PROG (STREAM FONT NUMBCODES RASTERWIDTH CB OFFSETS)
(SETQ STREAM (OPENSTREAM FILE 'INPUT 'OLD))
(COND
((ZEROP (LOGAND (\WIN STREAM)
16384)) (* First check to make sure it is a vanilla strike
font%, not a strike index.)
(* first word has high bits (onebit index fixed). Onebit means "new-style font", index is 0 for simple strike%, 1
for index%, and fixed is if all chars have max width. Lisp doesn%'t care about "fixed")
(SETQ FONT (CREATE FONTDESCRIPTOR
FONTFAMILY ← FAMILY
FONTSIZE ← SIZE
FONTFACE ← FACE
FONTDEVICE ← 'DISPLAY
FONTSCALE ← 1)) (* minimum ascii code)
(replace (FONTDESCRIPTOR FIRSTCHAR) of FONT with (\WIN STREAM))
(* maximum ascii code)
(replace (FONTDESCRIPTOR LASTCHAR) of FONT with (\WIN STREAM))
(* MaxWidth which isn%'t used by anyone.)
(\WIN STREAM) (* number of words in this StrikeBody)
(\WIN STREAM) (* ascent in scan lines (=FBBdy+FBBoy))
(replace (FONTDESCRIPTOR \SFAscent) of FONT with (\WIN STREAM))
(* descent in scan-lines (=FBBoy))
(replace (FONTDESCRIPTOR \SFDescent) of FONT with (\WIN STREAM))
(* offset in bits (<0 for kerning%, else 0%, =FBBox))
(\WIN STREAM) (* raster width of bitmap)
(SETQ RASTERWIDTH (\WIN STREAM)) (* height of bitmap)
(replace (FONTDESCRIPTOR \SFHeight) of FONT with (IPLUS (fetch (FONTDESCRIPTOR
\SFAscent)
of FONT)
(fetch (FONTDESCRIPTOR
\SFDescent)
of FONT)))
(SETQ CB (BITMAPCREATE (ITIMES RASTERWIDTH BITSPERWORD)
(fetch (FONTDESCRIPTOR \SFHeight) of FONT)))
(* read bits into bitmap)
(\BINS STREAM (fetch (BITMAP BITMAPBASE) of CB)
0
(ITIMES (ITIMES RASTERWIDTH (fetch (FONTDESCRIPTOR \SFHeight) of FONT))
BYTESPERWORD))
(replace (FONTDESCRIPTOR CHARACTERBITMAP) of FONT with CB)
(SETQ NUMBCODES (IPLUS (IDIFFERENCE (fetch (FONTDESCRIPTOR LASTCHAR) of FONT)
(fetch (FONTDESCRIPTOR FIRSTCHAR) of FONT))
3))
(SETQ OFFSETS (ARRAY NINDEXS 'SMALLPOSP 0 0))
(AIN OFFSETS (fetch (FONTDESCRIPTOR FIRSTCHAR) of FONT)
NUMBCODES STREAM)
(replace (FONTDESCRIPTOR \SFOffsets) of FONT with OFFSETS)
(replace (FONTDESCRIPTOR \SFWidths) of FONT with (ARRAY NINDEXS 'SMALLPOSP 0 0))
(\FONTRESETCHARWIDTHS FONT)
(replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT with (\AVGCHARWIDTH FONT))))
(CLOSEF STREAM)
(RETURN FONT))))
(WRITESTRIKEFONTFILE
(LAMBDA (FONT FILE) (* kbr: "14-Feb-85 17:52")
(* Write strike FILE using info in FONT.
*)
(PROG (STREAM FIRSTCHAR LASTCHAR WIDTH MAXWIDTH LENGTH RASTERWIDTH DUMMYCHAR DUMMYOFFSET OFFSET
PREVIOUSOFFSET WIDTH CODE)
(COND
((NOT (FONTP FONT))
(LISPERROR "ILLEGAL ARG" FONT)))
(SETQ FIRSTCHAR (fetch (FONTDESCRIPTOR FIRSTCHAR) of FONT))
(SETQ LASTCHAR (fetch (FONTDESCRIPTOR LASTCHAR) of FONT))
(SETQ STREAM (OPENSTREAM FILE (QUOTE OUTPUT)
(QUOTE NEW)
8
(QUOTE ((TYPE BINARY)))))
(* STRIKE HEADER. *)
(\WOUT STREAM 32768)
(\WOUT STREAM FIRSTCHAR)
(\WOUT STREAM LASTCHAR)
(SETQ MAXWIDTH 0)
(for I from 0 to LASTINDEX do (SETQ MAXWIDTH (IMAX MAXWIDTH (ELT (fetch (FONTDESCRIPTOR
\SFWidths)
of FONT)
I))))
(\WOUT STREAM MAXWIDTH) (* STRIKE BODY. *)
(* Length. *)
(SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of (fetch (FONTDESCRIPTOR
CHARACTERBITMAP)
of FONT)))
(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 (FONTDESCRIPTOR \SFAscent) of FONT))
(\WOUT STREAM (fetch (FONTDESCRIPTOR \SFDescent) of FONT))
(\WOUT STREAM 0)
(\WOUT STREAM RASTERWIDTH) (* Bitmap. *)
(\BOUTS STREAM (fetch (BITMAP BITMAPBASE) of (fetch (FONTDESCRIPTOR CHARACTERBITMAP)
of FONT))
0
(ITIMES 2 RASTERWIDTH (fetch (FONTDESCRIPTOR \SFHeight) of FONT)))
(* Offsets. *)
(SETQ DUMMYCHAR (ADD1 LASTCHAR))
(SETQ DUMMYOFFSET (ELT (fetch (FONTDESCRIPTOR \SFOffsets) of FONT)
DUMMYINDEX))
(SETQ CODE 0)
(\WOUT STREAM CODE)
(for I from FIRSTCHAR to DUMMYCHAR
do (SETQ OFFSET (ELT (fetch (FONTDESCRIPTOR \SFOffsets) of FONT)
I))
(SETQ WIDTH (ELT (fetch (FONTDESCRIPTOR \SFWidths) of FONT)
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))))
(\WIN
(LAMBDA (STREAM) (* kbr: "15-Dec-84 15:20")
(IPLUS (LLSH (\BIN STREAM)
8)
(\BIN STREAM))))
(\WOUT
(LAMBDA (STREAM WORD) (* kbr: "15-Dec-84 15:20")
(\BOUT STREAM (IQUOTIENT WORD 256))
(\BOUT STREAM (IREMAINDER WORD 256))))
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(EF.INIT)
)
(PUTPROPS EDITFONT COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1278 31116 (EF.INIT 1288 . 1661) (EF.EDIT 1663 . 3622) (EF.PROMPT 3624 . 3957) (
EF.MESSAGE 3959 . 4165) (EF.CLOSEFN 4167 . 4631) (EF.CHARITEMS 4633 . 6658) (EF.WHENSELECTEDFN 6660 .
6986) (EF.EDITBM 6988 . 8263) (EF.MIDDLEBUTTONFN 8265 . 8533) (EF.CHANGESIZE 8535 . 9651) (EF.DELETE
9653 . 10411) (EF.ENTER 10413 . 11168) (EF.REPLACE 11170 . 11903) (EF.SWITCH 11905 . 13636) (EF.EXIT
13638 . 17067) (EF.BLANK 17069 . 20391) (EF.EXPAND 20393 . 21958) (EF.OUTLINE 21960 . 23878) (
READSTRIKEFONTFILE 23880 . 27562) (WRITESTRIKEFONTFILE 27564 . 30734) (\WIN 30736 . 30911) (\WOUT
30913 . 31114)))))
STOP