(FILECREATED " 3-Oct-85 16:03:22" {ERIS}<LISPCORE>LIBRARY>FX80STREAM.;7 78524
changes to: (FNS OPENFX80STREAM \OUTCHARFN.FX80 \CHANGECHARSET.FX80)
(VARS FX80STREAMCOMS)
previous date: "30-Sep-85 14:16:29" {ERIS}<LISPCORE>LIBRARY>FX80STREAM.;6)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT FX80STREAMCOMS)
(RPAQQ FX80STREAMCOMS [(FNS NEWLINE.FX80 NEWPAGE.FX80 OPENFX80STREAM STARTPAGE.FX80 \BITBLT.FX80
\BLTCHAR.FX80 \BLTSHADE.FX80 \CHANGECHARSET.FX80 \CHARWIDTH.FX80
\CLOSEFN.FX80 \CREATECHARSET.FX80 \CREATEFX80FONT \SEARCHFX80FONTFILES
\STRINGWIDTH.FX80 \DRAWCIRCLE.FX80 \DRAWCURVE.FX80 \DRAWELLIPSE.FX80
\DRAWLINE.FX80 \DSPCLIPPINGREGION.FX80 \DSPFONT.FX80
\DSPLEFTMARGIN.FX80 \DSPLINEFEED.FX80 \DSPOPERATION.FX80
\DSPPRINTCHAR.FX80 \DSPPRINTCR/LF.FX80 \DSPRESET.FX80
\DSPRIGHTMARGIN.FX80 \DSPXPOSITION.FX80 \DSPYPOSITION.FX80
\DUMPPAGEBUFFER.FX80 \FILLCIRCLE.FX80 \FX80.CRLF \FX80.GRAPHICSMODE
\FX80.PRINTERCOMMAND \FX80.PRINTERMODE \FX80INIT \OUTCHARFN.FX80)
(INITVARS (FX80BAUDRATE 9600))
(CONSTANTS \FX80PointsPerInch)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (\FX80INIT])
(DEFINEQ
(NEWLINE.FX80
[LAMBDA (FX80STREAM) (* hdj "21-Jan-85 12:35")
(* Go to next line (or next page))
(PROG (NEWYPOS (FX80DATA (ffetch IMAGEDATA of FX80STREAM)))
(SETQ NEWYPOS (IPLUS (ffetch DDYPOSITION of FX80DATA)
(ffetch DDLINEFEED of FX80DATA)))
(COND
((ILESSP NEWYPOS (ffetch DDClippingBottom of FX80DATA))
(NEWPAGE.FX80 FX80STREAM))
(T (\DSPXPOSITION.FX80 FX80STREAM (ffetch DDLeftMargin of FX80DATA))
(\DSPYPOSITION.FX80 FX80STREAM NEWYPOS])
(NEWPAGE.FX80
[LAMBDA (FX80STREAM) (* hdj "25-Jan-85 17:32")
(LET ((DD (fetch (STREAM IMAGEDATA) of FX80STREAM)))
(\DUMPPAGEBUFFER.FX80 (fetch DDDestination of DD)
FX80STREAM)
(STARTPAGE.FX80 FX80STREAM])
(OPENFX80STREAM
[LAMBDA (FX80FILE OPTIONS) (* hdj " 3-Oct-85 15:19")
(* Opens an FX80 stream)
(DECLARE (GLOBALVARS \FX80IMAGEOPS FX80BAUDRATE))
(LET* ((WIDTH (ITIMES 8 \FX80PointsPerInch))
(HEIGHT (ITIMES 11 \FX80PointsPerInch))
(FX80STREAM (DSPCREATE (BITMAPCREATE WIDTH HEIGHT)))
(DISPLAYDATA (\GETDISPLAYDATA FX80STREAM)))
[replace (STREAM F1) of FX80STREAM with (OPENSTREAM FX80FILE (QUOTE OUTPUT)
(QUOTE NEW)
8
(BQUOTE ((BaudRate
,
(OR FX80BAUDRATE
9600))
(BitsPerSerialChar
8)
(NoOfStopBits 1)
(ModemControl DTR]
(replace (STREAM OUTCHARFN) of FX80STREAM with (FUNCTION \OUTCHARFN.FX80))
(replace (STREAM STRMBOUTFN) of FX80STREAM with (FUNCTION \DSPPRINTCHAR.FX80))
(replace (STREAM USERCLOSEABLE) of FX80STREAM with T)
(replace (STREAM IMAGEOPS) of FX80STREAM with \FX80IMAGEOPS)
(replace (\DISPLAYDATA DDClippingRegion) of DISPLAYDATA
with (CREATEREGION 0 0 WIDTH HEIGHT))
(STARTPAGE.FX80 FX80STREAM)
FX80STREAM])
(STARTPAGE.FX80
[LAMBDA (FX80STREAM) (* hdj "25-Jan-85 17:48")
(LET* ((DD (\GETDISPLAYDATA FX80STREAM))
(CREG (fetch DDClippingRegion of DD))
(FONTASCENT (FONTASCENT (fetch DDFONT of DD)))
(PAGEBUFFER (fetch DDDestination of DD)))
(\BLTSHADE.BITMAP WHITESHADE PAGEBUFFER NIL NIL NIL NIL (QUOTE REPLACE))
(\DSPXPOSITION.FX80 FX80STREAM (fetch DDLeftMargin of DD))
(\DSPYPOSITION.FX80 FX80STREAM (ADD1 (IDIFFERENCE (fetch TOP of CREG)
FONTASCENT])
(\BITBLT.FX80
[LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM FX80STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH
HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT
CLIPPEDSOURCEBOTTOM) (* hdj "18-Jan-85 17:28")
(DECLARE (LOCALVARS . T))
(COND
((NEQ 1 (fetch (BITMAP BITMAPBITSPERPIXEL) of SOURCEBITMAP))
(* going from color map into black and white map.)
(ERROR "not implemented to blt between bitmaps of different pixel size.")))
(PROG (stodx stody left top bottom right DESTBITMAP (DESTDD (fetch IMAGEDATA of FX80STREAM)))
(SETQ DESTBITMAP (fetch DDDestination of DESTDD))
(SETQ DESTINATIONLEFT (\DSPTRANSFORMX DESTINATIONLEFT DESTDD))
(SETQ DESTINATIONBOTTOM (\DSPTRANSFORMY DESTINATIONBOTTOM DESTDD))
[PROGN (* compute limits based on clipping regions.)
(SETQ left (fetch DDClippingLeft of DESTDD))
(SETQ bottom (fetch DDClippingBottom of DESTDD))
(SETQ right (fetch DDClippingRight of DESTDD))
(SETQ top (fetch DDClippingTop of DESTDD))
(COND
(CLIPPINGREGION (* hard case, two destination clipping regions: do
calculations to merge them.)
(PROG (CRLEFT CRBOTTOM)
[SETQ left (IMAX left (SETQ CRLEFT
(\DSPTRANSFORMX (fetch LEFT of
CLIPPINGREGION)
DESTDD]
[SETQ bottom (IMAX bottom (SETQ CRBOTTOM
(\DSPTRANSFORMY (fetch BOTTOM
of CLIPPINGREGION)
DESTDD]
[SETQ right (IMIN right (IPLUS CRLEFT (fetch WIDTH
of CLIPPINGREGION]
(SETQ top (IMIN top (IPLUS CRBOTTOM (fetch HEIGHT
of CLIPPINGREGION]
(* left, right top and bottom are the limits in destination taking into account Clipping Regions.
Clip to region in the arguments of this call.)
[PROGN (SETQ left (IMAX DESTINATIONLEFT left))
(SETQ bottom (IMAX DESTINATIONBOTTOM bottom))
[COND
(WIDTH (* WIDTH is optional)
(SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH)
right]
(COND
(HEIGHT (* HEIGHT is optional)
(SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT)
top] (* Clip and translate coordinates.)
(SETQ stodx (IDIFFERENCE DESTINATIONLEFT SOURCELEFT))
(SETQ stody (IDIFFERENCE DESTINATIONBOTTOM SOURCEBOTTOM))
(* compute the source dimensions (left right bottom top) by intersecting the source bit map, the source area to be
moved with the limits of the region to be moved in the destination coordinates.)
[PROGN (* compute left margin)
(SETQ left (IMAX CLIPPEDSOURCELEFT (IDIFFERENCE left stodx)
0)) (* compute bottom margin)
(SETQ bottom (IMAX CLIPPEDSOURCEBOTTOM (IDIFFERENCE bottom stody)
0))
[PROGN (* compute right margin)
(SETQ right (IMIN (ffetch BITMAPWIDTH of SOURCEBITMAP)
(IDIFFERENCE right stodx)
(IPLUS CLIPPEDSOURCELEFT WIDTH]
(PROGN (* compute top margin)
(SETQ top (IMIN (ffetch BITMAPHEIGHT of SOURCEBITMAP)
(IDIFFERENCE top stody)
(IPLUS CLIPPEDSOURCEBOTTOM HEIGHT]
(COND
((OR (ILEQ right left)
(ILEQ top bottom)) (* there is nothing to move.)
(RETURN)))
(OR OPERATION (SETQ OPERATION (ffetch (\DISPLAYDATA DDOPERATION) of DESTDD)))
(SELECTQ SOURCETYPE
[MERGE (* Need to use complement of TEXTURE)
(SETQ TEXTURE (COND
((NULL TEXTURE)
BLACKSHADE)
((FIXP TEXTURE)
(LOGXOR (LOGAND TEXTURE BLACKSHADE)
BLACKSHADE))
[(type? BITMAP TEXTURE)
(INVERT.TEXTURE.BITMAP TEXTURE (OR \BBSCRATCHTEXTURE
(SETQ \BBSCRATCHTEXTURE
(BITMAPCREATE 16 16]
(T (\ILLEGAL.ARG TEXTURE]
NIL)
(UNINTERRUPTABLY
[PROG ([PILOTBBT (COND
((type? PILOTBBT \SYSPILOTBBT)
\SYSPILOTBBT)
(T (SETQ \SYSPILOTBBT (create PILOTBBT]
(HEIGHT (IDIFFERENCE top bottom))
(WIDTH (IDIFFERENCE right left))
(DTY (\SFInvert DESTBITMAP (IPLUS top stody)))
(DLX (IPLUS left stodx))
(STY (\SFInvert SOURCEBITMAP top))
(SLX left))
(replace PBTWIDTH of PILOTBBT with WIDTH)
(replace PBTHEIGHT of PILOTBBT with HEIGHT)
(COND
((EQ SOURCETYPE (QUOTE MERGE))
(\BITBLT.MERGE PILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH HEIGHT
OPERATION TEXTURE))
(T (\BITBLTSUB PILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY HEIGHT
SOURCETYPE OPERATION TEXTURE])
(RETURN T])
(\BLTCHAR.FX80
(LAMBDA (CHARCODE FX80STREAM DISPLAYDATA) (* ejs: "29-Aug-85 23:22")
(* puts a character on a display stream. Much of the information needed by the BitBlt microcode is prestored by the
routines that change it. This is kept in the BitBltTable.)
(* knows about the representation of an FX80STREAM)
(DECLARE (LOCALVARS . T))
(PROG (LOCAL1 RIGHT LEFT CURX (CHAR8CODE (\CHAR8CODE CHARCODE)))
CRLP(COND
((NEQ (ffetch DDCHARSET of DISPLAYDATA)
(\CHARSET CHARCODE))
(\CHANGECHARSET.DISPLAY DISPLAYDATA (\CHARSET CHARCODE))))
(COND
((ffetch (\DISPLAYDATA DDSlowPrintingCase) of DISPLAYDATA)
(RETURN (\SLOWBLTCHAR CHARCODE FX80STREAM))))
(COND
((IGREATERP (SETQ RIGHT (IPLUS (SETQ CURX (ffetch DDXPOSITION of DISPLAYDATA))
(\DSPGETCHARWIDTH CHAR8CODE DISPLAYDATA)))
(ffetch DDRightMargin of DISPLAYDATA))
(* would go past right margin, force a cr)
(COND
((IGREATERP CURX (ffetch DDLeftMargin of DISPLAYDATA))
(* don't bother CR if position is at left margin
anyway. This also serves to break the loop.)
(\DSPPRINTCR/LF.FX80 (CHARCODE EOL)
FX80STREAM) (* reuse the code in the test of this conditional
rather than repeat it here.)
(GO CRLP))))) (* update the display stream x position.)
(freplace DDXPOSITION of DISPLAYDATA with RIGHT) (* transforms an x coordinate into the destination
coordinate.)
(SETQ CURX (IPLUS CURX (SETQ LOCAL1 (ffetch DDXOFFSET of DISPLAYDATA))))
(SETQ RIGHT (IPLUS RIGHT LOCAL1))
(COND
((IGREATERP RIGHT (SETQ LOCAL1 (ffetch DDClippingRight of DISPLAYDATA)))
(* character overlaps right edge of clipping region.)
(SETQ RIGHT LOCAL1)))
(SETQ LEFT (COND
((IGREATERP CURX (SETQ LOCAL1 (ffetch DDClippingLeft of DISPLAYDATA)))
CURX)
(T LOCAL1)))
(RETURN (COND
((AND (ILESSP LEFT RIGHT)
(NEQ (fetch PBTHEIGHT of (SETQ LOCAL1 (ffetch DDPILOTBBT of DISPLAYDATA)))
0))
(.WHILE.TOP.DS. FX80STREAM (freplace PBTDESTBIT of LOCAL1 with LEFT)
(freplace PBTWIDTH of LOCAL1 with (IDIFFERENCE RIGHT LEFT))
(freplace PBTSOURCEBIT of LOCAL1
with (IDIFFERENCE (IPLUS (\DSPGETCHAROFFSET CHAR8CODE
DISPLAYDATA)
LEFT)
CURX))
(\PILOTBITBLT LOCAL1 0))
T))))))
(\BLTSHADE.FX80
[LAMBDA (TEXTURE FX80STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION)
(* hdj "18-Jan-85 17:29")
(* BLTSHADE to the FX80 printer page)
(DECLARE (LOCALVARS . T))
(PROG (left top bottom right DESTINATIONBITMAP (DESTDD (fetch IMAGEDATA of FX80STREAM)))
(SETQ DESTINATIONLEFT (\DSPTRANSFORMX DESTINATIONLEFT DESTDD))
(SETQ DESTINATIONBOTTOM (\DSPTRANSFORMY DESTINATIONBOTTOM DESTDD))
[PROGN (* compute limits based on clipping regions.)
(SETQ left (fetch DDClippingLeft of DESTDD))
(SETQ bottom (fetch DDClippingBottom of DESTDD))
(SETQ right (fetch DDClippingRight of DESTDD))
(SETQ top (fetch DDClippingTop of DESTDD))
(COND
(CLIPPINGREGION (* hard case, two destination clipping regions: do
calculations to merge them.)
(PROG (CRLEFT CRBOTTOM)
[SETQ left (IMAX left (SETQ CRLEFT
(\DSPTRANSFORMX (fetch LEFT of
CLIPPINGREGION)
DESTDD]
[SETQ bottom (IMAX bottom (SETQ CRBOTTOM
(\DSPTRANSFORMY (fetch BOTTOM
of CLIPPINGREGION)
DESTDD]
[SETQ right (IMIN right (IPLUS CRLEFT (fetch WIDTH
of CLIPPINGREGION]
(SETQ top (IMIN top (IPLUS CRBOTTOM (fetch HEIGHT
of CLIPPINGREGION]
(SETQ DESTINATIONBITMAP (fetch DDDestination of DESTDD))
(* left, right top and bottom are the limits in destination taking into account Clipping Regions.
Clip to region in the arguments of this call.)
[PROGN (SETQ left (IMAX DESTINATIONLEFT left))
(SETQ bottom (IMAX DESTINATIONBOTTOM bottom))
[COND
(WIDTH (* WIDTH is optional)
(SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH)
right]
(COND
(HEIGHT (* HEIGHT is optional)
(SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT)
top]
(COND
((AND (IGREATERP right left)
(IGREATERP top bottom)))
(T (* there is nothing to move.)
(RETURN)))
(SELECTQ (TYPENAME TEXTURE)
[LITATOM (* includes NIL case)
(COND
((NULL TEXTURE) (* default texture to background texture.)
(SETQ TEXTURE (ffetch (\DISPLAYDATA DDTexture) of DESTDD)))
(T (\ILLEGAL.ARG TEXTURE]
((SMALLP FIXP)
(SETQ TEXTURE (LOGAND TEXTURE BLACKSHADE)))
(BITMAP NIL)
(\ILLEGAL.ARG TEXTURE))
(UNINTERRUPTABLY
(PROG ([PILOTBBT (COND
((type? PILOTBBT \SYSPILOTBBT)
\SYSPILOTBBT)
(T (SETQ \SYSPILOTBBT (create PILOTBBT]
(HEIGHT (IDIFFERENCE top bottom)))
(replace PBTWIDTH of PILOTBBT with (IDIFFERENCE right left))
(replace PBTHEIGHT of PILOTBBT with HEIGHT)
(\BITBLTSUB PILOTBBT NIL left NIL DESTINATIONBITMAP left (\SFInvert
DESTINATIONBITMAP top)
HEIGHT
(QUOTE TEXTURE)
(OR OPERATION (ffetch (\DISPLAYDATA DDOPERATION) of DESTDD))
TEXTURE)))
(RETURN T])
(\CHANGECHARSET.FX80
[LAMBDA (FX80DATA CHARSET) (* hdj " 3-Oct-85 15:56")
(* Called when the character set information cached in
a display stream doesn't correspond to CHARSET)
(PROG [BM (PBT (ffetch DDPILOTBBT of FX80DATA))
(CSINFO (\GETCHARSETINFO CHARSET (ffetch DDFONT of FX80DATA]
(* Since we called \GETCHARSETINFO without the NOSLUG? flag, we presume we will get back a CSINFO , even if it is a
slug csinfo)
(UNINTERRUPTABLY
(freplace DDWIDTHSCACHE of FX80DATA with (ffetch (CHARSETINFO WIDTHS)
of CSINFO))
(freplace DDOFFSETSCACHE of FX80DATA with (ffetch (CHARSETINFO OFFSETS)
of CSINFO))
(freplace DDCHARIMAGEWIDTHS of FX80DATA with (ffetch (CHARSETINFO IMAGEWIDTHS)
of CSINFO))
(freplace DDCHARSET of FX80DATA with CHARSET)
(SETQ BM (ffetch CHARSETBITMAP of CSINFO))
(freplace PBTSOURCEBPL of PBT with (UNFOLD (ffetch BITMAPRASTERWIDTH
of BM)
BITSPERWORD))
[if (OR (NEQ (ffetch DDCHARSETASCENT of FX80DATA)
(ffetch CHARSETASCENT of CSINFO))
(NEQ (ffetch DDCHARSETDESCENT of FX80DATA)
(ffetch CHARSETDESCENT of CSINFO)))
then (\SFFixY FX80DATA CSINFO)
else (freplace PBTSOURCE of PBT with (\ADDBASE (ffetch BITMAPBASE
of BM)
(ITIMES (ffetch
BITMAPRASTERWIDTH
of BM)
(ffetch
DDCHARHEIGHTDELTA
of FX80DATA]
)])
(\CHARWIDTH.FX80
[LAMBDA (FX80STREAM CHARCODE) (* hdj "18-Jan-85 17:30")
(* gets the width of a character code in a display
stream. Need to fix up for spacefactor.)
(\FGETWIDTH (ffetch (\DISPLAYDATA DDWIDTHSCACHE) of (ffetch IMAGEDATA of FX80STREAM))
CHARCODE])
(\CLOSEFN.FX80
[LAMBDA (FX80STREAM) (* hdj "25-Jan-85 17:45")
(* * "do cleanup prefatory to closing. dump last buffer" "and close the backing stream")
(LET ((DD (fetch (STREAM IMAGEDATA) of FX80STREAM)))
(\DUMPPAGEBUFFER.FX80 (fetch DDDestination of DD)
FX80STREAM)
(CLOSEF (fetch (STREAM F1) of FX80STREAM])
(\CREATECHARSET.FX80
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?)
(* hdj "27-Sep-85 15:49")
(* * tries to build the csinfo required for CHARSET. Does the necessary coercions. Returns NIL when unsuccessful
(\CREATECHARSET will do the same))
(* * NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL)
(DECLARE (GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS))
(* DISPLAYFONTCOERCIONS is a list of font coercions, in the form ((user-font real-font) (user-font real-font) ...).
Each user-font is a list of FAMILY, and optionally SIZE and CHARSET, (e.g., (GACHA) or (GACHA 10) or
(GACHA 10 143)), and each real-font is a similar list.)
(COND
((PROG1 (for TRANSL in DISPLAYFONTCOERCIONS bind NEWCSINFO USER-FONT REALFONT
when (AND (SETQ USER-FONT (CAR TRANSL))
(EQ FAMILY (CAR USER-FONT))
(OR (NOT (CADR USER-FONT))
(EQ SIZE (CADR USER-FONT)))
(OR (NOT (CADDR USER-FONT))
(EQ CHARSET (CADDR USER-FONT)))
(SETQ REALFONT (CADR TRANSL))
(SETQ NEWCSINFO (\CREATECHARSET.FX80 (OR (CAR REALFONT)
FAMILY)
(OR (CADR REALFONT)
SIZE)
FACE ROTATION DEVICE
(OR (CADDR REALFONT)
CHARSET)
FONTDESC NOSLUG?)))
do (RETURN NEWCSINFO)) (* Just recursively call ourselves to handle entries in
DISPLAYFONTCOERCIONS)
))
((AND (EQ ROTATION 0) (* If it is available, this will force the appropriate
file to be read to fill in the charset entry)
(\READDISPLAYFONTFILE FAMILY SIZE FACE ROTATION (QUOTE DISPLAY)
CHARSET)))
(T
(* * if we get here, the font is not directly available, either it needs to be rotated, boldified, or italicised
"by hand")
(PROG (NEWFONT XFONT XLATEDFAM CSINFO)
(RETURN (COND
[(NEQ ROTATION 0)
(* to make a rotated font (even if it is bold or whatnot), recursively call fontcreate to get the unrotated font
(maybe bold, etc), then call \SFMAKEROTATEDFONT on the csinfo.)
(OR (MEMB ROTATION (QUOTE (90 270)))
(ERROR "only implemented rotations are 0, 90 and 270." ROTATION))
(COND
((SETQ XFONT (FONTCREATE FAMILY SIZE FACE 0 (QUOTE FX80)
T CHARSET))
(* actually call FONTCREATE here, rather than \CREATEDISPLAYFONT or \CREATECHARSET.DISPLAY, so that the vanilla font
that is built in this process will be cached and not repeated.)
(if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT))
then (\SFROTATECSINFO CSINFO ROTATION)
else NIL]
((AND (EQ (fetch WEIGHT of FACE)
(QUOTE BOLD))
(SETQ XFONT (FONTCREATE FAMILY SIZE (create FONTFACE
using FACE WEIGHT ←(QUOTE
MEDIUM))
0
(QUOTE FX80)
T CHARSET)))
(* if we want a bold font, and the medium weight font is available, build the medium weight version then call
\SFMAKEBOLD on the csinfo)
(if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT))
then (\SFMAKEBOLD CSINFO)
else NIL))
((AND (EQ (fetch SLOPE of FACE)
(QUOTE ITALIC))
(SETQ XFONT (FONTCREATE FAMILY SIZE (create FONTFACE
using FACE SLOPE ←(QUOTE
REGULAR))
0
(QUOTE FX80)
T CHARSET)))
(if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT))
then (\SFMAKEITALIC CSINFO)
else NIL))
((for TRANSL in MISSINGDISPLAYFONTCOERCIONS bind NEWCSINFO USER-FONT
REALFONT
when (AND (SETQ USER-FONT (CAR TRANSL))
(EQ FAMILY (CAR USER-FONT))
(OR (NOT (CADR USER-FONT))
(EQ SIZE (CADR USER-FONT)))
(OR (NOT (CADDR USER-FONT))
(EQ CHARSET (CADDR USER-FONT)))
(SETQ REALFONT (CADR TRANSL))
(SETQ NEWCSINFO (\CREATECHARSET.FX80 (OR (CAR REALFONT)
FAMILY)
(OR (CADR REALFONT)
SIZE)
FACE ROTATION DEVICE
(OR (CADDR REALFONT)
CHARSET)
FONTDESC NOSLUG?)))
do (RETURN NEWCSINFO)))
((NOT NOSLUG?)
(\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONTDESC)
(FONTPROP FONTDESC (QUOTE ASCENT))
(FONTPROP FONTDESC (QUOTE DESCENT])
(\CREATEFX80FONT
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* hdj "27-Sep-85 15:15")
(PROG [(FONTDESC (create FONTDESCRIPTOR
FONTDEVICE ←(QUOTE FX80)
FONTFAMILY ← FAMILY
FONTSIZE ← SIZE
FONTFACE ← FACE
\SFAscent ← 0
\SFDescent ← 0
\SFHeight ← 0
ROTATION ← ROTATION
FONTDEVICESPEC ←(LIST FAMILY SIZE FACE ROTATION (QUOTE FX80]
(\GETCHARSETINFO CHARSET FONTDESC T)
(RETURN FONTDESC])
(\SEARCHFX80FONTFILES
[LAMBDA (FAMILY SIZE FACE ROTATION) (* hdj "21-Jan-85 12:19")
(* * returns a list of the fonts that can be read in for the FX80 device. Rotation is ignored because it is assumed
that all devices support 0 90 and 270)
(DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES))
(SELECTQ (SYSTEMTYPE)
(J
(* OLD J code from \READDISPLAYFONT (PROG ((FONTFILE (\FONTFILENAME FAMILY SIZE FACE)) FONTDESC STRM)
(COND ((SETQ STRM (AND FONTDIRECTORIES (FINDFILE FONTFILE T FONTDIRECTORIES))) (SETQ STRM (OPENSTREAM FONTFILE
(QUOTE INPUT))) (SETQ FONTDESC (\READJERICHOFONTFILE FAMILY SIZE FACE STRM)) (CLOSEF STRM)))
(RETURN FONTDESC)))
NIL)
(D (for E FILENAMEPATTERN FONTSFOUND THISFONT inside DISPLAYFONTEXTENSIONS
do (SETQ FILENAMEPATTERN (\FONTFILENAME FAMILY SIZE FACE E))
[for DIR inside DISPLAYFONTDIRECTORIES
do (for FONTFILE in (DIRECTORY (PACKFILENAME (QUOTE DIRECTORY)
DIR
(QUOTE BODY)
FILENAMEPATTERN))
do (OR (MEMBER (SETQ THISFONT (\FONTINFOFROMFILENAME FONTFILE
(QUOTE DISPLAY)))
FONTSFOUND)
(SETQ FONTSFOUND (CONS THISFONT FONTSFOUND]
finally (RETURN FONTSFOUND)))
(SHOULDNT])
(\STRINGWIDTH.FX80
[LAMBDA (FX80STREAM STR RDTBL) (* hdj "18-Jan-85 17:34")
(* Returns the width of for the current
font/spacefactor in STREAM.)
(PROG (WIDTHSBASE)
(RETURN (\STRINGWIDTH.GENERIC STR (SETQ WIDTHSBASE (ffetch (\DISPLAYDATA DDWIDTHSCACHE)
of (ffetch IMAGEDATA of FX80STREAM)))
RDTBL
(\FGETWIDTH WIDTHSBASE (CHARCODE SPACE])
(\DRAWCIRCLE.FX80
[LAMBDA (DISPLAYSTREAM CENTERX CENTERY RADIUS BRUSH DASHING)
(* JonL " 7-May-84 02:46")
(* \DRAWCIRCLE.FX80 extended for color.
Color is specified by either BRUSH or the DSPCOLOR of
DS.)
(DECLARE (LOCALVARS . T))
(COND
((OR (NOT (NUMBERP RADIUS))
(ILESSP (SETQ RADIUS (FIXR RADIUS))
0))
(\ILLEGAL.ARG RADIUS))
((EQ RADIUS 0) (* don't draw anything.)
NIL)
(T (GLOBALRESOURCE \BRUSHBBT
(PROG ((X 0)
(Y RADIUS)
(D (ITIMES 2 (IDIFFERENCE 1 RADIUS)))
DestinationBitMap LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT
LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE
BRUSHBASE RASTERWIDTH BRUSHRASTERWIDTH NBITSRIGHTPLUS1 OPERATION
HEIGHTMINUS1 CX CY (BBT \BRUSHBBT)
COLOR COLORBRUSHBASE NBITS (DISPLAYDATA (fetch IMAGEDATA
of DISPLAYSTREAM))
(USERFN (AND (LITATOM BRUSH)
BRUSH))) (* many of these variables are used by the macro for
\CURVEPT that passes them to \BBTCURVEPT and
.SETUP.FOR.\BBTCURVEPT. sets them up.)
(COND
(USERFN (* if calling user fn, don't bother with set up and
leave points in stream coordinates.)
(SETQ CX CENTERX)
(SETQ CY CENTERY))
(T (.SETUP.FOR.\BBTCURVEPT.)
(SELECTQ NBITS
(1 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX
(FOLDLO
BRUSHWIDTH 2))
DISPLAYDATA)))
(4 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE
CENTERX
(FOLDLO (LRSH BRUSHWIDTH 2)
2))
DISPLAYDATA)))
(8 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE
CENTERX
(FOLDLO (LRSH BRUSHWIDTH 3)
2))
DISPLAYDATA)))
(SHOULDNT)) (* take into account the brush thickness.)
(SETQ CY (\DSPTRANSFORMY (IDIFFERENCE CENTERY (FOLDLO BRUSHHEIGHT
2))
DISPLAYDATA))
(* Move the window to top while interruptable, but
verify that it is still there uninterruptably with
drawing points)
(\INSURETOPWDS DISPLAYSTREAM)))
[COND
((EQ RADIUS 1) (* put a single brush down.)
(* draw the top and bottom most points.)
[COND
(USERFN (APPLY* USERFN CX CY DISPLAYSTREAM))
(T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT CX CY]
(RETURN))
(T (* draw the top and bottom most points.)
(COND
(USERFN (APPLY* USERFN CX (IPLUS CY RADIUS)
DISPLAYSTREAM)
(APPLY* USERFN CX (IDIFFERENCE CY RADIUS)
DISPLAYSTREAM))
(T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT CX (IPLUS CY RADIUS))
(\CURVEPT CX (IDIFFERENCE CY RADIUS]
LP (* (UNFOLD x 2) is used instead of
(ITIMES x 2))
[COND
[(IGREATERP 0 D)
(SETQ X (ADD1 X))
(COND
((IGREATERP (UNFOLD (IPLUS D Y)
2)
1)
(SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y)
2)
4))
(SETQ Y (SUB1 Y)))
(T (SETQ D (IPLUS D (UNFOLD X 2)
1]
((OR (EQ 0 D)
(IGREATERP X D))
(SETQ X (ADD1 X))
(SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y)
2)
4))
(SETQ Y (SUB1 Y)))
(T (SETQ D (IPLUS (IDIFFERENCE D (UNFOLD Y 2))
3))
(SETQ Y (SUB1 Y]
(COND
[(EQ Y 0) (* left most and right most points are drawn specially
so that they are not duplicated which leaves a hole in
XOR mode.)
(COND
(USERFN (APPLY* USERFN (IPLUS CX X)
CY DISPLAYSTREAM)
(APPLY* USERFN (IDIFFERENCE CX X)
CY DISPLAYSTREAM))
(T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT (IPLUS CX X)
CY)
(\CURVEPT (IDIFFERENCE CX X)
CY]
(T [COND
(USERFN (APPLY* USERFN (IPLUS CX X)
(IPLUS CY Y)
DISPLAYSTREAM)
(APPLY* USERFN (IDIFFERENCE CX X)
(IPLUS CY Y)
DISPLAYSTREAM)
(APPLY* USERFN (IPLUS CX X)
(IDIFFERENCE CY Y)
DISPLAYSTREAM)
(APPLY* USERFN (IDIFFERENCE CX X)
(IDIFFERENCE CY Y)
DISPLAYSTREAM))
(T (.WHILE.TOP.DS. DISPLAYSTREAM (\CIRCLEPTS CX CY X Y]
(GO LP)))
(MOVETO CENTERX CENTERY DISPLAYSTREAM)
(RETURN NIL])
(\DRAWCURVE.FX80
[LAMBDA (FX80STREAM KNOTS CLOSED BRUSH DASHING) (* hdj "21-Jan-85 17:48")
(* draws a spline curve with a given brush.)
(GLOBALRESOURCE \BRUSHBBT (PROG ([DASHLST (AND DASHING
(OR (AND (LISTP DASHING)
(EVERY DASHING (FUNCTION FIXP))
DASHING)
(\ILLEGAL.ARG DASHING]
(BBT \BRUSHBBT)
LKNOT)
(SELECTQ (LENGTH KNOTS)
(0 (* No knots => empty curve rather than error?)
NIL)
(1 (* only one knot, put down a brush shape)
(OR (type? POSITION (CAR KNOTS))
(ERROR "bad knot" (CAR KNOTS)))
(DRAWPOINT (fetch XCOORD of (CAR KNOTS))
(fetch YCOORD of (CAR KNOTS))
BRUSH FX80STREAM))
(2 (OR (type? POSITION (CAR KNOTS))
(ERROR "bad knot" (CAR KNOTS)))
(OR (type? POSITION (CADR KNOTS))
(ERROR "bad knot" (CADR KNOTS)))
(\LINEWITHBRUSH (fetch XCOORD of (CAR KNOTS))
(fetch YCOORD of (CAR KNOTS))
(fetch XCOORD of (CADR KNOTS))
(fetch YCOORD of (CADR KNOTS))
BRUSH DASHLST FX80STREAM BBT))
(\CURVE2 (PARAMETRICSPLINE KNOTS CLOSED)
BRUSH DASHLST BBT FX80STREAM))
(RETURN FX80STREAM])
(\DRAWELLIPSE.FX80
[LAMBDA (DISPLAYSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING)
(* JonL " 7-May-84 02:45")
(DECLARE (LOCALVARS . T))
(* Draws an ellipse. At ORIENTATION 0, the semimajor axis is horizontal, the semiminor axis vertical.
Orientation is positive in the counterclockwise direction. The current location in the stream is left at the center
of the ellipse.)
(PROG ((CENTERX (FIXR CENTERX))
(CENTERY (FIXR CENTERY))
(SEMIMINORRADIUS (FIXR SEMIMINORRADIUS))
(SEMIMAJORRADIUS (FIXR SEMIMAJORRADIUS)))
(COND
((OR (EQ 0 SEMIMINORRADIUS)
(EQ 0 SEMIMAJORRADIUS))
(MOVETO CENTERX CENTERY DISPLAYSTREAM)
(RETURN)))
(COND
((ILESSP SEMIMINORRADIUS 1)
(\ILLEGAL.ARG SEMIMINORRADIUS))
((ILESSP SEMIMAJORRADIUS 1)
(\ILLEGAL.ARG SEMIMAJORRADIUS))
((OR (NULL ORIENTATION)
(EQ SEMIMINORRADIUS SEMIMAJORRADIUS))
(SETQ ORIENTATION 0))
((NULL (NUMBERP ORIENTATION))
(\ILLEGAL.ARG ORIENTATION)))
(* This function is the implementation of the algorithm given in
"Algorithm for drawing ellipses or hyperbolae with a digital plotter" by Pitteway appearing in Computer Journal 10:
(3) Nov 1967.0 The input parameters are used to determine the ellipse equation (1/8) Ayy+ (1/8) Bxx+
(1/4) Gxy+ (1/4) Ux+ (1/4) Vy= (1/4) K which specifies a translated version of the desired ellipse.
This ellipse passes through the mesh point (0,0), the initial point of the algorithm. The power of 2 factors reflect
an implementation convenience.)
(GLOBALRESOURCE \BRUSHBBT
(PROG (DestinationBitMap LEFT RIGHTPLUS1 BOTTOM TOP BOTTOMMINUSBRUSH
TOPMINUSBRUSH LEFTMINUSBRUSH DESTINATIONBASE
BRUSHBASE BRUSHHEIGHT BRUSHWIDTH RASTERWIDTH
BRUSHRASTERWIDTH BRUSHBM OPERATION HEIGHTMINUS1
(BBT \BRUSHBBT)
(cosOrientation (COS ORIENTATION))
(sinOrientation (SIN ORIENTATION))
(SEMIMINORRADIUSSQUARED (ITIMES SEMIMINORRADIUS
SEMIMINORRADIUS))
(SEMIMAJORRADIUSSQUARED (ITIMES SEMIMAJORRADIUS
SEMIMAJORRADIUS))
(x 0)
(y 0)
(x2 1)
x1 y1 y2 k1 k2 k3 a b d w A B G U V K CX CY
yOffset CYPlusOffset CYMinusOffset NBITSRIGHTPLUS1
COLORBRUSHBASE COLOR NBITS
(DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM))
(USERFN (AND (LITATOM BRUSH)
BRUSH)))
(* many of these variables are used by the macro for
\CURVEPT that passes them to \BBTCURVEPT and
.SETUP.FOR.\BBTCURVEPT. sets them up.)
(COND
(USERFN (* if calling user fn, don't bother with set up and
leave points in window coordinates.)
(SETQ CX CENTERX)
(SETQ CY CENTERY))
(T (.SETUP.FOR.\BBTCURVEPT.)
(* take into account the brush thickness.)
(SELECTQ NBITS
(1 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX
(FOLDLO
BRUSHWIDTH 2))
DISPLAYDATA)))
(4 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE
CENTERX
(FOLDLO (LRSH BRUSHWIDTH
2)
2))
DISPLAYDATA)))
(8 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE
CENTERX
(FOLDLO (LRSH BRUSHWIDTH
3)
2))
DISPLAYDATA)))
(SHOULDNT))
(SETQ CY (\DSPTRANSFORMY (IDIFFERENCE CENTERY (FOLDLO
BRUSHHEIGHT 2))
DISPLAYDATA))
(* Move the window to top while interruptable, but
verify that it is still there uninterruptably with
drawing points)
(\INSURETOPWDS DISPLAYSTREAM)))
(SETQ A (FPLUS (FTIMES SEMIMAJORRADIUSSQUARED cosOrientation
cosOrientation)
(FTIMES SEMIMINORRADIUSSQUARED sinOrientation
sinOrientation)))
(SETQ B (LSH (FIXR (FPLUS (FTIMES SEMIMINORRADIUSSQUARED
cosOrientation cosOrientation)
(FTIMES SEMIMAJORRADIUSSQUARED
sinOrientation sinOrientation)))
3))
(SETQ G (FTIMES cosOrientation sinOrientation
(LSH (IDIFFERENCE SEMIMINORRADIUSSQUARED
SEMIMAJORRADIUSSQUARED)
1)))
[SETQ yOffset (FIXR (FQUOTIENT (ITIMES SEMIMINORRADIUS
SEMIMAJORRADIUS)
(SQRT A]
(SETQ CYPlusOffset (IPLUS CY yOffset))
(SETQ CYMinusOffset (IDIFFERENCE CY yOffset))
(SETQ U (LSH (FIXR (FTIMES A (LSH yOffset 1)))
2))
(SETQ V (LSH (FIXR (FTIMES G yOffset))
2))
(SETQ K (LSH [FIXR (FDIFFERENCE (ITIMES SEMIMINORRADIUSSQUARED
SEMIMAJORRADIUSSQUARED)
(FTIMES A (ITIMES yOffset yOffset]
2))
(SETQ A (LSH (FIXR A)
3))
(SETQ G (LSH (FIXR G)
2))
(* The algorithm is incremental and iterates through the octants of a cartesian plane. The octants are labeled from
1 through 8 beginning above the positive X axis and proceeding counterclockwise. Decisions in making the incremental
steps are determined according to the error term d which is updated according to the curvature terms a and b.
k1, k2, and k3 are used to correct the error and curvature terms at octant boundaries. The initial values of these
terms depends on the octant in which drawing begins. The initial move steps (x1,y1) and (x2,y2) also depend on the
starting octant.)
[COND
[(ILESSP (ABS U)
(ABS V))
(SETQ x1 0)
(COND
[(MINUSP V) (* start in octant 2)
(SETQ y1 1)
(SETQ y2 1)
(SETQ k1 (IMINUS A))
(SETQ k2 (IDIFFERENCE k1 G))
(SETQ k3 (IDIFFERENCE k2 (IPLUS B G)))
(SETQ b (IPLUS U (RSH (IPLUS A G)
1)))
(SETQ a (IMINUS (IPLUS b V)))
(SETQ d (IPLUS b (RSH B 3)
(RSH V 1)
(IMINUS K]
(T (* start in octant 7)
(SETQ y1 -1)
(SETQ y2 -1)
(SETQ k1 A)
(SETQ k2 (IDIFFERENCE k1 G))
(SETQ k3 (IPLUS k2 B (IMINUS G)))
(SETQ b (IPLUS U (RSH (IDIFFERENCE G A)
1)))
(SETQ a (IDIFFERENCE V b))
(SETQ d (IPLUS b K (IMINUS (IPLUS (RSH V 1)
(RSH B 3]
(T (SETQ x1 1)
(SETQ y1 0)
(COND
[(MINUSP V) (* start in octant 1)
(SETQ y2 1)
(SETQ k1 B)
(SETQ k2 (IPLUS k1 G))
(SETQ k3 (IPLUS k2 A G))
[SETQ b (IMINUS (IPLUS V (RSH (IPLUS B G)
1]
(SETQ a (IDIFFERENCE U b))
(SETQ d (IPLUS b K (IMINUS (IPLUS (RSH A 3)
(RSH U 1]
(T (* start in octant 8)
(SETQ y2 -1)
(SETQ k1 (IMINUS B))
(SETQ k2 (IPLUS k1 G))
(SETQ k3 (IPLUS k2 G (IMINUS A)))
(SETQ b (IPLUS V (RSH (IDIFFERENCE B G)
1)))
(SETQ a (IDIFFERENCE U b))
(SETQ d (IPLUS b (RSH A 3)
(IMINUS (IPLUS K (RSH U 1]
(* The ellipse equation describes an ellipse of the desired size and ORIENTATION centered at
(0,0) and then dropped yOffset mesh points so that it will pass through (0,0). Thus, the intended starting point is
(CX, CY+yOffset) where (CX, CY) is the center of the desired ellipse. Drawing is accomplished with point relative
steps. In each octant, the error term d is used to choose between move 1 (an axis move) and move 2
(a diagonal move).)
MOVE[COND
((MINUSP d) (* move 1)
(SETQ x (IPLUS x x1))
(SETQ y (IPLUS y y1))
(SETQ b (IDIFFERENCE b k1))
(SETQ a (IPLUS a k2))
(SETQ d (IPLUS b d)))
(T (* move 2)
(SETQ x (IPLUS x x2))
(SETQ y (IPLUS y y2))
(SETQ b (IDIFFERENCE b k2))
(SETQ a (IPLUS a k3))
(SETQ d (IDIFFERENCE d a]
(COND
((MINUSP x)
(MOVETO CENTERX CENTERY DISPLAYSTREAM)
(RETURN NIL)))
[COND
(USERFN (APPLY* USERFN (IPLUS CX x)
(IPLUS CYPlusOffset y)
DISPLAYSTREAM)
(APPLY* USERFN (IDIFFERENCE CX x)
(IDIFFERENCE CYMinusOffset y)
DISPLAYSTREAM))
(T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT (IPLUS CX x)
(IPLUS CYPlusOffset y))
(\CURVEPT (IDIFFERENCE CX x)
(IDIFFERENCE CYMinusOffset y]
(AND (MINUSP b)
(GO SQUARE))
DIAGONAL
(OR (MINUSP a)
(GO MOVE)) (* diagonal octant change)
(SETQ x1 (IDIFFERENCE x2 x1))
(SETQ y1 (IDIFFERENCE y2 y1))
(SETQ w (IDIFFERENCE (LSH k2 1)
k3))
(SETQ k1 (IDIFFERENCE w k1))
(SETQ k2 (IDIFFERENCE k2 k3))
(SETQ k3 (IMINUS k3))
[SETQ b (IPLUS b a (IMINUS (RSH (ADD1 k2)
1]
[SETQ d (IPLUS b (RSH (IPLUS k3 4)
3)
(IMINUS d)
(IMINUS (RSH (ADD1 a)
1]
(SETQ a (IDIFFERENCE (RSH (ADD1 w)
1)
a))
(OR (MINUSP b)
(GO MOVE))
SQUARE (* square octant change)
[COND
((EQ 0 x1)
(SETQ x2 (IMINUS x2)))
(T (SETQ y2 (IMINUS y2]
(SETQ w (IDIFFERENCE k2 k1))
(SETQ k1 (IMINUS k1))
(SETQ k2 (IPLUS w k1))
(SETQ k3 (IDIFFERENCE (LSH w 2)
k3))
(SETQ b (IDIFFERENCE (IMINUS b)
w))
(SETQ d (IDIFFERENCE (IDIFFERENCE b a)
d))
(SETQ a (IDIFFERENCE (IDIFFERENCE a w)
(LSH b 1)))
(GO DIAGONAL])
(\DRAWLINE.FX80
[LAMBDA (FX80STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR) (* hdj "21-Jan-85 17:45")
(* FX80STREAM is guaranteed to be a display-stream.
Draws a line from x1,y1 to x2,y2 leaving the position
at x2,y2)
(PROG ((DD (fetch IMAGEDATA of FX80STREAM)))
(\CLIPANDDRAWLINE (\DSPTRANSFORMX (OR (FIXP X1)
(FIXR X1))
DD)
(\DSPTRANSFORMY (OR (FIXP Y1)
(FIXR Y1))
DD)
(\DSPTRANSFORMX (OR (FIXP X2)
(FIXR X2))
DD)
(\DSPTRANSFORMY (OR (FIXP Y2)
(FIXR Y2))
DD)
[COND
((NULL WIDTH)
1)
((OR (FIXP WIDTH)
(FIXR WIDTH]
(SELECTQ OPERATION
(NIL (ffetch DDOPERATION of DD))
((REPLACE PAINT INVERT ERASE)
OPERATION)
(\ILLEGAL.ARG OPERATION))
(ffetch DDDestination of DD)
(ffetch DDClippingLeft of DD)
(SUB1 (ffetch DDClippingRight of DD))
(ffetch DDClippingBottom of DD)
(SUB1 (ffetch DDClippingTop of DD))
FX80STREAM COLOR)) (* the generic case of MOVETO is used so that the
hardcopy streams get handled as well.)
(MOVETO X2 Y2 FX80STREAM])
(\DSPCLIPPINGREGION.FX80
(LAMBDA (FX80STREAM REGION) (* ejs: "29-Aug-85 23:43")
(* sets the clipping region of a display stream.)
(PROG ((DD (\GETDISPLAYDATA FX80STREAM)))
(RETURN (PROG1 (ffetch DDClippingRegion of DD)
(COND
(REGION (OR (type? REGION REGION)
(ERROR REGION " is not a REGION."))
(UNINTERRUPTABLY
(freplace DDClippingRegion of DD with REGION)
(\SFFixClippingRegion DD)
(\INVALIDATEDISPLAYCACHE DD)))))))))
(\DSPFONT.FX80
[LAMBDA (FX80STREAM FONT) (* hdj "18-Jan-85 17:37")
(* sets the font that a display stream uses to print
characters. FX80STREAM is guaranteed to be a stream of
type FX80)
(PROG (XFONT OLDFONT (DD (fetch IMAGEDATA of FX80STREAM)))
(* save old value to return, smash new value and update
the bitchar portion of the record.)
(RETURN (PROG1 (SETQ OLDFONT (fetch DDFONT of DD))
(COND
(FONT (SETQ XFONT (OR (\GETFONTDESC FONT (QUOTE FX80)
T)
(FONTCOPY (ffetch DDFONT of DD)
FONT)))
(* updating font information is fairly expensive
operation. Don't bother unless font has changed.)
(OR (EQ XFONT OLDFONT)
(UNINTERRUPTABLY
(freplace DDFONT of DD with XFONT)
(freplace DDLINEFEED of DD
with (IMINUS (fetch \SFHeight of XFONT)))
(\SFFixFont FX80STREAM DD))])
(\DSPLEFTMARGIN.FX80
[LAMBDA (FX80STREAM XPOSITION) (* hdj "21-Jan-85 17:34")
(* sets the xposition that a carriage return returns
to.)
(PROG ((DD (fetch IMAGEDATA of FX80STREAM)))
(RETURN (PROG1 (ffetch DDLeftMargin of DD)
(AND XPOSITION (COND
((AND (SMALLP XPOSITION)
(IGREATERP XPOSITION -1))
(UNINTERRUPTABLY
(freplace DDLeftMargin of DD with XPOSITION)
(\SFFIXLINELENGTH FX80STREAM)))
(T (\ILLEGAL.ARG XPOSITION])
(\DSPLINEFEED.FX80
[LAMBDA (FX80STREAM DELTAY) (* hdj "18-Jan-85 17:30")
(* sets the amount that a line feed increases the y
coordinate by.)
(PROG ((DD (fetch IMAGEDATA of FX80STREAM)))
(RETURN (PROG1 (ffetch DDLINEFEED of DD)
(AND DELTAY (COND
((NUMBERP DELTAY)
(freplace DDLINEFEED of DD with DELTAY))
(T (\ILLEGAL.ARG DELTAY])
(\DSPOPERATION.FX80
[LAMBDA (FX80STREAM OPERATION) (* hdj "18-Jan-85 17:31")
(* sets the operation field of a display stream)
(PROG ((DD (\GETDISPLAYDATA FX80STREAM)))
(RETURN (PROG1 (fetch DDOPERATION of DD)
(COND
(OPERATION (OR (FMEMB OPERATION (QUOTE (PAINT REPLACE INVERT ERASE)))
(LISPERROR "ILLEGAL ARG" OPERATION))
(UNINTERRUPTABLY
(freplace DDOPERATION of DD with OPERATION)
(* update other fields that depend on operation.)
(\SETPBTFUNCTION (fetch DDPILOTBBT of DD)
(fetch DDSOURCETYPE of DD)
OPERATION))])
(\DSPPRINTCHAR.FX80
[LAMBDA (STREAM CHARCODE) (* hdj " 8-Feb-85 17:42")
(* Displays the character and increments the Xposition.
STREAM is guaranteed to be of type display.)
(PROG ((DD (fetch IMAGEDATA of STREAM)))
(SELCHARQ CHARCODE
((EOL CR LF)
(\DSPPRINTCR/LF.FX80 CHARCODE STREAM)
(replace CHARPOSITION of STREAM with 0))
(LF (\DSPPRINTCR/LF.FX80 CHARCODE STREAM))
[TAB (PROG (TABWIDTH (SPACEWIDTH (CHARWIDTH (CHARCODE SPACE)
STREAM)))
(SETQ TABWIDTH (UNFOLD SPACEWIDTH 8))
(if (IGREATERP (\DISPLAYSTREAMINCRXPOSITION
(SETQ TABWIDTH
(IDIFFERENCE TABWIDTH
(MOD (IDIFFERENCE (fetch DDXPOSITION
of DD)
(ffetch DDLeftMargin
of DD))
TABWIDTH)))
DD)
(ffetch DDRightMargin of DD))
then (* tab was past rightmargin, force cr.)
(\DSPPRINTCR/LF.FX80 (CHARCODE EOL)
STREAM))
(* return the number of spaces taken.)
(add (fetch CHARPOSITION of STREAM)
(IQUOTIENT TABWIDTH SPACEWIDTH]
(add (fetch CHARPOSITION of STREAM)
(IPLUS (if (ILESSP CHARCODE 32)
then (* CONTROL character)
(\BLTCHAR.FX80 CHARCODE STREAM DD)
0
else (\BLTCHAR.FX80 CHARCODE STREAM DD)
1])
(\DSPPRINTCR/LF.FX80
[LAMBDA (CHARCODE DS) (* hdj "18-Jan-85 19:52")
(* CHARCODE is EOL, CR, or LF Assumes that DS has been
checked by \DSPPRINTCHAR)
(* changed to call DSPXPOSITION and DSPYPOSITION instead of \DSPxPOSITION.DISPLAY so that it could be used in the
hardcopy display stream case as well. Could go back to other method if efficiency becomes an issue.)
(PROG (BTM AMOUNT/BELOW Y ROTATION FONT (DD (fetch IMAGEDATA of DS)))
(COND
((AND (fetch DDSlowPrintingCase of DD)
(NEQ (SETQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of (fetch DDFONT of DD)))
0))
(PROG ((CLIPREG (ffetch DDClippingRegion of DD))
X)
(COND
((EQ CHARCODE (CHARCODE EOL)) (* on LF, no change in X)
(COND
((SETQ Y (fetch DDEOLFN of DD)) (* call the eol function for ds.)
(APPLY* Y DS)))
(DSPYPOSITION (SELECTQ ROTATION
(90 (fetch (REGION BOTTOM) of CLIPREG))
(270 (fetch (REGION TOP) of CLIPREG))
(ERROR "Only rotations supported are 0, 90 and 270"))
DS)))
[SETQ X (IPLUS (fetch DDXPOSITION of DD)
(SELECTQ ROTATION
(90 (IMINUS (ffetch DDLINEFEED of DD)))
(270 (ffetch DDLINEFEED of DD))
(ERROR "Only rotations supported are 0, 90 and 270"]
[COND
((AND (fetch DDScroll of DD)
(SELECTQ ROTATION
(90 (IGREATERP [SETQ AMOUNT/BELOW
(IDIFFERENCE (\DSPTRANSFORMX X DD)
(IDIFFERENCE (fetch
DDClippingRight
of DD)
(fetch \SFDescent
of (fetch DDFONT
of DD]
0))
(270 (IGREATERP (SETQ AMOUNT/BELOW
(IDIFFERENCE (IPLUS (fetch DDClippingLeft
of DD)
(fetch \SFDescent
of (fetch DDFONT
of DD)))
(\DSPTRANSFORMX X DD)))
0))
(SHOULDNT)))
(* automatically scroll up enough to make the entire next character visible. Descent check is so that the bottoms of
characters will be printed also.)
[PROG ((LFT (fetch DDClippingLeft of DD))
WDTH BKGRND (DBITMAP (fetch DDDestination of DD))
HGHT KEPTWIDTH)
(SETQ BTM (fetch DDClippingBottom of DD))
(SETQ HGHT (IDIFFERENCE (ffetch DDClippingTop of DD)
BTM))
(SETQ WDTH (IDIFFERENCE (fetch DDClippingRight of DD)
LFT))
[SETQ BKGRND (COND
((NEQ (fetch (BITMAP BITMAPBITSPERPIXEL) of DBITMAP)
1) (* this is a color case.)
(DSPBACKCOLOR NIL DS))
(T (ffetch DDTexture of DD]
(.WHILE.TOP.DS. DS
(COND
((IGREATERP AMOUNT/BELOW WDTH)
(* scrolling more than the window size, use different
method.)
(* clear the window with background.)
(BITBLT NIL 0 0 DBITMAP LFT BTM WDTH HGHT
(QUOTE TEXTURE)
(QUOTE REPLACE)
BKGRND))
((EQ ROTATION 90)
(BITBLT DBITMAP (IPLUS LFT AMOUNT/BELOW)
BTM DBITMAP LFT BTM (SETQ KEPTWIDTH
(IDIFFERENCE WDTH AMOUNT/BELOW))
HGHT
(QUOTE INPUT)
(QUOTE REPLACE))
(BITBLT NIL 0 0 DBITMAP (IPLUS LFT KEPTWIDTH)
BTM AMOUNT/BELOW HGHT (QUOTE TEXTURE)
(QUOTE REPLACE)
BKGRND))
(T (BITBLT DBITMAP LFT BTM DBITMAP (IPLUS LFT
AMOUNT/BELOW)
BTM
(IDIFFERENCE WDTH AMOUNT/BELOW)
HGHT
(QUOTE INPUT)
(QUOTE REPLACE))
(BITBLT NIL 0 0 DBITMAP LFT BTM AMOUNT/BELOW HGHT
(QUOTE TEXTURE)
(QUOTE REPLACE)
BKGRND]
(SETQ X (SELECTQ ROTATION
(90 (IDIFFERENCE X AMOUNT/BELOW))
(IPLUS X AMOUNT/BELOW]
(DSPXPOSITION X DS)))
(T (COND
((EQ CHARCODE (CHARCODE EOL)) (* on LF, no change in X)
(COND
((SETQ Y (fetch DDEOLFN of DD)) (* call the eol function for ds.)
(APPLY* Y DS)))
(DSPXPOSITION (ffetch DDLeftMargin of DD)
DS)))
(SETQ Y (IPLUS (ffetch DDYPOSITION of DD)
(ffetch DDLINEFEED of DD)))
[COND
((AND (fetch DDScroll of DD)
(IGREATERP (SETQ AMOUNT/BELOW (IDIFFERENCE (IPLUS (SETQ BTM
(fetch DDClippingBottom
of DD))
(fetch \SFDescent
of (fetch DDFONT
of DD)))
(\DSPTRANSFORMY Y DD)))
0))
(* automatically scroll up enough to make the entire next character visible. Descent check is so that the bottoms of
characters will be printed also.)
[PROG ((LFT (fetch DDClippingLeft of DD))
WDTH BKGRND (DBITMAP (fetch DDDestination of DD))
(HGHT (IDIFFERENCE (ffetch DDClippingTop of DD)
BTM)))
(SETQ WDTH (IDIFFERENCE (fetch DDClippingRight of DD)
LFT))
[SETQ BKGRND (COND
((NEQ (fetch (BITMAP BITMAPBITSPERPIXEL) of DBITMAP)
1) (* this is a color case.)
(DSPBACKCOLOR NIL DS))
(T (ffetch DDTexture of DD]
(.WHILE.TOP.DS. DS (COND
((IGREATERP AMOUNT/BELOW HGHT)
(* scrolling more than the window size, use different
method.)
(* clear the window with background.)
(BITBLT NIL 0 0 DBITMAP LFT BTM WDTH HGHT (QUOTE TEXTURE)
(QUOTE REPLACE)
BKGRND))
(T (BITBLT DBITMAP LFT BTM DBITMAP LFT (IPLUS BTM
AMOUNT/BELOW)
WDTH
(IDIFFERENCE HGHT AMOUNT/BELOW)
(QUOTE INPUT)
(QUOTE REPLACE))
(BITBLT NIL 0 0 DBITMAP LFT BTM WDTH AMOUNT/BELOW
(QUOTE TEXTURE)
(QUOTE REPLACE)
BKGRND]
(SETQ Y (IPLUS Y AMOUNT/BELOW]
(DSPYPOSITION Y DS])
(\DSPRESET.FX80
[LAMBDA (FX80STREAM) (* hdj "18-Jan-85 17:33")
(DECLARE (GLOBALVARS \CURRENTDISPLAYLINE)) (* resets a display stream)
(PROG (CREG FONT FONTASCENT (DD (\GETDISPLAYDATA FX80STREAM)))
(SETQ CREG (ffetch DDClippingRegion of DD))
(SETQ FONT (fetch DDFONT of DD))
(SETQ FONTASCENT (FONTASCENT FONT))
(SELECTQ (fetch (FONTDESCRIPTOR ROTATION) of FONT)
[0 (\DSPXPOSITION.FX80 FX80STREAM (ffetch DDLeftMargin of DD))
(\DSPYPOSITION.FX80 FX80STREAM (ADD1 (IDIFFERENCE (fetch TOP of CREG)
FONTASCENT]
(90 (\DSPXPOSITION.FX80 FX80STREAM (IPLUS (fetch LEFT of CREG)
FONTASCENT))
(\DSPYPOSITION.FX80 FX80STREAM (fetch BOTTOM of CREG)))
(270 (\DSPXPOSITION.FX80 FX80STREAM (IDIFFERENCE (fetch RIGHT of CREG)
FONTASCENT))
(\DSPYPOSITION.FX80 FX80STREAM (fetch TOP of CREG)))
(ERROR "only supported rotations are 0, 90 and 270"))
(BITBLT NIL NIL NIL FX80STREAM (fetch LEFT of CREG)
(fetch BOTTOM of CREG)
(fetch WIDTH of CREG)
(fetch HEIGHT of CREG)
(QUOTE TEXTURE)
(QUOTE REPLACE)
(ffetch DDTexture of DD])
(\DSPRIGHTMARGIN.FX80
[LAMBDA (FX80STREAM XPOSITION) (* hdj "21-Jan-85 17:35")
(* Sets the right margin that determines when a cr is
inserted by print.)
(PROG (OLDRM (DD (fetch IMAGEDATA of FX80STREAM)))
(SETQ OLDRM (ffetch DDRightMargin of DD))
(COND
((NULL XPOSITION))
[(AND (SMALLP XPOSITION)
(IGREATERP XPOSITION -1)) (* Avoid fixing linelength if right margin hasn't
changed.)
(OR (EQ XPOSITION OLDRM)
(UNINTERRUPTABLY
(freplace DDRightMargin of DD with XPOSITION)
(\SFFIXLINELENGTH FX80STREAM))]
(T (\ILLEGAL.ARG XPOSITION)))
(RETURN OLDRM])
(\DSPXPOSITION.FX80
[LAMBDA (FX80STREAM XPOSITION) (* hdj "18-Jan-85 18:24")
(* coordinate position is stored in 15 bits in the
range -2↑15 to +2↑15.)
(PROG ((DD (fetch IMAGEDATA of FX80STREAM)))
(RETURN (PROG1 (fetch DDXPOSITION of DD)
(COND
((NULL XPOSITION))
((NUMBERP XPOSITION)
(freplace DDXPOSITION of DD with XPOSITION)
(* reset the charposition field so that PRINT etc.
won't put out eols.)
(freplace (STREAM CHARPOSITION) of FX80STREAM with 0))
(T (\ILLEGAL.ARG XPOSITION])
(\DSPYPOSITION.FX80
(LAMBDA (DISPLAYSTREAM YPOSITION) (* ejs: "29-Aug-85 23:43")
(LET ((DD (fetch IMAGEDATA of DISPLAYSTREAM)))
(PROG1 (ffetch DDYPOSITION of DD)
(COND
((NULL YPOSITION))
((NUMBERP YPOSITION)
(UNINTERRUPTABLY
(freplace DDYPOSITION of DD with YPOSITION)
(\INVALIDATEDISPLAYCACHE DD)))
(T (\ILLEGAL.ARG YPOSITION)))))))
(\DUMPPAGEBUFFER.FX80
[LAMBDA (BITMAP FX80STREAM) (* edited: "24-Apr-85 21:53")
(PROG ((WIDTH (BITMAPWIDTH BITMAP))
(WIDTHSUB1 (SUB1 (BITMAPWIDTH BITMAP)))
(HEIGHT (BITMAPHEIGHT BITMAP))
(HEIGHTSUB1 (SUB1 (BITMAPHEIGHT BITMAP)))
(SUBSTREAM (fetch (STREAM F1) of FX80STREAM))
CodedBitColumn)
(\FX80.PRINTERMODE (QUOTE UniDirectionalOn)
SUBSTREAM)
(\FX80.PRINTERMODE (QUOTE EightSpacingOn)
SUBSTREAM)
(* * pack the bitmap into FX80 format)
(for TopOfColumn from HEIGHTSUB1 to 0 by -8 bind BottomOfColumn
do (SETQ BottomOfColumn (IDIFFERENCE TopOfColumn 7))
(* (GRAPHICS.MODE WIDTH))
(\FX80.GRAPHICSMODE WIDTH SUBSTREAM)
(for Column from 0 to WIDTHSUB1
do (SETQ CodedBitColumn 0)
[for BitNumber from TopOfColumn to BottomOfColumn by -1
do (SETQ CodedBitColumn (LOGOR CodedBitColumn
(LLSH (BITMAPBIT BITMAP Column BitNumber)
(IDIFFERENCE 7 (IDIFFERENCE TopOfColumn
BitNumber]
(BOUT SUBSTREAM CodedBitColumn))
(* * Output CR and LF to get to beginning of next line.)
(BOUT SUBSTREAM (CHARCODE CR))
(BOUT SUBSTREAM (CHARCODE LF)))
(\FX80.PRINTERMODE (QUOTE UniDirectionalOff)
SUBSTREAM])
(\FILLCIRCLE.FX80
[LAMBDA (FX80STREAM CENTERX CENTERY RADIUS TEXTURE) (* hdj "21-Jan-85 17:58")
(COND
((OR (NOT (NUMBERP RADIUS))
(ILESSP (SETQ RADIUS (FIXR RADIUS))
0))
(\ILLEGAL.ARG RADIUS))
(T (GLOBALRESOURCE \BRUSHBBT
(PROG (TOP BOTTOM RIGHT LEFT OPERATION DestinationBitMap
(DISPLAYDATA (fetch IMAGEDATA of FX80STREAM))
(X 0)
(Y RADIUS)
(D (ITIMES 2 (IDIFFERENCE 1 RADIUS)))
DESTINATIONBASE RASTERWIDTH CX CY TEXTUREBM GRAYHEIGHT GRAYWIDTH
GRAYBASE NBITS (FCBBT \BRUSHBBT))
(SETQ TOP (SUB1 (fetch DDClippingTop of DISPLAYDATA)))
(SETQ BOTTOM (fetch DDClippingBottom of DISPLAYDATA))
(SETQ LEFT (fetch DDClippingLeft of DISPLAYDATA))
(SETQ RIGHT (SUB1 (fetch DDClippingRight of DISPLAYDATA)))
(SETQ OPERATION (ffetch DDOPERATION of DISPLAYDATA))
(SETQ DestinationBitMap (fetch DDDestination of DISPLAYDATA))
(SETQ NBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DestinationBitMap))
[SETQ TEXTUREBM
(COND
((BITMAPP TEXTURE))
[(AND (NEQ NBITS 1)
(BITMAPP (COLORTEXTUREFROMCOLOR# (COLORNUMBERP
(OR TEXTURE
(DSPCOLOR NIL
FX80STREAM]
[(AND (NULL TEXTURE)
(BITMAPP (ffetch DDTexture of DISPLAYDATA]
([OR (FIXP TEXTURE)
(AND (NULL TEXTURE)
(SETQ TEXTURE (ffetch DDTexture of DISPLAYDATA]
(* create bitmap for the texture.
Could reuse a bitmap but for now this is good enough.)
(SETQ TEXTUREBM (BITMAPCREATE 16 4))
(SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBM))
(\PUTBASE GRAYBASE 0 (\SFReplicate (LOGAND (LRSH TEXTURE 12)
15)))
(\PUTBASE GRAYBASE 1 (\SFReplicate (LOGAND (LRSH TEXTURE 8)
15)))
(\PUTBASE GRAYBASE 2 (\SFReplicate (LOGAND (LRSH TEXTURE 4)
15)))
(\PUTBASE GRAYBASE 3 (\SFReplicate (LOGAND TEXTURE 15)))
TEXTUREBM)
(T (\ILLEGAL.ARG TEXTURE]
(SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBM))
(SETQ DESTINATIONBASE (fetch BITMAPBASE of DestinationBitMap))
(SETQ RASTERWIDTH (fetch BITMAPRASTERWIDTH of DestinationBitMap))
(* update as many fields in the brush bitblt table as
possible from DS.)
(replace PBTFLAGS of FCBBT with 0)
(replace PBTDESTBPL of FCBBT with (UNFOLD RASTERWIDTH BITSPERWORD))
(* clear gray information. PBTSOURCEBPL is used for
gray information too.)
(replace PBTSOURCEBPL of FCBBT with 0)
(replace PBTUSEGRAY of FCBBT with T)
[replace PBTGRAYWIDTHLESSONE of FCBBT
with (SUB1 (SETQ GRAYWIDTH (IMIN (fetch (BITMAP BITMAPWIDTH)
of TEXTUREBM)
16]
[replace PBTGRAYHEIGHTLESSONE of FCBBT
with (SUB1 (SETQ GRAYHEIGHT (IMIN (fetch (BITMAP BITMAPHEIGHT)
of TEXTUREBM)
16]
(replace PBTDISJOINT of FCBBT with T)
(\SETPBTFUNCTION FCBBT (QUOTE TEXTURE)
OPERATION)
(replace PBTHEIGHT of FCBBT with 1)
(* take into account the brush thickness.)
(SETQ CX (\DSPTRANSFORMX CENTERX DISPLAYDATA))
(SETQ CY (\DSPTRANSFORMY CENTERY DISPLAYDATA))
(* change Y TOP and BOTTOM to be in bitmap coordinates)
(SETQ CY (\SFInvert DestinationBitMap CY))
[SETQ BOTTOM (PROG1 (SUB1 (\SFInvert DestinationBitMap TOP))
(SETQ TOP (SUB1 (\SFInvert DestinationBitMap
BOTTOM]
(\INSURETOPWDS FX80STREAM) (* Move the window to top while interruptable, but
verify that it is still there uninterruptably with
drawing points)
(COND
((EQ RADIUS 0) (* put a single point down. Use \LINEBLT to get proper
texture. NIL)
(.WHILE.TOP.DS. FX80STREAM
(\LINEBLT FCBBT CX CY CX DESTINATIONBASE
RASTERWIDTH LEFT RIGHT BOTTOM TOP
GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS))
(RETURN)))
LP (* (UNFOLD x 2) is used instead of
(ITIMES x 2))
[COND
[(IGREATERP 0 D)
(SETQ X (ADD1 X))
(COND
((IGREATERP (UNFOLD (IPLUS D Y)
2)
1)
(SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y)
2)
4)))
(T (SETQ D (IPLUS D (UNFOLD X 2)
1)) (* don't draw unless Y changes.)
(GO LP]
((OR (EQ 0 D)
(IGREATERP X D))
(SETQ X (ADD1 X))
(SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y)
2)
4)))
(T (SETQ D (IPLUS (IDIFFERENCE D (UNFOLD Y 2))
3]
(COND
((EQ Y 0) (* draw the middle line differently to avoid
duplication.)
(.WHILE.TOP.DS. FX80STREAM (\LINEBLT FCBBT (IDIFFERENCE CX X)
CY
(IPLUS CX X)
DESTINATIONBASE RASTERWIDTH
LEFT RIGHT BOTTOM TOP
GRAYWIDTH GRAYHEIGHT GRAYBASE
NBITS)))
(T (.WHILE.TOP.DS. FX80STREAM (\FILLCIRCLEBLT CX CY X Y))
(SETQ Y (SUB1 Y))
(GO LP)))
(MOVETO CENTERX CENTERY FX80STREAM)
(RETURN NIL])
(\FX80.CRLF
[LAMBDA (STREAM) (* hdj "25-Jan-85 17:11")
(* Send a CRLF to the printer)
(BOUT STREAM (CHARCODE CR))
(BOUT STREAM (CHARCODE LF])
(\FX80.GRAPHICSMODE
[LAMBDA (ROWS STREAM) (* hdj "28-Jan-85 17:12")
(* * "put the fx80 in graphics mode")
(* 72 spot per inch printing mode = "ESC 5")
(BOUT STREAM (CHARCODE ESC))
(BOUT STREAM (CHARCODE *))
(BOUT STREAM 5)
(BOUT STREAM (IREMAINDER ROWS 256))
(BOUT STREAM (FOLDLO ROWS 256])
(\FX80.PRINTERCOMMAND
[LAMBDA (CommandString STREAM) (* hdj "28-Jan-85 15:49")
(* * Send an Escape, to tell the printer there is to be a mode change, and then the specific mode change)
(BOUT STREAM (CHARCODE ESC))
(for CHAR instring CommandString do (BOUT STREAM CHAR])
(\FX80.PRINTERMODE
[LAMBDA (Mode STREAM) (* hdj "28-Jan-85 18:46")
(* put the fx80 in some mode)
(SELECTQ Mode
(BoldOn (\FX80.PRINTERCOMMAND "E" STREAM))
(BoldOff (\FX80.PRINTERCOMMAND "F" STREAM))
(CompressedOn (\FX80.PRINTERCOMMAND (CHARACTER 15)
STREAM))
(CompressedOff (BOUT STREAM 18))
(EliteOn (\FX80.PRINTERCOMMAND "M" STREAM))
(EliteOff (\FX80.PRINTERCOMMAND "P" STREAM))
(ItalicOn (\FX80.PRINTERCOMMAND "4" STREAM))
(ItalicOff (\FX80.PRINTERCOMMAND "5" STREAM))
(PicaOn (\FX80.PRINTERCOMMAND (CONCAT "P" (CHARACTER 18))
STREAM))
(SubScriptOn (\FX80.PRINTERCOMMAND "S0" STREAM))
(ScriptOff (\FX80.PRINTERCOMMAND "T" STREAM))
(SuperScriptOn (\FX80.PRINTERCOMMAND "S1" STREAM))
(ExpandOn (\FX80.PRINTERCOMMAND "W1" STREAM))
(ExpandOff (\FX80.PRINTERCOMMAND "W0" STREAM))
(ProportionalOn (\FX80.PRINTERCOMMAND "p1" STREAM))
(ProportionalOff (\FX80.PRINTERCOMMAND "p0" STREAM))
(UniDirectionalOn (\FX80.PRINTERCOMMAND "U1" STREAM))
(UniDirectionalOff (\FX80.PRINTERCOMMAND "U0" STREAM))
(SevenSpacingOn (\FX80.PRINTERCOMMAND "1" STREAM))
(EightSpacingOn (\FX80.PRINTERCOMMAND (CONCAT "A" (CHARACTER 8))
STREAM))
(NineSpacingOn (\FX80.PRINTERCOMMAND "0" STREAM))
(TwelveSpacingOn (\FX80.PRINTERCOMMAND "2" STREAM))
NIL])
(\FX80INIT
[LAMBDA NIL (* hdj "27-Sep-85 15:23")
(* Initializes global variables for the FX80)
(DECLARE (GLOBALVARS \FX80IMAGEOPS))
(SETQ \FX80IMAGEOPS (create IMAGEOPS
IMAGETYPE ←(QUOTE FX80)
IMFONT ←(FUNCTION \DSPFONT.FX80)
IMLEFTMARGIN ←(FUNCTION \DSPLEFTMARGIN.FX80)
IMRIGHTMARGIN ←(FUNCTION \DSPRIGHTMARGIN.FX80)
IMLINEFEED ←(FUNCTION \DSPLINEFEED.FX80)
IMXPOSITION ←(FUNCTION \DSPXPOSITION.FX80)
IMYPOSITION ←(FUNCTION \DSPYPOSITION.FX80)
IMCLOSEFN ←(FUNCTION \CLOSEFN.FX80)
IMDRAWCURVE ←(FUNCTION \DRAWCURVE.FX80)
IMFILLCIRCLE ←(QUOTE \FILLCIRCLE.FX80)
IMDRAWLINE ←(FUNCTION \DRAWLINE.FX80)
IMDRAWELLIPSE ←(FUNCTION \DRAWELLIPSE.FX80)
IMDRAWCIRCLE ←(FUNCTION \DRAWCIRCLE.FX80)
IMBITBLT ←(FUNCTION \BITBLT.FX80)
IMBLTSHADE ←(FUNCTION \BLTSHADE.FX80)
IMNEWPAGE ←(FUNCTION NEWPAGE.FX80)
IMSCALE ←(FUNCTION [LAMBDA NIL 1])
IMSPACEFACTOR ←(FUNCTION NILL)
IMFONTCREATE ←(QUOTE FX80)
IMCOLOR ←(FUNCTION NILL)
IMBACKCOLOR ←(FUNCTION NILL)
IMOPERATION ←(FUNCTION \DSPOPERATION.FX80)
IMSTRINGWIDTH ←(FUNCTION \STRINGWIDTH.FX80)
IMCHARWIDTH ←(FUNCTION \CHARWIDTH.FX80)
IMCLIPPINGREGION ←(FUNCTION \DSPCLIPPINGREGION.FX80)
IMRESET ←(FUNCTION \DSPRESET.FX80)))
[push IMAGESTREAMTYPES (LIST (QUOTE FX80)
(LIST (QUOTE OPENSTREAM)
(FUNCTION OPENFX80STREAM))
(LIST (QUOTE FONTCREATE)
(FUNCTION \CREATEFX80FONT))
(LIST (QUOTE CREATECHARSET)
(FUNCTION \CREATECHARSET.FX80))
(LIST (QUOTE FONTSAVAILABLE)
(FUNCTION \SEARCHFX80FONTFILES]
(push PRINTERTYPES (LIST (LIST (QUOTE FX80)
(QUOTE EPSON))
(LIST (QUOTE CANPRINT)
(LIST (QUOTE TEXT)
(QUOTE BITMAP)
(QUOTE WINDOW)))
(LIST (QUOTE STATUS)
(FUNCTION TRUE))
(LIST (QUOTE PROPERTIES)
(FUNCTION NILL))
(LIST (QUOTE SEND)
(FUNCTION FXPRINT))
(LIST (QUOTE BITMAPSCALE)
NIL)
(LIST (QUOTE BITMAPFILE)
NIL)))
[push PRINTFILETYPES (LIST (QUOTE FX80)
(LIST (QUOTE TEST)
(FUNCTION NILL))
(LIST (QUOTE EXTENSION)
(LIST (QUOTE FX80)
(QUOTE EPSON]
(DEFAULTFONT (QUOTE FX80)
(QUOTE (GACHA 10 MRR))
(QUOTE NEW))
T])
(\OUTCHARFN.FX80
[LAMBDA (FX80STREAM CHARCODE) (* hdj " 3-Oct-85 15:58")
(*
"Handle all the special-purpose characters going to an FX-80 file")
(SELCHARQ CHARCODE
(EOL (* New Line)
(NEWLINE.FX80 FX80STREAM)
(replace (STREAM CHARPOSITION) of FX80STREAM with 0))
[LF (* Line feed--move down, but not over)
(\DSPXPOSITION.FX80 FX80STREAM (PROG1 (DSPXPOSITION NIL FX80STREAM)
(NEWLINE.FX80 FX80STREAM]
(↑L (* Form Feed)
(replace (STREAM CHARPOSITION) of FX80STREAM with 0)
(NEWPAGE.FX80 FX80STREAM))
(PROG ((FX80DATA (fetch IMAGEDATA of FX80STREAM))
NEWXPOS CLIPPINGREGION XPOS)
(if (NEQ (ffetch DDCHARSET of FX80DATA)
(\CHARSET CHARCODE))
then (\CHANGECHARSET.FX80 FX80DATA (\CHARSET CHARCODE)))
(SETQ XPOS (fetch DDXPOSITION of FX80DATA))
(SETQ NEWXPOS (IPLUS XPOS (\FGETWIDTH (fetch DDWIDTHSCACHE of FX80DATA)
CHARCODE)))
(COND
((AND [IGEQ XPOS (fetch LEFT of (SETQ CLIPPINGREGION
(fetch DDClippingRegion
of FX80DATA]
(ILEQ NEWXPOS (fetch RIGHT of CLIPPINGREGION))
(IGEQ (fetch DDYPOSITION of FX80DATA)
(fetch BOTTOM of CLIPPINGREGION)))
(* Bottom test should really subtract off the descent,
and also should do a top-test)
(* The Y-tests can probably be done inside SETXY,
SETY, and DSPFONT.)
(\BOUT FX80STREAM CHARCODE])
)
(RPAQ? FX80BAUDRATE 9600)
(DECLARE: EVAL@COMPILE
(RPAQQ \FX80PointsPerInch 72)
(CONSTANTS \FX80PointsPerInch)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(\FX80INIT)
)
(PUTPROPS FX80STREAM COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1239 78273 (NEWLINE.FX80 1249 . 1935) (NEWPAGE.FX80 1937 . 2236) (OPENFX80STREAM 2238
. 3628) (STARTPAGE.FX80 3630 . 4245) (\BITBLT.FX80 4247 . 9801) (\BLTCHAR.FX80 9803 . 12883) (
\BLTSHADE.FX80 12885 . 16651) (\CHANGECHARSET.FX80 16653 . 18458) (\CHARWIDTH.FX80 18460 . 18864) (
\CLOSEFN.FX80 18866 . 19295) (\CREATECHARSET.FX80 19297 . 24407) (\CREATEFX80FONT 24409 . 24937) (
\SEARCHFX80FONTFILES 24939 . 26405) (\STRINGWIDTH.FX80 26407 . 26931) (\DRAWCIRCLE.FX80 26933 . 32247)
(\DRAWCURVE.FX80 32249 . 33785) (\DRAWELLIPSE.FX80 33787 . 45116) (\DRAWLINE.FX80 45118 . 46571) (
\DSPCLIPPINGREGION.FX80 46573 . 47254) (\DSPFONT.FX80 47256 . 48567) (\DSPLEFTMARGIN.FX80 48569 .
49265) (\DSPLINEFEED.FX80 49267 . 49807) (\DSPOPERATION.FX80 49809 . 50670) (\DSPPRINTCHAR.FX80 50672
. 52392) (\DSPPRINTCR/LF.FX80 52394 . 59372) (\DSPRESET.FX80 59374 . 60801) (\DSPRIGHTMARGIN.FX80
60803 . 61678) (\DSPXPOSITION.FX80 61680 . 62484) (\DSPYPOSITION.FX80 62486 . 62962) (
\DUMPPAGEBUFFER.FX80 62964 . 64525) (\FILLCIRCLE.FX80 64527 . 70791) (\FX80.CRLF 70793 . 71075) (
\FX80.GRAPHICSMODE 71077 . 71547) (\FX80.PRINTERCOMMAND 71549 . 71905) (\FX80.PRINTERMODE 71907 .
73520) (\FX80INIT 73522 . 76273) (\OUTCHARFN.FX80 76275 . 78271)))))
STOP