(FILECREATED "15-Jun-85 12:12:34" {ERIS}<LISPCORE>SOURCES>AFONT.;29 32696
changes to: (VARS AFONTCOMS)
(RECORDS BOUNDINGBOX)
(FNS \READACFONTBOXES \READACFONTFILE \ACCHARIMAGELIST)
previous date: "17-May-85 10:48:02" {ERIS}<LISPCORE>SOURCES>AFONT.;28)
(* Copyright (c) 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT AFONTCOMS)
(RPAQQ AFONTCOMS [(DECLARE: EVAL@COMPILE DONTCOPY (RECORDS BOUNDINGBOX FONTBOUNDINGBOX)
(CONSTANTS noInfoCode))
(FNS \CREATESTARFONT \READACFONTBOXES \READACFONTFILE \ACCHARIMAGELIST
\ACCHARWIDTHLIST \GETFBB \ACCHARPOSLIST \ACROTATECHAR \READFONTWDFILE
\FACECODE \FAMILYCODE \FINDFONT)
(INITVARS (INTERPRESSFONTDIRECTORIES (QUOTE ({ERIS}<LISP>FONTS>])
(DECLARE: EVAL@COMPILE DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD BOUNDINGBOX (
(* * The bounding box for a character in an AC file)
BBOX (* Offset from the left edge of the bounding box to the
character's origin)
BBOY (* Offset from the bottom of the bounding box to the
character's origin)
BBDX (* Width of the character's bounding box in pixels)
BBDY (* Height of the bounding box in bits;
-1 if this character doesn't really exist)
RASTERWIDTHX (* Width of the character's image
(i.e., the escapement for this character) in raster
bits)
RASTERWIDTHY (* Amount this char moves in Y, in raster units.)
))
(RECORD FONTBOUNDINGBOX (FBBBDX FBBBDY FBBBOX FBBBOY))
]
(DECLARE: EVAL@COMPILE
(RPAQQ noInfoCode 32768)
(CONSTANTS noInfoCode)
)
)
(DEFINEQ
(\CREATESTARFONT
[LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE CHARSET) (* rmk: " 4-Dec-84 10:00")
(* Build the font descriptor for an Interpress NS font.
If we can't find widths info for that font, return NIL)
(* Widths array is fully allocated, with zeroes for characters with no information. An array is not allocated for
fixed WidthsY. DEVICE is PRESS or INTERPRESS)
(DECLARE (GLOBALVARS INTERPRESSFONTDIRECTORIES \ASCIITONS))
(RESETLST (* RESETLST to make sure the fontfiles get closed)
(PROG [WFILE WSTRM FIXEDFLAGS RELFLAG FIRSTCHAR LASTCHAR TEM WIDTHSY
(WIDTHS (ARRAY (ADD1 \MAXCHAR)
(QUOTE SMALLPOSP)
0 0))
(NSMICASIZE (FIXR (FQUOTIENT (ITIMES PSIZE 2540)
72)))
(FD (create FONTDESCRIPTOR
FONTDEVICE ← DEVICE
FONTFAMILY ← FAMILY
FONTSIZE ← PSIZE
FONTFACE ← FACE
\SFFACECODE ←(\FACECODE FACE)
ROTATION ← ROTATION
OTHERDEVICEFONTPROPS ← \ASCIITONS
FONTSCALE ←(CONSTANT (FQUOTIENT 2540 72]
(COND
((SETQ WFILE (FINDFILE (\FONTFILENAME FAMILY PSIZE FACE (QUOTE WD)
CHARSET)
T INTERPRESSFONTDIRECTORIES))
(* Look thru INTERPRESSFONTDIRECTORIES for a .WD file
that describes the font requested.
Only continue if we can find one.)
[RESETSAVE (SETQ WSTRM (OPENSTREAM WFILE (QUOTE INPUT)
(QUOTE OLD)))
(QUOTE (PROGN (CLOSEF? OLDVALUE]
[COND
((RANDACCESSP WSTRM)
(SETFILEPTR WSTRM 0))
(T (COPYBYTES WSTRM (SETQ WSTRM (OPENSTREAM (QUOTE {NODIRCORE})
(QUOTE BOTH)
(QUOTE NEW]
(SETQ RELFLAG (\FINDFONT FD WSTRM NSMICASIZE NIL T))
(* Fill in the widths, and return a flag telling
whether the widths are absolute, or are type-size
relative. 0 => relative)
)
(T (* Can't find a file to describe this font;
return NIL)
(RETURN NIL)))
(SETQ RELFLAG (ZEROP RELFLAG)) (* Convert the flag to a logical value)
(SETFILEPTR WSTRM (UNFOLD (\FIXPIN WSTRM)
BYTESPERWORD))
(* Read the location of the WD segment for this font (we're in the directory part of the file now), and go there.)
(replace (FONTDESCRIPTOR FBBOX) of FD with (SIGNED (\WIN WSTRM)
BITSPERWORD))
(* Get the max bounding width for the font)
(replace \SFDescent of FD with (IMINUS (SIGNED (\WIN WSTRM)
BITSPERWORD)))
(* Descent is -FBBOY)
(replace (FONTDESCRIPTOR FBBDX) of FD with (SIGNED (\WIN WSTRM)
BITSPERWORD))
(* And the standard kern value
(?))
(replace \SFHeight of FD with (SIGNED (\WIN WSTRM)
BITSPERWORD))
(* Height is FBBDY)
(replace \SFWidths of FD with WIDTHS)
(SETQ FIRSTCHAR (fetch FIRSTCHAR of FD))
(SETQ LASTCHAR (fetch LASTCHAR of FD))
[COND
(RELFLAG (* Dimensions are relative, must be scaled)
(replace (FONTDESCRIPTOR FBBOX) of FD
with (IQUOTIENT (ITIMES (fetch (FONTDESCRIPTOR FBBOX) of FD)
NSMICASIZE)
1000))
(replace \SFDescent of FD with (IQUOTIENT (ITIMES (fetch \SFDescent
of FD)
NSMICASIZE)
1000))
(replace (FONTDESCRIPTOR FBBDX) of FD
with (IQUOTIENT (ITIMES (fetch (FONTDESCRIPTOR FBBDX) of FD)
NSMICASIZE)
1000))
(replace \SFHeight of FD with (IQUOTIENT (ITIMES (fetch \SFHeight
of FD)
NSMICASIZE)
1000]
(replace \SFAscent of FD with (IDIFFERENCE (fetch \SFHeight of FD)
(fetch \SFDescent of FD)))
(SETQ FIXEDFLAGS (LRSH (\BIN WSTRM)
6)) (* The fixed flags)
(\BIN WSTRM) (* Skip the spares)
[COND
((EQ 2 (LOGAND FIXEDFLAGS 2)) (* This font is fixed width.)
(SETQ TEM (\WIN WSTRM)) (* Read the fixed width for this font)
[COND
((AND RELFLAG (NOT (ZEROP TEM))) (* If it's size relative, scale it.)
(SETQ TEM (IQUOTIENT (ITIMES TEM NSMICASIZE)
1000]
(for I from FIRSTCHAR to LASTCHAR
do (* Fill in the char widths table with the width.)
(SETA WIDTHS I TEM)))
(T (* Variable width font, so we have to read widths.)
(AIN WIDTHS FIRSTCHAR (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))
WSTRM) (* Read the X widths.)
(for I from FIRSTCHAR to LASTCHAR when (EQ noInfoCode (ELT WIDTHS I))
do (* For chars that have no width info, let width be
zero.)
(SETA WIDTHS I 0))
(COND
(RELFLAG (* If the widths are size-relative, scale them.)
(for I from FIRSTCHAR to LASTCHAR
do (SETA WIDTHS I (IQUOTIENT (ITIMES (ELT WIDTHS I)
NSMICASIZE)
1000]
[COND
[(EQ 1 (LOGAND FIXEDFLAGS 1))
(COND
((ILESSP (GETFILEPTR WSTRM)
(GETEOFPTR WSTRM))
(SETQ WIDTHSY (\WIN WSTRM)))
(T (* STAR FONT FILES LIKE TO LEAVE OFF THE Y WIDTH.)
(SETQ WIDTHSY 0))) (* The fixed width-Y for this font;
the width-Y field is a single integer in the FD)
(replace \SFWidthsY of FD with (COND
((AND RELFLAG (NOT (ZEROP WIDTHSY)))
(IQUOTIENT (ITIMES WIDTHSY NSMICASIZE)
1000))
(T WIDTHSY]
(T (* Variable Y-width font. Fill it in as above)
(replace \SFWidthsY of FD with (SETQ WIDTHSY (ARRAY (ADD1 \MAXCHAR)
(QUOTE SMALLPOSP)
0 0)))
(AIN WIDTHSY FIRSTCHAR (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))
WSTRM) (* Read the Y widths)
(for I from FIRSTCHAR to LASTCHAR when (EQ noInfoCode (ELT WIDTHSY I))
do (* Let any characters with no width info be zero
height)
(SETA WIDTHSY I 0))
(COND
(RELFLAG (* If the widths are size-relative, scale them.)
(for I from FIRSTCHAR to LASTCHAR
do (SETA WIDTHSY I (IQUOTIENT (ITIMES (ELT WIDTHSY I)
NSMICASIZE)
1000]
(RETURN FD])
(\READACFONTBOXES
[LAMBDA (FILE STARTCHAR ENDCHAR) (* jds "15-Jun-85 11:48")
(* GETACCHARSPECS returns (bbox bboy bbdx bbdy))
(* if bbdx and bbdy are both zero, then treat it as a
space.)
(SETFILEPTR FILE 48) (* Move to the start of AC file's width info.)
(for X from STARTCHAR to ENDCHAR
collect (* Now collect the 4 bounding box values into a list)
(create BOUNDINGBOX
RASTERWIDTHX ←(PROG1 (\WIN FILE) (* Read a fraction, and truncate it to an integer # of
raster bits)
(\WIN FILE))
RASTERWIDTHY ←(PROG1 (\WIN FILE) (* Read a fraction, and truncate it to an integer # of
raster bits)
(\WIN FILE))
BBOX ←(SIGNED (\WIN FILE)
BITSPERWORD)
BBOY ←(SIGNED (\WIN FILE)
BITSPERWORD)
BBDX ←(SIGNED (\WIN FILE)
BITSPERWORD)
BBDY ←(SIGNED (\WIN FILE)
BITSPERWORD])
(\READACFONTFILE
[LAMBDA (STRM FAMILY SIZE FACE PAD.LEFT DONT.PAD.RIGHT) (* jds "15-Jun-85 12:10")
(* Read an AC-format font file.
Assumes that the file is open and has already been
determined to be of type AC.)
[COND
((RANDACCESSP STRM)
(RESETSAVE NIL (LIST (FUNCTION CLOSEF)
STRM)))
(T
(* This is necessary unless we figure out how to read the AC file sequentially. When we figure this out, we can
factor the RESETSAVE back in \READDISPLAYFONTFILE)
(SETQ STRM (OPENSTREAM (CLOSEF STRM)
(QUOTE INPUT)))
(RESETSAVE NIL (LIST (FUNCTION CLOSEF)
STRM))
(COPYBYTES STRM (SETQ STRM (OPENSTREAM (QUOTE {NODIRCORE})
(QUOTE BOTH]
(SETFILEPTR STRM 28) (* Starting at 28 skips the family and face bytes.)
(PROG (FBBLIST STARTCHAR ENDCHAR CHARWIDTHLIST CHARIMAGEWIDTHLIST OFFSETARRAY CHARWIDTHARRAY
IMAGEWIDTHARRAY FONTDESC FBBBITMAP CHARBITMAP STARTWORDLIST BBOXLIST
DUMMYCHAROFFSET DUMMYWIDTH)
(SETQ STARTCHAR (BIN STRM)) (* Get the first and last characters in this font)
(SETQ ENDCHAR (BIN STRM))
(SETQ BBOXLIST (\READACFONTBOXES STRM STARTCHAR ENDCHAR))
(* Read the list of bounding boxes for all the chars in
the font)
(SETQ FBBLIST (\GETFBB BBOXLIST))
(SETQ CHARWIDTHLIST (\ACCHARIMAGELIST BBOXLIST)) (* And the escapement for each character.)
(SETQ CHARIMAGEWIDTHLIST (\ACCHARWIDTHLIST BBOXLIST FBBLIST))
(* Create the list of character widths for the
characters in the font.)
(COND
([EVERY (CDR CHARWIDTHLIST)
(FUNCTION (LAMBDA (WID)
(OR (ZEROP WID)
(EQP WID (CAR CHARWIDTHLIST] (* Fixed-pitch font. Make the dummy character
(for non-existent chars) the same width.)
(SETQ DUMMYWIDTH (CAR CHARWIDTHLIST)))
(T (* Otherwise, make the dummy 6 wide.)
(SETQ DUMMYWIDTH 6)))
(COND
((NULL (REMOVE 0 CHARIMAGEWIDTHLIST))
(ERROR "No raster images" NIL)
(RETURN)))
(SETQ IMAGEWIDTHARRAY (ARRAY 258 (QUOTE (BITS 16))
DUMMYWIDTH 0)) (* Create the array of character widths, assuming the
dummy width for all characters--we'll write over it
alter)
[for X from STARTCHAR to ENDCHAR as Y in CHARIMAGEWIDTHLIST
do (SETA IMAGEWIDTHARRAY X (COND
((ZEROP Y)
0)
(T (IPLUS Y (COND
(PAD.LEFT 1)
(T 0))
(COND
(DONT.PAD.RIGHT 0)
(T 1]
(SETQ CHARWIDTHARRAY (ARRAY 258 (QUOTE (BITS 16))
DUMMYWIDTH 0)) (* And the array of image escapements)
(for X from STARTCHAR to ENDCHAR as Y in CHARWIDTHLIST do (OR (ZEROP Y)
(SETA CHARWIDTHARRAY X Y)))
(SETQ FONTDESC (create FONTDESCRIPTOR
FONTFAMILY ← FAMILY
FONTFACE ← FACE
FONTSIZE ← SIZE
FONTDEVICE ←(QUOTE DISPLAY)
FIRSTCHAR ← STARTCHAR
LASTCHAR ← ENDCHAR
\SFWidths ← CHARWIDTHARRAY
\SFAscent ←(IMAX 0 (IPLUS (fetch (FONTBOUNDINGBOX FBBBDY)
of FBBLIST)
(fetch (FONTBOUNDINGBOX FBBBOY)
of FBBLIST)))
\SFDescent ←(IMAX 0 (IMINUS (fetch (FONTBOUNDINGBOX FBBBOY)
of FBBLIST)))
\SFHeight ←(fetch (FONTBOUNDINGBOX FBBBDY) of FBBLIST)
FONTIMAGEWIDTHS ← IMAGEWIDTHARRAY))
[replace CHARACTERBITMAP of FONTDESC with (SETQ CHARBITMAP
(BITMAPCREATE (IPLUS (SETQ DUMMYCHAROFFSET
(for (X ← STARTCHAR)
to ENDCHAR
sum (ELT
CHARWIDTHARRAY X)))
DUMMYWIDTH)
(fetch (FONTBOUNDINGBOX FBBBDY)
of FBBLIST]
(SETQ OFFSETARRAY (ARRAY 258 (QUOTE (BITS 16))
DUMMYCHAROFFSET 0))
(SETQ STARTWORDLIST (\ACCHARPOSLIST STRM STARTCHAR ENDCHAR))
(bind (DESTLEFT ← 0) for NTHCHAR from STARTCHAR to ENDCHAR as BBLIST in BBOXLIST
as STARTWORD in STARTWORDLIST as CHARWIDTH in CHARWIDTHLIST
do (PROG (RASTERINFO BBOX BBBITMAP BBBMBASE) (* \ACCHARPOSLIST returns NIL if no raster exists for
the code)
(COND
((NULL STARTWORD) (* This character has no image;
use the dummy char's offset
(already in the offset and width arrays from earlier))
(add DESTLEFT (ELT CHARWIDTHARRAY NTHCHAR))
(SETA CHARWIDTHARRAY NTHCHAR DUMMYWIDTH)
(SETA IMAGEWIDTHARRAY NTHCHAR DUMMYWIDTH)
(GO L2)))
(SETFILEPTR STRM STARTWORD) (* If could flush this, would work on non-randaccessp
devices)
(SETQ RASTERINFO (\WIN STRM))
(COND
((EQ -1 (fetch BBDY of BBLIST))
(SETA CHARWIDTHARRAY NTHCHAR DUMMYWIDTH)
(SETA IMAGEWIDTHARRAY NTHCHAR DUMMYWIDTH)
(GO L2))) (* \ACCHARPOSLIST returns NIL if no raster exists for
the code)
(SETQ BBOX (fetch BBOX of BBLIST))
(COND
((AND (ZEROP (fetch BBDX of BBLIST))
(ZEROP (fetch BBDY of BBLIST)))
(* The image is zero wide or zero high.
Don't bother reading a bitmap image)
)
((SETQ BBBITMAP (BITMAPCREATE (TIMES 16 (FOLDLO RASTERINFO 1024))
(IMOD RASTERINFO 1024)))
(SETQ BBBMBASE (fetch BITMAPBASE of BBBITMAP))
(* STARTWORD is the characters raster information word. The high 6 bits record number of words per scan line and the
lower 10 bits is the same as bbdx bbdx. The raster for the char follows STARTWORD)
(\BINS STRM BBBMBASE 0 (TIMES 2 (FOLDLO RASTERINFO 1024)
(IMOD RASTERINFO 1024)))
(SETQ BBBITMAP (\ACROTATECHAR BBBITMAP))
(* here is the place to add a rotation function to
manipulate the character images coming off *.ac)
(BITBLT BBBITMAP 0 0 CHARBITMAP [PLUS DESTLEFT
(IMAX 0 (COND
(PAD.LEFT (ADD1 BBOX))
(T BBOX]
(DIFFERENCE (fetch BBOY of BBLIST)
(fetch (FONTBOUNDINGBOX FBBBOY) of FBBLIST))
(ELT CHARWIDTHARRAY NTHCHAR)
(CADDDR BBLIST)
(QUOTE INPUT)
(QUOTE REPLACE)) (* ADD1 to BBOX because we add an empty column to each
raster image to the left)
))
(SETA OFFSETARRAY NTHCHAR DESTLEFT)
(* on screen ac fonts, there are no spaces stored so that the width of the char is exactly that of the character
image without any spacing columns)
(add DESTLEFT (ELT CHARWIDTHARRAY NTHCHAR))
L2 (* add 2 because of the two blank columns we add;
one on either side of the ac raster image)
))
(replace \SFOffsets of FONTDESC with OFFSETARRAY)
(BITBLT NIL 0 0 CHARBITMAP (ADD1 DUMMYCHAROFFSET)
0
(IDIFFERENCE DUMMYWIDTH 2)
NIL
(QUOTE TEXTURE)
(QUOTE REPLACE)
BLACKSHADE) (* Fill in the dummy-character black blot)
(RETURN FONTDESC])
(\ACCHARIMAGELIST
[LAMBDA (BOXLIST) (* jds "15-Jun-85 11:37")
(* Returns a list of the ESCAPEMENTS
(ie how far to move after printng this character) for
each char in the font.)
(for BOX in BOXLIST collect (fetch (BOUNDINGBOX RASTERWIDTHX) of BOX])
(\ACCHARWIDTHLIST
[LAMBDA (BOXLIST FBBOX) (* jds " 4-Dec-84 16:05")
(* GETACCHARSPECS returns (bbox bboy bbdx bbdy))
(* if bbdx and bbdy are both zero, then treat it as a
space.)
(for BOX in BOXLIST bind (STARTWORD BBOX BBOY BBDX BBDY)
collect (SETQ BBOX (fetch BBOX of BOX))
(SETQ BBOY (fetch BBOY of BOX))
(SETQ BBDX (fetch BBDX of BOX))
(SETQ BBDY (fetch BBDY of BOX))
(COND
((AND (ZEROP BBDX)
(ZEROP BBDY)) (* we've found a Space. Smash in a quarter of the
maximum width. Maybe should be an explicit em?)
(IMAX 2 (FOLDLO (IPLUS 2 (fetch (FONTBOUNDINGBOX FBBBDX) of FBBOX))
4)))
(T (COND
((EQ BBDX -1)
0)
(T (IPLUS BBDX (IMAX 0 BBOX])
(\GETFBB
[LAMBDA (BOXLIST) (* jds "17-May-85 10:22")
(* Read a font bounding box from an AC file)
(PROG (RESULTLIST CHARCOUNT BBLIST MAXBBOX MAXBBOY MINBBOX MINBBOY MAXSUMBBOXBBDX MAXSUMBBOYBBDY
BBOX BBOY BBDX BBDY) (* \GETFBB returns the fbbdx fbbdy fbbox fbboy of an
acfont)
(SETQ MINBBOX 32767)
(SETQ MINBBOY 32767)
(SETQ MAXBBOX -32768)
(SETQ MAXBBOY -32768)
(SETQ MAXSUMBBOXBBDX -32768)
(SETQ MAXSUMBBOYBBDY -32768)
[for BOX in BOXLIST
do (SETQ BBOX (fetch (BOUNDINGBOX BBOX) of BOX))
(SETQ BBOY (fetch (BOUNDINGBOX BBOY) of BOX))
(SETQ BBDX (fetch (BOUNDINGBOX BBDX) of BOX))
(SETQ BBDY (fetch (BOUNDINGBOX BBDY) of BOX))
(* GETACCHARSPECS returns bbox bboy bbdx bbdy)
(COND
[(IEQP BBDY -1) (* This character doesn't exist.
Create a dummy bounding box for it)
(SETQ BBLIST (QUOTE (0 0 0 -1]
(T (COND
((IGREATERP BBOX MAXBBOX)
(SETQ MAXBBOX BBOX)))
(COND
((ILESSP BBOX MINBBOX)
(SETQ MINBBOX BBOX)))
(COND
((IGREATERP BBOY MAXBBOY)
(SETQ MAXBBOY BBOY)))
(COND
((ILESSP BBOY MINBBOY)
(SETQ MINBBOY BBOY)))
[COND
((IGREATERP (IPLUS BBOX BBDX)
MAXSUMBBOXBBDX)
(SETQ MAXSUMBBOXBBDX (IPLUS BBOX BBDX]
(COND
((IGREATERP (IPLUS BBOY BBDY)
MAXSUMBBOYBBDY)
(SETQ MAXSUMBBOYBBDY (IPLUS BBOY BBDY]
(* \GETFBB returns the fbbdx fbbdy fbbox fbboy of an
acfont)
(RETURN (create FONTBOUNDINGBOX
FBBBDX ←(IDIFFERENCE MAXSUMBBOXBBDX MINBBOX)
FBBBDY ←(IDIFFERENCE MAXSUMBBOYBBDY MINBBOY)
FBBBOX ← MINBBOX
FBBBOY ← MINBBOY])
(\ACCHARPOSLIST
[LAMBDA (FILE STARTCHAR ENDCHAR) (* jds "10-NOV-83 20:19")
(* \ACCHARPOSLIST returns the word position of the
raster for the nth character of the file)
[SETFILEPTR FILE (IPLUS 48 (ITIMES 16 (ADD1 (IDIFFERENCE ENDCHAR STARTCHAR]
(bind HIWORD LOWORD [DIRECTORYSTART ←(IPLUS 48 (ITIMES 16 (ADD1 (IDIFFERENCE ENDCHAR STARTCHAR]
first (SETFILEPTR FILE DIRECTORYSTART) for X from STARTCHAR to ENDCHAR
collect (SETQ HIWORD (\WIN FILE))
(SETQ LOWORD (\WIN FILE)) (* If the position of the acchar is given as -1,-1 then
the raster does not exist so return nil)
(COND
((AND (IEQP HIWORD 65535)
(IEQP LOWORD 65535))
NIL)
(T (IPLUS (LLSH HIWORD 17)
(LLSH LOWORD 1)
DIRECTORYSTART])
(\ACROTATECHAR
[LAMBDA (BITMAP) (* HK "12-JUL-82 11:48")
(PROG (NEW.BITMAP (WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP))
(HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP)))
(SETQ NEW.BITMAP (BITMAPCREATE HEIGHT WIDTH))
[for Y from 0 to (SUB1 HEIGHT) do (for X from 0 to (SUB1 WIDTH)
bind (Y1 ←(IDIFFERENCE (SUB1 HEIGHT)
Y))
do (BITMAPBIT NEW.BITMAP Y1 X (BITMAPBIT BITMAP X Y]
(RETURN NEW.BITMAP])
(\READFONTWDFILE
[LAMBDA (FILE FD WIDTHS SCALE) (* jds " 3-Dec-84 16:07")
(* Widths array is fully allocated, with zeroes for characters with no information. An array is not allocated for
fixed WidthsY. DEVICE is PRESS or INTERPRESS)
(DECLARE (GLOBALVARS FONTWIDTHSFILES))
(RESETLST (* RESETLST to make sure the fontfiles get closed)
(PROG (FIXEDFLAGS FIRSTCHAR LASTCHAR TEM WIDTHSY)
(SETFILEPTR FILE (LLSH (\FIXPIN FILE)
1)) (* Locate the segment)
(replace (FONTDESCRIPTOR FBBOX) of FD with (SIGNED (\WIN FILE)
BITSPERWORD))
(replace \SFDescent of FD with (IMINUS (SIGNED (\WIN FILE)
BITSPERWORD)))
(* Descent is -FBBOY)
(replace (FONTDESCRIPTOR FBBDX) of FD with (SIGNED (\WIN FILE)
BITSPERWORD))
(replace \SFHeight of FD with (SIGNED (\WIN FILE)
BITSPERWORD))
(* Height is FBBDY)
(replace \SFWidths of FD with WIDTHS)
(SETQ FIRSTCHAR (fetch FIRSTCHAR of FD))
(* First and last "real" characters in the font)
(SETQ LASTCHAR (fetch LASTCHAR of FD))
[COND
(SCALE (* Dimensions are relative, must be scaled)
(replace (FONTDESCRIPTOR FBBOX) of FD
with (IQUOTIENT (ITIMES (fetch (FONTDESCRIPTOR FBBOX) of FD)
SCALE)
1000))
(replace \SFDescent of FD with (IQUOTIENT (ITIMES (fetch \SFDescent
of FD)
SCALE)
1000))
(replace (FONTDESCRIPTOR FBBDX) of FD
with (IQUOTIENT (ITIMES (fetch (FONTDESCRIPTOR FBBDX) of FD)
SCALE)
1000))
(replace \SFHeight of FD with (IQUOTIENT (ITIMES (fetch \SFHeight
of FD)
SCALE)
1000]
(replace \SFAscent of FD with (IDIFFERENCE (fetch \SFHeight of FD)
(fetch \SFDescent of FD)))
(SETQ FIXEDFLAGS (LRSH (\BIN FILE)
6)) (* The fixed flags)
(\BIN FILE) (* Skip the spares)
[COND
((EQ 2 (LOGAND FIXEDFLAGS 2))
(SETQ TEM (\WIN FILE)) (* The fixed width for this font)
[COND
((AND SCALE (NOT (ZEROP TEM)))
(SETQ TEM (IQUOTIENT (ITIMES TEM SCALE)
1000]
(for I from FIRSTCHAR to LASTCHAR do (SETA WIDTHS I TEM)))
(T (AIN WIDTHS FIRSTCHAR (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))
FILE)
(for I from FIRSTCHAR to LASTCHAR when (EQ noInfoCode (ELT WIDTHS I))
do (SETA WIDTHS I 0))
(COND
(SCALE (for I from FIRSTCHAR to LASTCHAR
do (SETA WIDTHS I (IQUOTIENT (ITIMES (ELT WIDTHS I)
SCALE)
1000]
(COND
[(EQ 1 (LOGAND FIXEDFLAGS 1))
(SETQ WIDTHSY (\WIN FILE)) (* The fixed width-Y for this font;
the width-Y field is a single integer in the FD)
(replace \SFWidthsY of FD with (COND
((AND SCALE (NOT (ZEROP WIDTHSY)))
(IQUOTIENT (ITIMES WIDTHSY SCALE)
1000))
(T WIDTHSY]
(T (replace \SFWidthsY of FD with (SETQ WIDTHSY (ARRAY (ADD1 \MAXCHAR)
(QUOTE SMALLPOSP)
0 0)))
(AIN WIDTHSY FIRSTCHAR (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))
FILE)
(for I from FIRSTCHAR to LASTCHAR when (EQ noInfoCode (ELT WIDTHSY I))
do (SETA WIDTHSY I 0))
(COND
(SCALE (for I from FIRSTCHAR to LASTCHAR
do (SETA WIDTHSY I (IQUOTIENT (ITIMES (ELT WIDTHSY I)
SCALE)
1000])
(\FACECODE
[LAMBDA (FACE) (* rmk: "27-FEB-81 12:16")
(IPLUS (SELECTQ (fetch (FONTFACE EXPANSION) of FACE)
(REGULAR 0)
(COMPRESSED 6)
(EXPANDED 12)
(SHOULDNT))
(SELECTQ (fetch (FONTFACE WEIGHT) of FACE)
(MEDIUM 0)
(BOLD 2)
(LIGHT 4)
(SHOULDNT))
(SELECTQ (fetch (FONTFACE SLOPE) of FACE)
(REGULAR 0)
(ITALIC 1)
(SHOULDNT])
(\FAMILYCODE
[LAMBDA (FAMILY WSTRM) (* rmk: "11-Sep-84 10:54")
(* Returns the family CODE for FAMILY in a standard widths file, leaving the file positioned at the beginning of the
next file entry. Returns NIL if FAMILY not found. If FAMILY is T, returns the code for the first family in the
index.)
(SETFILEPTR WSTRM 0)
(bind TYPE CODE LENGTH (NCHARS ←(NCHARS FAMILY))
(NEXT ← 0)
do (SETFILEPTR WSTRM NEXT)
(SETQ TYPE (\BIN WSTRM))
(SETQ LENGTH (\BIN WSTRM))
(add NEXT (LLSH (IPLUS LENGTH (LLSH (LOGAND TYPE 15)
8))
1))
(SELECTQ (LRSH TYPE 4)
[1 (SETQ CODE (\WIN WSTRM))
(COND
([OR (EQ FAMILY T)
(AND (EQ NCHARS (\BIN WSTRM))
(for I from 1 to NCHARS always (EQ (\BIN WSTRM)
(NTHCHARCODE FAMILY I]
(SETFILEPTR WSTRM NEXT) (* Move file to next entry)
(RETURN CODE]
(0 (RETURN NIL))
NIL])
(\FINDFONT
[LAMBDA (FD WSTRM PRESSMICASIZE NSMICASIZE DONTCHECK) (* jds "30-Oct-84 14:29")
(* Finds the widths information for the specified FAMILY, FACECODE, MSIZE, and ROTATION. The FIRSTCHAR and LASTCHAR
of the font are filled in, since we have to read past those to check the size. If successful, returns the size found
in the widths file, with zero indicating that dimensions in the widths file are relative, leaving the file pointing
just after the Rotation word of the font. -
If DONTCHECK, then assumes that this file contains exactly the right face and family, without checking -
Returns NIL if the font is not found)
(bind TYPE LENGTH SIZE FAMILYCODE (ROTATION ←(fetch ROTATION of FD))
(FACECODE ←(\FACECODE (fetch FONTFACE of FD)))
(NEXT ← 0) first (OR (SETQ FAMILYCODE (\FAMILYCODE (OR DONTCHECK (fetch FONTFAMILY
of FD))
WSTRM))
(RETURN NIL))
do (SETQ TYPE (\BIN WSTRM))
(SETQ LENGTH (\BIN WSTRM))
(add NEXT (LLSH (IPLUS LENGTH (LLSH (LOGAND TYPE 15)
8))
1))
(SELECTQ (LRSH TYPE 4)
[4 (COND
((OR (AND (EQ FAMILYCODE (\BIN WSTRM))
(EQ FACECODE (\BIN WSTRM)))
DONTCHECK) (* This is the right family/face
(DONTCHECK must come last, so the file reads get done.)
)
(replace FIRSTCHAR of FD with (\BIN WSTRM))
(replace LASTCHAR of FD with (\BIN WSTRM))
(COND
((AND (OR (ZEROP (SETQ SIZE (\WIN WSTRM)))
(EQ PRESSMICASIZE SIZE)
(EQ NSMICASIZE SIZE))
(EQ ROTATION (\WIN WSTRM)))
(replace \SFFACECODE of FD with FACECODE)
(RETURN SIZE]
(0 (RETURN NIL))
NIL)
(SETFILEPTR WSTRM NEXT])
)
(RPAQ? INTERPRESSFONTDIRECTORIES (QUOTE ({ERIS}<LISP>FONTS>)))
(PUTPROPS AFONT COPYRIGHT ("Xerox Corporation" 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1902 32547 (\CREATESTARFONT 1912 . 9759) (\READACFONTBOXES 9761 . 11004) (
\READACFONTFILE 11006 . 19259) (\ACCHARIMAGELIST 19261 . 19682) (\ACCHARWIDTHLIST 19684 . 20759) (
\GETFBB 20761 . 22997) (\ACCHARPOSLIST 22999 . 23937) (\ACROTATECHAR 23939 . 24519) (\READFONTWDFILE
24521 . 28912) (\FACECODE 28914 . 29418) (\FAMILYCODE 29420 . 30547) (\FINDFONT 30549 . 32545)))))
STOP