(FILECREATED " 1-Oct-85 18:51:06" {ERIS}<LISPCORE>SOURCES>AFONT.;34 27901
changes to: (FNS \CREATESTARFONT)
previous date: "25-Sep-85 17:57:30" {ERIS}<LISPCORE>SOURCES>AFONT.;33)
(* 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>]
(MACROS \POSITIONFONTFILE)))
(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) (* gbn " 1-Oct-85 18:29")
(* the Build 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 [(CS (OR CHARSET \DEFAULTCHARSET))
(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]
(RETURN (if (NOT (\GETCHARSETINFO CS FD T))
then (* return NIL and let FONTCREATE decide whether or not
to cause an error)
NIL
else 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) (* gbn " 1-Aug-85 23:29")
(* 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 OFFSETS WIDTHS IMAGEWIDTHS
FONTDESC FBBBITMAP CHARBITMAP STARTWORDLIST BBOXLIST DUMMYCHAROFFSET DUMMYWIDTH
(CSINFO (create CHARSETINFO
IMAGEWIDTHS ←(\CREATECSINFOELEMENT]
(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 IMAGEWIDTHS (fetch IMAGEWIDTHS of CSINFO))
(for I from 0 to (ADD1 \MAXTHINCHAR) do (\FSETIMAGEWIDTH IMAGEWIDTHS I DUMMYWIDTH))
(SETQ WIDTHS (fetch WIDTHS of CSINFO))
(for I from 0 to (ADD1 \MAXTHINCHAR) do (\FSETWIDTH WIDTHS I DUMMYWIDTH))
(* SETQ IMAGEWIDTHS (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 (\FSETIMAGEWIDTH IMAGEWIDTHS X (COND
((ZEROP Y)
0)
(T (IPLUS Y (COND
(PAD.LEFT 1)
(T 0))
(COND
(DONT.PAD.RIGHT 0)
(T 1] (* And the array of image escapements)
(for X from STARTCHAR to ENDCHAR as Y in CHARWIDTHLIST do (OR (ZEROP Y)
(\FSETWIDTH WIDTHS X Y)))
[replace CHARSETDESCENT of CSINFO with (IMAX 0 (IMINUS (fetch (FONTBOUNDINGBOX FBBBOY)
of FBBLIST]
[replace CHARSETASCENT of CSINFO with (IMAX 0 (IPLUS (fetch (FONTBOUNDINGBOX FBBBDY)
of FBBLIST)
(fetch (FONTBOUNDINGBOX FBBBOY)
of FBBLIST]
[replace CHARSETBITMAP of CSINFO with (SETQ CHARBITMAP
(BITMAPCREATE (IPLUS (SETQ DUMMYCHAROFFSET
(for (X ← STARTCHAR)
to ENDCHAR
sum (\FGETWIDTH WIDTHS X))
)
DUMMYWIDTH)
(fetch (FONTBOUNDINGBOX FBBBDY)
of FBBLIST]
(SETQ OFFSETS (fetch OFFSETS of CSINFO))
(for I from 0 to (ADD1 \MAXTHINCHAR) do (\FSETOFFSET OFFSETS I DUMMYCHAROFFSET))
(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 (\FGETWIDTH WIDTHS NTHCHAR))
(\FSETWIDTH WIDTHS NTHCHAR DUMMYWIDTH)
(\FSETIMAGEWIDTH IMAGEWIDTHS 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))
(\FSETWIDTH WIDTHS NTHCHAR DUMMYWIDTH)
(\FSETIMAGEWIDTH IMAGEWIDTHS 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))
(\FGETWIDTH WIDTHS NTHCHAR)
(CADDDR BBLIST)
(QUOTE INPUT)
(QUOTE REPLACE)) (* ADD1 to BBOX because we add an empty column to each
raster image to the left)
))
(\FSETOFFSET OFFSETS 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 (\FGETWIDTH WIDTHS NTHCHAR))
L2 (* add 2 because of the two blank columns we add;
one on either side of the ac raster image)
))
(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 CSINFO])
(\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) (* hdj "25-Sep-85 14:37")
(* 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)
(FUZZ ← (PROG1 .02 (* percentile difference acceptable as the same font
size)))
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)))
(LESSP (ABS (FQUOTIENT (IDIFFERENCE (OR PRESSMICASIZE
NSMICASIZE)
SIZE)
PRESSMICASIZE))
FUZZ))
(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>)))
(DECLARE: EVAL@COMPILE
[PUTPROPS \POSITIONFONTFILE MACRO
((WSTRM NSMICASIZE FIRSTCHAR LASTCHAR)
(* gbn "25-Jul-85 02:15")
(* sets FIRSTCHAR LASTCHAR, and positions the file correctly)
(* Finds the widths information for the specified FAMILY, FACECODE, MSIZE, and ROTATION.
FIRSTCHAR and LASTCHAR are passed 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. - - Returns NIL if the font is not found)
(bind TYPE LENGTH SIZE (NEXT ← 0)
first
(OR (\FAMILYCODE T 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 (\BIN WSTRM)
(\BIN WSTRM)
(* This is the right family/face)
(SETQ FIRSTCHAR (\BIN WSTRM))
(SETQ LASTCHAR (\BIN WSTRM))
(COND ((AND (OR (ZEROP (SETQ SIZE (\WIN WSTRM)))
(LESSP (ABS (FQUOTIENT (IDIFFERENCE NSMICASIZE SIZE)
NSMICASIZE))
.02))
(ZEROP (\WIN WSTRM)))
(RETURN SIZE]
(0 (RETURN NIL))
NIL)
(SETFILEPTR WSTRM NEXT]
)
(PUTPROPS AFONT COPYRIGHT ("Xerox Corporation" 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1852 26406 (\CREATESTARFONT 1862 . 3254) (\READACFONTBOXES 3256 . 4499) (
\READACFONTFILE 4501 . 12891) (\ACCHARIMAGELIST 12893 . 13314) (\ACCHARWIDTHLIST 13316 . 14391) (
\GETFBB 14393 . 16629) (\ACCHARPOSLIST 16631 . 17569) (\ACROTATECHAR 17571 . 18151) (\READFONTWDFILE
18153 . 22544) (\FACECODE 22546 . 23050) (\FAMILYCODE 23052 . 24179) (\FINDFONT 24181 . 26404)))))
STOP