(FILECREATED " 7-Nov-85 14:48:12" {ERIS}<LISPCORE>LIBRARY>4045STREAM.;15 51504
changes to: (FNS \4045INIT)
previous date: " 3-Oct-85 14:07:15" {ERIS}<LISPCORE>LIBRARY>4045STREAM.;14)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT 4045STREAMCOMS)
(RPAQQ 4045STREAMCOMS [(FNS 4045.EncodedSixelofBitmap 4045.OUTCHARFN BEGINPAGE.4045 ENDPAGE.4045
NEWLINE.4045 NEWPAGE.4045 OPEN4045STREAM SETXY.4045 \4045INIT
\BITBLT.4045 \BLTSHADE.4045 \CHARWIDTH.4045 \CLOSE4045STREAM
\COERCEASCIITO4045FONT \CREATE4045FONT \CREATECHARSET.4045
\DOUBLE.BITMAP.4045 \DRAWLINE.4045 \DRAWPOLYGON.4045
\DSPBOTTOMMARGIN.4045 \DSPCLIPPINGREGION.4045 \DSPFONT.4045
\BOLDMODE.4045 \MEDIUMMODE.4045 \DSPLEFTMARGIN.4045 \DSPLINEFEED.4045
\DSPRIGHTMARGIN.4045 \DSPSPACEFACTOR.4045 \DSPTOPMARGIN.4045
\DSPXPOSITION.4045 \DSPYPOSITION.4045 \FIXLINELENGTH.4045 \MOVETO.4045
\READ4045FONTFILE \SCALEDBITBLT.4045 \SEARCH4045FONTS \SEND4045COMMAND
\STRINGWIDTH.4045 \WINDOWCMD.4045)
(DECLARE: EVAL@LOAD DONTCOPY (RECORDS SIXEL)
(FILES (LOADFROM)
INTERPRESS))
(RECORDS 4045DATA)
(FILES CENTRONICS)
(VARS 4045.DOTSPERMICA 4045.DOTSPERPOINT \ASCIITOASCII)
(MACROS \4045BackingStream)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (\4045INIT])
(DEFINEQ
(4045.EncodedSixelofBitmap
[LAMBDA (BASEPTR Sixel#) (* hdj " 9-Sep-85 18:23")
(LET* ((WordsToSkip (ITIMES 3 (IQUOTIENT Sixel# 8)))
(SixelsRemaining (IREMAINDER Sixel# 8))
(StartOfSixelRun (\ADDBASE BASEPTR WordsToSkip)))
(IPLUS 63 (SELECTQ SixelsRemaining
(0 (fetch (SIXEL ZERO) of StartOfSixelRun))
(1 (fetch (SIXEL ONE) of StartOfSixelRun))
(2 (fetch (SIXEL TWO) of StartOfSixelRun))
(3 (fetch (SIXEL THREE) of StartOfSixelRun))
(4 (fetch (SIXEL FOUR) of StartOfSixelRun))
(5 (fetch (SIXEL FIVE) of StartOfSixelRun))
(6 (fetch (SIXEL SIX) of StartOfSixelRun))
(7 (fetch (SIXEL SEVEN) of StartOfSixelRun))
(SHOULDNT SixelsRemaining])
(4045.OUTCHARFN
[LAMBDA (4045STREAM CHARCODE) (* hdj " 2-Oct-85 18:30")
(PROG (NSCODE CLIPPINGREGION NEWXPOS (4045DATA (ffetch IMAGEDATA of 4045STREAM))
(BACKINGSTREAM (\4045BackingStream 4045STREAM)))
[SETQ NSCODE (COND
((\FATCHARCODEP CHARCODE)
CHARCODE)
(T (\GETBASE (ffetch 4045NSTRANSTABLE of 4045DATA)
CHARCODE] (* Select on NSCODE, since ↑L etc might be graphic in
some ascii fonts)
(SETQ CLIPPINGREGION (ffetch 4045CLIPPINGREGION of 4045DATA))
(SELCHARQ NSCODE
(EOL (NEWLINE.4045 4045STREAM))
[LF (\DSPXPOSITION.4045 4045STREAM (PROG1 (\DSPXPOSITION.4045 4045STREAM)
(NEWLINE.4045 4045STREAM]
(↑L (NEWPAGE.4045 4045STREAM))
(PROGN [SETQ NEWXPOS (add (ffetch 4045XPOS of 4045DATA)
(COND
((EQ NSCODE (CHARCODE SPACE))
(ffetch 4045SPACEWIDTH of 4045DATA))
(T (\FGETWIDTH (ffetch 4045WIDTHSCACHE of 4045DATA)
(\CHAR8CODE NSCODE]
(if (IGREATERP NEWXPOS (ffetch 4045RIGHT of 4045DATA))
then (NEWLINE.4045 4045STREAM))
(* Assume the widths for the untranslated code
correspond to the translated character)
(if (AND (ILESSP NEWXPOS (fetch (REGION RIGHT) of CLIPPINGREGION))
(IGREATERP NEWXPOS (fetch (REGION LEFT) of CLIPPINGREGION)))
then (BOUT BACKINGSTREAM (\CHAR8CODE NSCODE])
(BEGINPAGE.4045
[LAMBDA (4045STREAM) (* hdj "15-Aug-85 13:09")
(MOVETOUPPERLEFT 4045STREAM])
(ENDPAGE.4045
[LAMBDA (4045STREAM) (* hdj " 5-Sep-85 11:54")
(BOUT (\4045BackingStream 4045STREAM)
(CHARCODE FF])
(NEWLINE.4045
[LAMBDA (4045STREAM) (* hdj " 2-Oct-85 18:36")
(PROG (NEWYPOS (4045DATA (ffetch IMAGEDATA of 4045STREAM)))
(SETQ NEWYPOS (IDIFFERENCE (ffetch 4045YPOS of 4045DATA)
(ffetch 4045LINEFEED of 4045DATA)))
(COND
((ILESSP NEWYPOS (fetch 4045BOTTOM of 4045DATA))
(NEWPAGE.4045 4045STREAM))
(T (SETXY.4045 4045STREAM (ffetch 4045LEFT of 4045DATA)
NEWYPOS])
(NEWPAGE.4045
[LAMBDA (4045STREAM) (* hdj "14-Aug-85 23:26")
(ENDPAGE.4045 4045STREAM)
(BEGINPAGE.4045 4045STREAM])
(OPEN4045STREAM
[LAMBDA (4045FILE OPTIONS) (* hdj "25-Sep-85 15:51")
(* * Opens a 4045 stream, to which user can perform DIG operations)
(DECLARE (GLOBALVARS \4045IMAGEOPS))
(LET [(4045DEFAULTFONT (FONTCREATE (QUOTE TITAN)
10
(QUOTE MRR)
0
(QUOTE 4045)))
(4045STREAM (create STREAM
DEVICE ← 4045FDEV
ACCESS ← (QUOTE OUTPUT)
USERCLOSEABLE ← T
OUTCHARFN ← (FUNCTION 4045.OUTCHARFN)
IMAGEOPS ← \4045IMAGEOPS
IMAGEDATA ← (create 4045DATA
4045CLIPPINGREGION ← (CREATEREGION 0 0 2550 3300))
F1 ← (OPENSTREAM 4045FILE (QUOTE OUTPUT]
(DSPFONT 4045DEFAULTFONT 4045STREAM)
(DSPLINEFEED (FONTPROP 4045DEFAULTFONT (QUOTE HEIGHT))
4045STREAM)
(BEGINPAGE.4045 4045STREAM)
4045STREAM])
(SETXY.4045
[LAMBDA (4045STREAM X Y) (* hdj " 5-Sep-85 11:59")
(* Move to (X,Y) on the page.)
(replace 4045XPOS of (fetch IMAGEDATA of 4045STREAM) with X)
(replace 4045YPOS of (fetch IMAGEDATA of 4045STREAM) with Y)
(\SEND4045COMMAND (CONCAT "a" X "," Y)
(\4045BackingStream 4045STREAM])
(\4045INIT
[LAMBDA NIL (* hdj " 7-Nov-85 14:46")
(DECLARE (GLOBALVARS \4045IMAGEOPS 4045FDEV))
[SETQ \4045IMAGEOPS (create IMAGEOPS
IMAGETYPE ←(QUOTE 4045)
IMCLOSEFN ←(FUNCTION \CLOSE4045STREAM)
IMXPOSITION ←(FUNCTION \DSPXPOSITION.4045)
IMYPOSITION ←(FUNCTION \DSPYPOSITION.4045)
IMFONT ←(FUNCTION \DSPFONT.4045)
IMLEFTMARGIN ←(FUNCTION \DSPLEFTMARGIN.4045)
IMRIGHTMARGIN ←(FUNCTION \DSPRIGHTMARGIN.4045)
IMLINEFEED ←(FUNCTION \DSPLINEFEED.4045)
IMDRAWLINE ←(FUNCTION \DRAWLINE.4045)
IMDRAWCURVE ←(FUNCTION NILL)
IMDRAWCIRCLE ←(FUNCTION NILL)
IMDRAWELLIPSE ←(FUNCTION NILL)
IMFILLCIRCLE ←(FUNCTION NILL)
IMBLTSHADE ←(FUNCTION \BLTSHADE.4045)
IMBITBLT ←(FUNCTION \BITBLT.4045)
IMMOVETO ←(FUNCTION \MOVETO.4045)
IMSCALE ←[FUNCTION (LAMBDA NIL
(CONSTANT (FQUOTIENT 300 72]
IMTERPRI ←(FUNCTION NEWLINE.4045)
IMBOTTOMMARGIN ←(FUNCTION \DSPBOTTOMMARGIN.4045)
IMTOPMARGIN ←(FUNCTION \DSPTOPMARGIN.4045)
IMFONTCREATE ←(QUOTE 4045)
IMNEWPAGE ←(FUNCTION NEWPAGE.4045)
IMSPACEFACTOR ←(FUNCTION \DSPSPACEFACTOR.4045)
IMSTRINGWIDTH ←(FUNCTION \STRINGWIDTH.4045)
IMCHARWIDTH ←(FUNCTION \CHARWIDTH.4045)
IMSCALEDBITBLT ←(FUNCTION \SCALEDBITBLT.4045)
IMCLIPPINGREGION ←(FUNCTION \DSPCLIPPINGREGION.4045)
IMDRAWPOLYGON ←(FUNCTION \DRAWPOLYGON.4045)
IMBITMAPSIZE ←(FUNCTION (LAMBDA (STREAM BITMAP DIMENSION)
(SELECTQ DIMENSION
(WIDTH (TIMES 4 (BITMAPWIDTH BITMAP)))
(HEIGHT (TIMES 4 (BITMAPHEIGHT BITMAP)))
[NIL (CONS (TIMES 4 (BITMAPWIDTH BITMAP))
(TIMES 4 (BITMAPHEIGHT BITMAP]
(\ILLEGAL.ARG DIMENSION]
(SETQ 4045FDEV (create FDEV
DEVICENAME ←(LIST (QUOTE 4045)
(QUOTE PRINTER))
RESETABLE ← NIL
RANDOMACCESSP ← NIL
PAGEMAPPED ← NIL
CLOSEFILE ←(FUNCTION NILL)
DELETEFILE ←(FUNCTION NILL)
GETFILEINFO ←(FUNCTION NILL)
OPENFILE ←(FUNCTION [LAMBDA (NAME ACCESS RECOG OTHERINFO FDEV)
NAME])
READPAGES ←(FUNCTION \ILLEGAL.DEVICEOP)
SETFILEINFO ←(FUNCTION NILL)
GENERATEFILES ←(FUNCTION \GENERATENOFILES)
TRUNCATEFILE ←(FUNCTION NILL)
WRITEPAGES ←(FUNCTION \ILLEGAL.DEVICEOP)
GETFILENAME ←(FUNCTION [LAMBDA (NAME RECOG FDEV)
NAME])
REOPENFILE ←(FUNCTION [LAMBDA (NAME)
NAME])
EVENTFN ←(FUNCTION NILL)
DIRECTORYNAMEP ←(FUNCTION NILL)
HOSTNAMEP ←(FUNCTION NILL)
BIN ←(FUNCTION \ILLEGAL.DEVICEOP)
BOUT ←(FUNCTION 4045.OUTCHARFN)
PEEKBIN ←(FUNCTION \ILLEGAL.DEVICEOP)
BACKFILEPTR ←(FUNCTION \PAGEDBACKFILEPTR)
BLOCKIN ←(FUNCTION \ILLEGAL.DEVICEOP)
BLOCKOUT ←(FUNCTION \NONPAGEDBOUTS)))
[push IMAGESTREAMTYPES (QUOTE (4045 (OPENSTREAM OPEN4045STREAM)
(FONTCREATE \CREATE4045FONT)
(FONTSAVAILABLE \SEARCH4045FONTS)
(CREATECHARSET \CREATECHARSET.4045]
[push PRINTFILETYPES (QUOTE (4045 (EXTENSION (4045]
(SETFONTCLASSCOMPONENT DEFAULTFONT 4045 (QUOTE (TITAN 10 MRR)))
NIL])
(\BITBLT.4045
[LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM 4045STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH
HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT
CLIPPEDSOURCEBOTTOM) (* hdj " 3-Oct-85 11:46")
(* * \DOUBLE.BITMAP.4045 doubles the size of the bitmap and makes it a multiple of 48 bits wide -- for ease of
handling and printing. 4045 wants bitmaps to be a multiple of 8 bits wide, and sixel encoding is easiest on things
that are a multiple of 48 bits wide -- we double it so we can print it at 75 ppi -
close to the ideal of 72 ppi)
(LET* ((NEWSOURCE (BITMAPCREATE WIDTH HEIGHT))
[EXPANDED.SOURCEBITMAP (\DOUBLE.BITMAP.4045 (PROG1 NEWSOURCE
(BITBLT SOURCEBITMAP CLIPPEDSOURCELEFT
CLIPPEDSOURCEBOTTOM NEWSOURCE 0
0 WIDTH HEIGHT (QUOTE INPUT)
(QUOTE REPLACE]
(BACKINGSTREAM (\4045BackingStream 4045STREAM))
(HEIGHT (BITMAPHEIGHT EXPANDED.SOURCEBITMAP))
(WIDTH.ROUNDED (BITMAPWIDTH EXPANDED.SOURCEBITMAP))
(SIXEL.WIDTH (IQUOTIENT WIDTH.ROUNDED 6))
(WordWidth (fetch (BITMAP BITMAPRASTERWIDTH) of EXPANDED.SOURCEBITMAP)))
(\WINDOWCMD.4045 2 DESTINATIONLEFT (IPLUS HEIGHT DESTINATIONBOTTOM)
WIDTH.ROUNDED HEIGHT BACKINGSTREAM)
(bind (CurrRow ←(fetch (BITMAP BITMAPBASE) of EXPANDED.SOURCEBITMAP)) for ROW from 1
to HEIGHT
do (for Sixel from 0 to (SUB1 SIXEL.WIDTH) do (BOUT BACKINGSTREAM (
4045.EncodedSixelofBitmap CurrRow
Sixel)))
(SETQ CurrRow (\ADDBASE CurrRow WordWidth])
(\BLTSHADE.4045
[LAMBDA (TEXTURE 4045STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION)
(* hdj " 9-Sep-85 22:03")
(\BLTSHADE.GENERICPRINTER TEXTURE 4045STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT
OPERATION CLIPPINGREGION (DSPSCALE NIL 4045STREAM])
(\CHARWIDTH.4045
[LAMBDA (4045STREAM CHARCODE) (* hdj "15-Aug-85 13:57")
(* * Gets the width of CHARCODE in a 4045 stream, observing spacefactor)
(COND
((EQ CHARCODE (CHARCODE SPACE))
(ffetch 4045SPACEWIDTH of (ffetch IMAGEDATA of 4045STREAM)))
(T (\FGETCHARWIDTH (ffetch 4045FONT of (ffetch IMAGEDATA of 4045STREAM))
CHARCODE])
(\CLOSE4045STREAM
[LAMBDA (4045STREAM) (* hdj "25-Sep-85 16:28")
(ENDPAGE.4045 4045STREAM)
(CLOSEF (\4045BackingStream 4045STREAM])
(\COERCEASCIITO4045FONT
[LAMBDA (ASCIITONSMAPARRAY ASCIITONSFIXARRAY ASCIIFAMILY NSFAMILY SIZE FONTFACE ROTATION DEVICE)
(* hdj "15-Aug-85 23:47")
(* Produces an ascii font with the proper widths for
the ns-character correspondences defined by
ASCIITONSMAPARRAY)
(* ASCIITONSFIXARRAY is for temporary problems with
font compatibility between printer and widths/screen.
in OS5.0 fonts)
(PROG (CHARSETDIR [ASCIITONSMAP (fetch (ARRAYP BASE) of (\DTEST (OR ASCIITONSFIXARRAY
ASCIITONSMAPARRAY)
(QUOTE ARRAYP]
(FD (\READ4045FONTFILE NSFAMILY SIZE FONTFACE ROTATION DEVICE)))
(OR FD (RETURN NIL))
(SETQ CHARSETDIR (CONS (CONS 0 FD)))
[for I NSCODE CS from 0 to 255 unless (OR (EQ I (SETQ NSCODE (\GETBASE ASCIITONSMAP I)))
(ASSOC (SETQ CS (\CHARSET NSCODE))
CHARSETDIR))
do (* Run thru the translate table looking for non-0
charsets. Add their width info to the directory)
(push CHARSETDIR (CONS CS
(COND
((\READ4045FONTFILE NSFAMILY SIZE FONTFACE ROTATION DEVICE
CS))
(T (* There isn't any info for that character.
Warn the guy, but continue.)
(FRESHLINE PROMPTWINDOW)
(printout PROMPTWINDOW
"Warning: Information about character set "
.I3.8 CS " missing from font " ASCIIFAMILY ,
SIZE ".")
NIL] (* Return if one of the fonts couldn't be found)
(bind CHARSETINFO for I NSCODE (WD ←(fetch \SFWidths of FD)) from 0 to 255
unless (EQ I (SETQ NSCODE (\GETBASE ASCIITONSMAP I)))
when (SETQ CHARSETINFO (CDR (ASSOC (\CHARSET NSCODE)
CHARSETDIR)))
do (* For each non-ASCII character, look for width info in
the right NS place. If none, use zero width.)
(SETA WD I (CHARWIDTH (\CHAR8CODE NSCODE)
CHARSETINFO)))
[replace OTHERDEVICEFONTPROPS of FD with (fetch (ARRAYP BASE) of (\DTEST ASCIITONSMAPARRAY
(QUOTE ARRAYP]
[COND
((NEQ NSFAMILY ASCIIFAMILY)
(* Update the font deacriptor so it looks like it's really for the family the guy wanted. Also save the info we used
to get here.)
(replace FONTFAMILY of FD with ASCIIFAMILY)
(replace FONTDEVICESPEC of FD with (LIST NSFAMILY SIZE FONTFACE ROTATION DEVICE]
(RETURN FD])
(\CREATE4045FONT
[LAMBDA (FAMILY SIZE FONTFACE ROTATION DEVICE) (* hdj " 2-Oct-85 16:15")
(* Creates a font descriptor for an NS font for
hardcopy. Tries first on the assumption that he gave us
the NS font name)
(DECLARE (GLOBALVARS \ASCIITOASCII \ASCIITOSTAR ASCIITONSTRANSLATIONS))
(if (\COERCEASCIITO4045FONT \ASCIITOASCII \ASCIITOSTAR FAMILY FAMILY SIZE FONTFACE ROTATION
DEVICE)
elseif (for TRANSL in ASCIITONSTRANSLATIONS bind NEWFONT
when (AND (EQ FAMILY (CAR TRANSL))
(SETQ NEWFONT (\COERCEASCIITO4045FONT (COND
((NULL (CADR TRANSL))
\ASCIITOASCII)
((LITATOM (CADR TRANSL))
(EVAL (CADR TRANSL)))
(T (CADR TRANSL)))
(COND
((NULL (CADR TRANSL))
\ASCIITOSTAR)
(T NIL))
FAMILY
(OR (CADDR TRANSL)
(QUOTE MODERN))
SIZE FONTFACE ROTATION DEVICE)))
do (RETURN NEWFONT])
(\CREATECHARSET.4045
[LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE CHARSET) (* hdj "25-Sep-85 14:07")
(* * Build the CHARSETINFO for a 4045 font. If we can't find widths info for that font, return NIL
(4045 uses same WD-format files as Interpress))
(* Widths array is fully allocated, with zeroes for
characters with no information.
An array is not allocated for fixed WidthsY.
DEVICE is 4045)
(DECLARE (GLOBALVARS INTERPRESSFONTDIRECTORIES \ASCIITONS))
(RESETLST (* RESETLST to make sure the fontfiles get closed)
(PROG (WFILE WSTRM FIXEDFLAGS RELFLAG FIRSTCHAR LASTCHAR TEM WIDTHSY
(NSMICASIZE (FIXR (FQUOTIENT (ITIMES PSIZE 2540)
72)))
(CSINFO (create CHARSETINFO)))
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(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 (\POSITIONFONTFILE WSTRM NSMICASIZE FIRSTCHAR LASTCHAR))
(* \POSITIONFONTFILE sets FIRSTCHAR LASTCHAR as well as
positioning the font file at the beginning of the
widths)
(* 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.)
(SETQ FBBOX (SIGNED (\WIN WSTRM)
BITSPERWORD)) (* replace (FONTDESCRIPTOR FBBOX) of FD with
(SIGNED (\WIN WSTRM) BITSPERWORD))
(* Get the max bounding width for the font)
(replace (CHARSETINFO CHARSETDESCENT) of CSINFO
with (IMINUS (SIGNED (\WIN WSTRM)
BITSPERWORD))) (* Descent is -FBBOY)
(\WIN WSTRM) (* replace (FONTDESCRIPTOR FBBDX) of FD with
(SIGNED (\WIN WSTRM) BITSPERWORD))
(* And the standard kern value
(?))
(SETQ CHARSETHEIGHT (SIGNED (\WIN WSTRM)
BITSPERWORD))
(* replace \SFHeight of FD with
(SIGNED (\WIN WSTRM) BITSPERWORD))
(* Height is FBBDY)
[COND
(RELFLAG (* Dimensions are relative, must be scaled)
(* replace (FONTDESCRIPTOR FBBOX) of FD with
(IQUOTIENT (ITIMES (fetch (FONTDESCRIPTOR FBBOX) of FD)
NSMICASIZE) 1000))
(replace (CHARSETINFO CHARSETDESCENT) of CSINFO
with (IQUOTIENT (ITIMES (fetch (CHARSETINFO CHARSETDESCENT)
of CSINFO)
NSMICASIZE)
1000)) (* replace (FONTDESCRIPTOR FBBDX) of FD with
(IQUOTIENT (ITIMES (fetch (FONTDESCRIPTOR FBBDX) of FD)
NSMICASIZE) 1000))
(SETQ CHARSETHEIGHT (IQUOTIENT (ITIMES CHARSETHEIGHT NSMICASIZE)
1000]
(replace (CHARSETINFO CHARSETASCENT) of CSINFO
with (IDIFFERENCE CHARSETHEIGHT (fetch CHARSETDESCENT of CSINFO)))
(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.)
(\FSETWIDTH WIDTHS I TEM)))
(T (* Variable width font, so we have to read widths.)
(* AIN WIDTHS FIRSTCHAR (ADD1
(IDIFFERENCE LASTCHAR FIRSTCHAR)) WSTRM)
(for I from FIRSTCHAR to LASTCHAR do (\FSETWIDTH WIDTHS I noInfoCode))
(\BINS (\GETOFD WSTRM (QUOTE INPUT))
WIDTHS
(UNFOLD FIRSTCHAR BYTESPERWORD)
(UNFOLD (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))
BYTESPERWORD)) (* Read the X widths.)
(for I from FIRSTCHAR to LASTCHAR when (EQ noInfoCode (\FGETWIDTH WIDTHS I))
do (* For chars that have no width info, let width be
zero.)
(\FSETWIDTH WIDTHS I 0))
(COND
(RELFLAG (* If the widths are size-relative, scale them.)
(for I from FIRSTCHAR to LASTCHAR
do (\FSETWIDTH WIDTHS I (IQUOTIENT (ITIMES (\FGETWIDTH 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 (CHARSETINFO YWIDTHS) of CSINFO
with (COND
((AND RELFLAG (NOT (ZEROP WIDTHSY)))
(IQUOTIENT (ITIMES WIDTHSY NSMICASIZE)
1000))
(T WIDTHSY]
(T (* Variable Y-width font. Fill it in as above)
(for I from FIRSTCHAR to LASTCHAR do (\FSETWIDTH WIDTHSY I noInfoCode))
(\BINS (\GETOFD WSTRM (QUOTE INPUT))
WIDTHS
(UNFOLD FIRSTCHAR BYTESPERWORD)
(UNFOLD (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))
BYTESPERWORD)) (* Read the Y widths)
(for I from FIRSTCHAR to LASTCHAR when (EQ noInfoCode (\FGETWIDTH WIDTHSY I))
do (* Let any characters with no width info be zero
height)
(\FSETWIDTH WIDTHSY I 0))
(COND
(RELFLAG (* If the widths are size-relative, scale them.)
(for I from FIRSTCHAR to LASTCHAR
do (\FSETWIDTH WIDTHSY I (IQUOTIENT (ITIMES (ELT WIDTHSY I)
NSMICASIZE)
1000]
(RETURN CSINFO])
(\DOUBLE.BITMAP.4045
[LAMBDA (SOURCEBM) (* hdj " 9-Sep-85 21:33")
(LET* ((SOURCEWIDTH (BITMAPWIDTH SOURCEBM))
(SOURCEHEIGHT (BITMAPHEIGHT SOURCEBM))
(NEWWIDTH (ITIMES (IQUOTIENT (IPLUS (UNFOLD (BITMAPWIDTH SOURCEBM)
2)
23)
24)
24))
(NEWHEIGHT (ITIMES (BITMAPHEIGHT SOURCEBM)
2))
(NEWBITMAP (BITMAPCREATE NEWWIDTH NEWHEIGHT)))
(for X from 0 to (SUB1 SOURCEWIDTH)
do (BITBLT SOURCEBM X 0 NEWBITMAP (UNFOLD X 2)
0 1 SOURCEHEIGHT (QUOTE INPUT)
(QUOTE REPLACE))
(BITBLT SOURCEBM X 0 NEWBITMAP (ADD1 (UNFOLD X 2))
0 1 SOURCEHEIGHT (QUOTE INPUT)
(QUOTE REPLACE)))
(bind (NEWY ← NEWHEIGHT) for Y from (SUB1 SOURCEHEIGHT) to 0 by -1
do (BITBLT NEWBITMAP 0 Y NEWBITMAP 0 (SETQ NEWY (SUB1 NEWY))
NEWWIDTH 1 (QUOTE INPUT)
(QUOTE REPLACE))
(BITBLT NEWBITMAP 0 Y NEWBITMAP 0 (SETQ NEWY (SUB1 NEWY))
NEWWIDTH 1 (QUOTE INPUT)
(QUOTE REPLACE)))
NEWBITMAP])
(\DRAWLINE.4045
[LAMBDA (4045STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR) (* hdj " 5-Sep-85 11:58")
(* * 4045 can only handle horizontal or vertical lines -
issue warnings in the other cases)
(LET ((BACKINGSTREAM (\4045BackingStream 4045STREAM)))
(if (EQP X1 X2)
then (* vertical line)
(* (printout T "vertical line: (" X1 "," Y1 ") - (" X2
"," Y2 ")" T))
(\SEND4045COMMAND (CONCAT "y" X1 "," (MIN Y1 Y2)
","
(IABS (IDIFFERENCE Y2 Y1))
"," WIDTH)
BACKINGSTREAM)
elseif (EQP Y1 Y2)
then (* horizontal line)
(* (printout T "horizontal line: (" X1 "," Y1 ") - ("
X2 "," Y2 ")" T))
(\SEND4045COMMAND (CONCAT "x" (MIN X1 X2)
"," Y1 "," (IABS (IDIFFERENCE X2 X1))
"," WIDTH)
BACKINGSTREAM)
else (PROMPTPRINT "4045 cannot draw diagonal lines"))
(\MOVETO.4045 4045STREAM X2 Y2])
(\DRAWPOLYGON.4045
[LAMBDA (4045STREAM POINTS CLOSED BRUSH DASHING) (* hdj " 6-Sep-85 11:07")
(LET [(1STPT (CAR POINTS))
(BRUSHWIDTH (if (LISTP BRUSH)
then (CADR BRUSH)
elseif (NUMBERP BRUSH)
then BRUSH
else (\ILLEGAL.ARG BRUSH]
(PROG ((LASTPT 1STPT))
(for PT in (CDR POINTS) do (\DRAWLINE.4045 4045STREAM (fetch (POSITION XCOORD)
of LASTPT)
(fetch (POSITION YCOORD) of LASTPT)
(fetch (POSITION XCOORD) of PT)
(fetch (POSITION YCOORD) of PT)
BRUSHWIDTH))
(if CLOSED
then (\DRAWLINE.4045 4045STREAM (fetch (POSITION XCOORD) of LASTPT)
(fetch (POSITION YCOORD) of LASTPT)
(fetch (POSITION XCOORD) of 1STPT)
(fetch (POSITION YCOORD) of 1STPT)
BRUSHWIDTH])
(\DSPBOTTOMMARGIN.4045
[LAMBDA (4045STREAM YPOSITION) (* hdj "15-Aug-85 13:53")
(PROG1 (fetch 4045BOTTOM of (fetch IMAGEDATA of 4045STREAM))
(COND
(YPOSITION (replace 4045BOTTOM of (fetch IMAGEDATA of 4045STREAM) with YPOSITION])
(\DSPCLIPPINGREGION.4045
[LAMBDA (4045STREAM REGION) (* hdj "15-Aug-85 14:14")
(LET ((4045DATA (fetch (STREAM IMAGEDATA) of 4045STREAM)))
(PROG1 (fetch (4045DATA 4045CLIPPINGREGION) of 4045DATA)
(AND REGION (UNINTERRUPTABLY
(replace (4045DATA 4045CLIPPINGREGION) of 4045DATA with REGION))])
(\DSPFONT.4045
[LAMBDA (4045STREAM FONT) (* hdj " 2-Oct-85 18:00")
(* Change fonts (or return the current font) for a 4045
stream)
(PROG (OLDFONT (4045DATA (ffetch IMAGEDATA of 4045STREAM)))
(SETQ OLDFONT (ffetch 4045FONT of 4045DATA))
(AND (NULL FONT)
(RETURN OLDFONT))
(COND
([EQ OLDFONT (SETQ FONT (OR (\GETFONTDESC FONT (QUOTE 4045))
(FONTCOPY OLDFONT FONT]
(* There was no change, or she was only asking for the
old font. Just return it.)
(RETURN OLDFONT))) (* Get the font number to go in the file)
(freplace 4045FONT of 4045DATA with FONT) (* Remember the new font)
(freplace 4045WIDTHSCACHE of 4045DATA with (ffetch (ARRAYP BASE)
of (ffetch \SFWidths of FONT)))
[freplace 4045SPACEWIDTH of 4045DATA with (FIXR (TIMES (ffetch 4045SPACEFACTOR
of 4045DATA)
(\FGETWIDTH (ffetch 4045WIDTHSCACHE
of 4045DATA)
(CHARCODE SPACE]
(* Set the linefeed distance to be one point more than
the font height)
[freplace 4045LINEFEED of 4045DATA with (ADD1 (FONTPROP FONT (QUOTE HEIGHT]
(freplace 4045NSTRANSTABLE of 4045DATA with (ffetch OTHERDEVICEFONTPROPS of FONT))
(SELECTQ (FONTPROP FONT (QUOTE WEIGHT))
(BOLD (if (NEQ (FONTPROP OLDFONT (QUOTE WEIGHT))
(QUOTE BOLD))
then (\BOLDMODE.4045 4045STREAM)))
(if (EQ (FONTPROP OLDFONT (QUOTE WEIGHT))
(QUOTE BOLD))
then (\MEDIUMMODE.4045 4045STREAM)))
(\FIXLINELENGTH.4045 4045STREAM)
(RETURN OLDFONT])
(\BOLDMODE.4045
[LAMBDA (4045STREAM) (* hdj " 2-Oct-85 18:16")
(* * turn on bold mode)
(LET ((BACK (\4045BackingStream 4045STREAM)))
(for C instring "b" do (BOUT BACK C])
(\MEDIUMMODE.4045
[LAMBDA (4045STREAM) (* hdj " 2-Oct-85 17:43")
(* * turn off bold mode)
(LET ((BACK (\4045BackingStream 4045STREAM)))
(for C instring "p" do (BOUT BACK C])
(\DSPLEFTMARGIN.4045
[LAMBDA (4045STREAM XPOSITION) (* hdj "15-Aug-85 13:54")
(PROG1 (ffetch 4045LEFT of (ffetch IMAGEDATA of 4045STREAM))
(COND
(XPOSITION (freplace 4045LEFT of (ffetch IMAGEDATA of 4045STREAM) with XPOSITION)
(\FIXLINELENGTH.4045 4045STREAM])
(\DSPLINEFEED.4045
[LAMBDA (4045STREAM DELTAY) (* hdj "15-Aug-85 13:54")
(* sets the amount that a line feed increases the y
coordinate by.)
(PROG ((4045DATA (ffetch IMAGEDATA of 4045STREAM)))
(RETURN (PROG1 (ffetch 4045LINEFEED of 4045DATA)
(AND DELTAY (COND
((NUMBERP DELTAY)
(freplace 4045LINEFEED of 4045DATA with DELTAY))
(T (\ILLEGAL.ARG DELTAY])
(\DSPRIGHTMARGIN.4045
[LAMBDA (4045STREAM XPOSITION) (* hdj "15-Aug-85 13:53")
(PROG1 (ffetch 4045RIGHT of (ffetch IMAGEDATA of 4045STREAM))
(COND
(XPOSITION (freplace 4045RIGHT of (ffetch IMAGEDATA of 4045STREAM) with XPOSITION)
(\FIXLINELENGTH.4045 4045STREAM])
(\DSPSPACEFACTOR.4045
[LAMBDA (4045STREAM FACTOR) (* hdj "15-Aug-85 13:56")
(PROG ((4045DATA (ffetch IMAGEDATA of 4045STREAM)))
(RETURN (PROG1 (ffetch 4045SPACEFACTOR of 4045DATA)
(COND
(FACTOR [freplace 4045SPACEWIDTH of 4045DATA
with (FIXR (TIMES FACTOR (\FGETWIDTH (ffetch 4045WIDTHSCACHE
of 4045DATA)
(CHARCODE SPACE]
(* Doing the multiply first will insure that FACTOR is
a number)
(freplace 4045SPACEWIDTH of 4045DATA with FACTOR])
(\DSPTOPMARGIN.4045
[LAMBDA (4045STREAM YPOSITION) (* hdj "15-Aug-85 13:53")
(PROG1 (fetch 4045TOP of (fetch IMAGEDATA of 4045STREAM))
(COND
(YPOSITION (replace 4045TOP of (fetch IMAGEDATA of 4045STREAM) with YPOSITION])
(\DSPXPOSITION.4045
[LAMBDA (4045STREAM XPOSITION) (* hdj "15-Aug-85 14:12")
(PROG1 (fetch 4045XPOS of (fetch IMAGEDATA of 4045STREAM))
(COND
(XPOSITION (SETXY.4045 4045STREAM XPOSITION (fetch 4045YPOS
of (fetch IMAGEDATA of 4045STREAM])
(\DSPYPOSITION.4045
[LAMBDA (4045STREAM YPOSITION) (* hdj " 2-Oct-85 18:33")
(PROG1 (fetch 4045YPOS of (fetch IMAGEDATA of 4045STREAM))
(COND
(YPOSITION (SETXY.4045 4045STREAM (fetch 4045XPOS of (fetch IMAGEDATA of 4045STREAM))
YPOSITION])
(\FIXLINELENGTH.4045
[LAMBDA (4045STREAM) (* hdj "15-Aug-85 14:06")
(* 4045STREAM is known to be a stream of type 4045 -
Called by RIGHTMARGIN LEFTMARGIN and \SFFIXFONT to update the LINELENGTH field in the stream.
also called when the stream is created.)
(PROG (LLEN (4045DATA (ffetch IMAGEDATA of 4045STREAM)))
(freplace (STREAM LINELENGTH) of 4045STREAM
with (COND
((IGREATERP [SETQ LLEN (IQUOTIENT (IDIFFERENCE (ffetch 4045RIGHT of 4045DATA)
(ffetch 4045LEFT of 4045DATA))
(ffetch FONTAVGCHARWIDTH
of (ffetch 4045FONT of 4045DATA]
1)
LLEN)
(T 10])
(\MOVETO.4045
[LAMBDA (4045STREAM X Y) (* hdj "15-Aug-85 00:21")
(SETXY.4045 4045STREAM X Y])
(\READ4045FONTFILE
[LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE CHARSET) (* hdj "25-Sep-85 15:27")
(* 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.)
(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)))
(CSINFO (create CHARSETINFO))
(FD (create FONTDESCRIPTOR
FONTDEVICE ← DEVICE
FONTFAMILY ← FAMILY
FONTSIZE ← PSIZE
FONTFACE ← FACE
\SFFACECODE ← (\FACECODE FACE)
ROTATION ← ROTATION
OTHERDEVICEFONTPROPS ← \ASCIITONS
FONTSCALE ← (CONSTANT (FQUOTIENT 300 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 (FIXR (TIMES 4045.DOTSPERMICA
(SIGNED (\WIN WSTRM)
BITSPERWORD]
(* Get the max bounding width for the font)
[replace \SFDescent of FD with (PROG1 10
(IMINUS (FIXR (TIMES 4045.DOTSPERMICA
(SIGNED (\WIN WSTRM)
BITSPERWORD]
(* Descent is -FBBOY)
[replace (FONTDESCRIPTOR FBBDX) of FD with (FIXR (TIMES 4045.DOTSPERMICA
(SIGNED (\WIN WSTRM)
BITSPERWORD]
(* And the standard kern value
(?))
[replace \SFHeight of FD with (PROG1 50 (FIXR (TIMES 4045.DOTSPERMICA
(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 (PROG1 30 (FIXR (TIMES 4045.DOTSPERMICA (\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
do (* For chars that have no width info, let width be
zero.)
(SETA WIDTHS I (if (EQ noInfoCode (ELT WIDTHS I))
then 0
else (PROG1 30 (FIXR (TIMES 4045.DOTSPERMICA
(ELT WIDTHS I]
(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
do (* Let any characters with no width info be zero
height)
(SETA WIDTHS I (if (EQ noInfoCode (ELT WIDTHSY I))
then 0
else (FIXR (TIMES 4045.DOTSPERMICA (ELT WIDTHSY I]
(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]
(\RPLPTR (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR) of FD)
0 CSINFO)
(replace (CHARSETINFO WIDTHS) of CSINFO with (fetch (ARRAYP BASE) of WIDTHS))
(RETURN FD])
(\SCALEDBITBLT.4045
[LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH
HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT
CLIPPEDSOURCEBOTTOM SCALE) (* hdj "14-Feb-85 14:33")
(LET* ((OLDX (\DSPXPOSITION.IP DESTINATION))
(OLDY (\DSPYPOSITION.IP DESTINATION))
(DESTINATIONLEFT (OR DESTINATIONLEFT OLDX))
(DESTINATIONBOTTOM (OR DESTINATIONBOTTOM OLDY)))
(\MOVETO.IP DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM)
(SHOWBITMAP.IP DESTINATION SOURCEBITMAP (COND
(CLIPPINGREGION (INTERSECTREGIONS CLIPPINGREGION
(CREATEREGION CLIPPEDSOURCELEFT
CLIPPEDSOURCEBOTTOM WIDTH
HEIGHT)))
(T (CREATEREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM WIDTH HEIGHT)))
SCALE)
(\MOVETO.IP DESTINATION OLDX OLDY))
T])
(\SEARCH4045FONTS
[LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE) (* hdj "15-Aug-85 14:40")
(* * returns a list of the form (family size face rotation INTERPRESS) for any font matching the specs.
* is used as wildcard.)
(DECLARE (GLOBALVARS INTERPRESSFONTDIRECTORIES))
(bind FONTSFOUND THISFONT (FILENAMEPATTERN ←(\FONTFILENAME FAMILY PSIZE FACE (QUOTE WD)))
for DIR inside INTERPRESSFONTDIRECTORIES
do [for FONTFILE in (DIRECTORY (PACKFILENAME (QUOTE DIRECTORY)
DIR
(QUOTE BODY)
FILENAMEPATTERN))
when [PROGN (SETQ THISFONT (\FONTINFOFROMFILENAME FONTFILE DEVICE))
(AND (OR (EQ FAMILY (QUOTE *))
(EQ FAMILY (CAR THISFONT)))
(OR (EQ PSIZE (QUOTE *))
(EQ PSIZE (CADR THISFONT)))
(OR (EQ FACE (QUOTE *))
(EQUAL FACE (CADDR THISFONT]
do (* make sure the file is appropriate e.g. the directory
pattern for CLASSIC if SIZE is * will match
CLASSICTHIN10 as well.)
(OR (MEMBER THISFONT FONTSFOUND)
(SETQ FONTSFOUND (CONS THISFONT FONTSFOUND]
finally (RETURN FONTSFOUND])
(\SEND4045COMMAND
[LAMBDA (STRING BACKINGSTREAM) (* hdj " 5-Sep-85 11:57")
(BOUT BACKINGSTREAM (CHARCODE ESC))
(for C instring STRING do (BOUT BACKINGSTREAM C))
(BOUT BACKINGSTREAM (CHARCODE CR))
(BOUT BACKINGSTREAM (CHARCODE LF])
(\STRINGWIDTH.4045
[LAMBDA (4045STREAM STRING RDTBL) (* hdj "15-Aug-85 14:07")
(* Returns the width of STRING in the interpress
STREAM, observing spacefactor)
(\STRINGWIDTH.GENERIC STRING (ffetch 4045FONT of (ffetch IMAGEDATA of 4045STREAM))
RDTBL
(ffetch 4045SPACEWIDTH of (ffetch IMAGEDATA of 4045STREAM])
(\WINDOWCMD.4045
[LAMBDA (MAGNIFICATION LEFT TOP WIDTH HEIGHT BACKINGSTREAM)
(* hdj " 3-Oct-85 11:48")
(for CH instring (CONCAT "gw" (if (EQ MAGNIFICATION 2)
then 2000
else MAGNIFICATION)
";" LEFT "," TOP "," WIDTH "," HEIGHT "
%
")
do (BOUT BACKINGSTREAM CH])
)
(DECLARE: EVAL@LOAD DONTCOPY
[DECLARE: EVAL@COMPILE
(BLOCKRECORD SIXEL ((ZERO BITS 6)
(ONE BITS 6)
(TWO.1 BITS 4)
(TWO.2 BITS 2)
(THREE BITS 6)
(FOUR BITS 6)
(FIVE.1 BITS 2)
(FIVE.2 BITS 4)
(SIX BITS 6)
(SEVEN BITS 6))
[ACCESSFNS SIXEL ([TWO (LOGOR (LLSH (fetch (SIXEL TWO.1) of DATUM)
2)
(fetch (SIXEL TWO.2) of DATUM))
(PROGN (replace (SIXEL TWO.1) of DATUM
with (LOGAND (MASK.1'S 0 4)
(LRSH DATUM 2)))
(replace (SIXEL TWO.2) of DATUM
with (LOGAND (MASK.1'S 0 2)
DATUM]
(FIVE (LOGOR (LLSH (fetch (SIXEL FIVE.1) of DATUM)
4)
(fetch (SIXEL FIVE.2) of DATUM])
]
(FILESLOAD (LOADFROM)
INTERPRESS)
)
[DECLARE: EVAL@COMPILE
(DATATYPE 4045DATA ((4045BOTTOM WORD)
(4045TOP WORD)
(4045RIGHT WORD)
(4045LEFT WORD)
(4045LINEFEED WORD)
4045XPOS 4045YPOS 4045CLIPPINGREGION 4045NSTRANSTABLE 4045WIDTHSCACHE 4045SPACEWIDTH
4045SPACEFACTOR 4045FONT)
4045BOTTOM ← 0 4045TOP ← 3000 4045RIGHT ← 2400 4045LEFT ← 0 4045LINEFEED ← 10
4045CLIPPINGREGION ←(CREATEREGION 0 0 2550 3300)
4045XPOS ← 0 4045YPOS ← 0 4045SPACEFACTOR ← 1)
]
(/DECLAREDATATYPE (QUOTE 4045DATA)
(QUOTE (WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER
POINTER POINTER))
(QUOTE ((4045DATA 0 (BITS . 15))
(4045DATA 1 (BITS . 15))
(4045DATA 2 (BITS . 15))
(4045DATA 3 (BITS . 15))
(4045DATA 4 (BITS . 15))
(4045DATA 6 POINTER)
(4045DATA 8 POINTER)
(4045DATA 10 POINTER)
(4045DATA 12 POINTER)
(4045DATA 14 POINTER)
(4045DATA 16 POINTER)
(4045DATA 18 POINTER)
(4045DATA 20 POINTER)))
(QUOTE 22))
(FILESLOAD CENTRONICS)
(RPAQQ 4045.DOTSPERMICA .122449)
(RPAQQ 4045.DOTSPERPOINT 4.166667)
(RPAQ \ASCIITOASCII (READARRAY 256 (QUOTE SMALLPOSP) 0))
(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36
37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70
71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103
104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128
129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153
154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178
179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203
204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228
229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253
254 255 NIL
)
(DECLARE: EVAL@COMPILE
(DEFMACRO \4045BackingStream (4045STREAM)
(BQUOTE (fetch (STREAM F1)
of , 4045STREAM)))
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(\4045INIT)
)
(PUTPROPS 4045STREAM COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1371 48267 (4045.EncodedSixelofBitmap 1381 . 2245) (4045.OUTCHARFN 2247 . 3955) (
BEGINPAGE.4045 3957 . 4105) (ENDPAGE.4045 4107 . 4283) (NEWLINE.4045 4285 . 4818) (NEWPAGE.4045 4820
. 4999) (OPEN4045STREAM 5001 . 5968) (SETXY.4045 5970 . 6434) (\4045INIT 6436 . 10068) (\BITBLT.4045
10070 . 11820) (\BLTSHADE.4045 11822 . 12201) (\CHARWIDTH.4045 12203 . 12652) (\CLOSE4045STREAM 12654
. 12849) (\COERCEASCIITO4045FONT 12851 . 15890) (\CREATE4045FONT 15892 . 17059) (\CREATECHARSET.4045
17061 . 25286) (\DOUBLE.BITMAP.4045 25288 . 26462) (\DRAWLINE.4045 26464 . 27706) (\DRAWPOLYGON.4045
27708 . 28670) (\DSPBOTTOMMARGIN.4045 28672 . 28997) (\DSPCLIPPINGREGION.4045 28999 . 29413) (
\DSPFONT.4045 29415 . 31590) (\BOLDMODE.4045 31592 . 31857) (\MEDIUMMODE.4045 31859 . 32127) (
\DSPLEFTMARGIN.4045 32129 . 32492) (\DSPLINEFEED.4045 32494 . 33057) (\DSPRIGHTMARGIN.4045 33059 .
33425) (\DSPSPACEFACTOR.4045 33427 . 34131) (\DSPTOPMARGIN.4045 34133 . 34449) (\DSPXPOSITION.4045
34451 . 34795) (\DSPYPOSITION.4045 34797 . 35140) (\FIXLINELENGTH.4045 35142 . 35923) (\MOVETO.4045
35925 . 36070) (\READ4045FONTFILE 36072 . 44746) (\SCALEDBITBLT.4045 44748 . 45679) (\SEARCH4045FONTS
45681 . 47054) (\SEND4045COMMAND 47056 . 47380) (\STRINGWIDTH.4045 47382 . 47856) (\WINDOWCMD.4045
47858 . 48265)))))
STOP