(FILECREATED "13-Mar-85 18:17:35" {ERIS}<LISPCORE>SOURCES>PRESS.;110 314172Q
changes to: (FNS \PRESSCURVE2)
previous date: "12-Mar-85 14:45:39" {ERIS}<LISPCORE>SOURCES>PRESS.;108)
(* Copyright (c) 1981, 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT PRESSCOMS)
(RPAQQ PRESSCOMS [(COMS (FNS \SEARCHPRESSFONTS \GETPRESSFONTNAMES \PRESSFAMILYCODELST
\DECODEPRESSFACEBYTE \CREATEPRESSFONT)
(INITVARS (PRESSFONTWIDTHSFILES (QUOTE {ERIS}<LISP>FONTS>FONTS.WIDTHS)))
(ALISTS (SYSTEMINITVARS PRESSFONTWIDTHSFILES))
(DECLARE: DONTCOPY (CONSTANTS noInfoCode)))
(FNS PRESSBITMAP FULLPRESSBITMAP SHOWREGION SHOWPRESSBITMAPREGION PRESSWINDOW WINDOW.BITMAP
\WRITEPRESSBITMAP)
(FNS \BCPLSOUT.PRESS \PAGEPAD.PRESS)
(FNS \ENTITYEND.PRESS \PARTEND.PRESS \ENTITYSTART.PRESS SETX.PRESS SETXY.PRESS SETY.PRESS
SHOW.PRESS)
(FNS OPENPRSTREAM \BITBLT.PRESS \BLTSHADE.PRESS \SCALEDBITBLT.PRESS \BITMAPSIZE.PRESS
\CHARWIDTH.PRESS \CLOSEF.PRESS \DRAWLINE.PRESS \ENDPAGE.PRESS NEWLINE.PRESS
NEWPAGE.PRESS SETUPFONTS.PRESS \DEFINEFONT.PRESS \DSPBOTTOMMARGIN.PRESS
\DSPCLIPPINGREGION.PRESS \DSPFONT.PRESS \DSPLEFTMARGIN.PRESS \DSPLINEFEED.PRESS
\DSPRIGHTMARGIN.PRESS \DSPSPACEFACTOR.PRESS \DSPTOPMARGIN.PRESS \DSPXPOSITION.PRESS
\DSPYPOSITION.PRESS \FIXLINELENGTH.PRESS \OUTCHARFN.PRESS \SETSPACE.PRESS
\STARTPAGE.PRESS \STRINGWIDTH.PRESS SHOWRECTANGLE.PRESS)
[COMS (* Drawcurve code)
(FNS \ENDVECRUN \VECENCODE \VECPUT \VECSKIP \VECFONTINIT \DRAWCIRCLE.PRESS
\DRAWCURVE.PRESS \DRAWCURVE.PRESS.LINE \DRAWELLIPSE.PRESS \GETBRUSHFONT.PRESS
\PRESSCURVE2)
(INITVARS (\VecFontDir))
(CONSTANTS (\MicasPerInch 2540))
(DECLARE: DONTCOPY (CONSTANTS (ScansPerIn 384)
(PointsPerIn 72.27)
(MicasPerScan (FQUOTIENT \MicasPerInch ScansPerIn))
(ScansPerMica (FQUOTIENT ScansPerIn \MicasPerInch))
(ScansPerPoint (FQUOTIENT ScansPerIn PointsPerIn))
(PointsPerScan (FQUOTIENT PointsPerIn ScansPerIn))
(MicasPerPoint (FQUOTIENT \MicasPerInch PointsPerIn))
(PointsPerMica (FQUOTIENT PointsPerIn \MicasPerInch))
(SPRUCEPAPERTOPSCANS 4096)
(SPRUCEPAPERTOPMICAS (FIX (FQUOTIENT (FTIMES
SPRUCEPAPERTOPSCANS
\MicasPerInch)
ScansPerIn)))
(SPRUCEPAPERRIGHTMICAS (FIX (FTIMES 8.5 \MicasPerInch)))
(SPRUCEPAPERRIGHTSCANS (FIX (FTIMES 8.5 ScansPerIn)))
(SPRUCEPAPERBOTTOMSCANS 0)
(SPRUCEPAPERBOTTOMMICAS 0)
(SPRUCEPAPERLEFTSCANS 0)
(SPRUCEPAPERLEFTMICAS 0]
(FNS \PRESSINIT)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (\PRESSINIT)))
(DECLARE: DONTCOPY (RECORDS PRESSDATA FONTDIRENTRY))
(INITRECORDS PRESSDATA)
[INITVARS (DEFAULTPAGEREGION (CREATEREGION 2794 1905 16256 24765))
(PRESSBITMAPREGION (CREATEREGION 1270 1270 (FIX (TIMES 7.5 \MicasPerInch))
(TIMES 10 \MicasPerInch]
(GLOBALVARS DEFAULTPAGEREGION)
(DECLARE: DONTCOPY (CONSTANTS (BYTESPERRECORD 512)
(LISPENTITYTYPE 6)
(MICASPERINCH \MicasPerInch))
(E (RESETSAVE (RADIX 8)))
(CONSTANTS * PRESSOPS))
(COMS (FNS MAKEPRESS PRESSFILEP PRESS.BITMAPSCALE)
(ALISTS (IMAGESTREAMTYPES PRESS))
(ADDVARS [PRINTERTYPES ((PRESS SPRUCE PENGUIN DOVER)
(CANPRINT (PRESS))
(STATUS PUP.PRINTER.STATUS)
(PROPERTIES PUP.PRINTER.PROPERTIES)
(SEND EFTP)
(BITMAPSCALE NIL)
(BITMAPFILE (PRESSBITMAP FILE BITMAP SCALEFACTOR REGION
ROTATION TITLE)))
((FULLPRESS RAVEN)
(* same as PRESS but can scale bitmaps)
(CANPRINT (PRESS))
(STATUS TRUE)
(PROPERTIES NILL)
(SEND EFTP)
(BITMAPSCALE PRESS.BITMAPSCALE)
(BITMAPFILE (FULLPRESSBITMAP FILE BITMAP SCALEFACTOR REGION
ROTATION TITLE]
(PRINTFILETYPES (PRESS (TEST PRESSFILEP)
(EXTENSION (PRESS))
(CONVERSION (TEXT MAKEPRESS TEDIT
(LAMBDA (FILE PFILE FONTS HEADING)
(SETQ FILE (OPENTEXTSTREAM
FILE))
(TEDIT.FORMAT.HARDCOPY
FILE PFILE T NIL NIL NIL
(QUOTE PRESS))
(CLOSEF? FILE)
PFILE])
(DEFINEQ
(\SEARCHPRESSFONTS
[LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE) (* rrb "26-Sep-84 16:35")
(* * returns a list of the form (family size face rotation PRESS) for any font matching the specs.
* is used as wildcard.)
(DECLARE (GLOBALVARS PRESSFONTWIDTHSFILES))
(RESETLST (bind FONTSFOUND WSTRM for F inside PRESSFONTWIDTHSFILES when (INFILEP F)
do [COND
((SETQ WSTRM (\GETSTREAM F (QUOTE INPUT)
T))
(RESETSAVE NIL (LIST (QUOTE SETFILEPTR)
WSTRM
(GETFILEPTR WSTRM)))
(SETFILEPTR WSTRM 0))
(T (RESETSAVE (SETQ WSTRM (OPENSTREAM F (QUOTE INPUT)
(QUOTE OLD)
8))
(QUOTE (PROGN (CLOSEF? OLDVALUE]
(SETQ FONTSFOUND (UNION (\GETPRESSFONTNAMES WSTRM FAMILY PSIZE FACE ROTATION)
FONTSFOUND))
finally (RETURN FONTSFOUND])
(\GETPRESSFONTNAMES
[LAMBDA (WSTRM FAMILY PSIZE FACE ROTATION) (* rmk: "17-Dec-84 13:55")
(* finds the fonts that exist that match the args.
* is used as wildcard.)
(bind FONTSFOUND TYPE XFACE XFAMILY XSIZE XFACE XROTATION
[XFACECODE ←(COND
((AND (LISTP FACE)
(NOT (MEMB (QUOTE *)
FACE))) (* if complete face is specified, compute code so don't
have to on each font.)
(\FACECODE FACE]
(FAMILYCODELST ←(\PRESSFAMILYCODELST WSTRM))
(NEXT ← 0)
(MICASIZE ←(AND (NEQ PSIZE (QUOTE *))
(IQUOTIENT (ITIMES PSIZE 2540)
72)))
do (SETFILEPTR WSTRM NEXT)
(SETQ TYPE (\BIN WSTRM))
(add NEXT (LLSH (IPLUS (\BIN WSTRM)
(LLSH (LOGAND TYPE 15)
8))
1))
(SELECTQ (LRSH TYPE 4)
[4 (SETQ XFAMILY (OR (CDR (FASSOC (\BIN WSTRM)
FAMILYCODELST))
(ERROR "unknown code number in widths file")))
(COND
((OR (EQ FAMILY (QUOTE *))
(EQ FAMILY XFAMILY))
(COND
([AND (ILESSP (SETQ XFACE (\BIN WSTRM))
18)
(COND
(XFACECODE (AND (EQ XFACECODE XFACE)
(SETQ XFACE FACE)))
((PROGN (SETQ XFACE (\DECODEPRESSFACEBYTE XFACE))
(OR (EQ FACE (QUOTE *))
(EQUAL FACE XFACE)
(for SPEC in FACE as XFIELD in XFACE
always (OR (EQ SPEC XFIELD)
(EQ SPEC (QUOTE *]
(* greater than 18 means either ASCII or other type of
font, ignore it.)
(* skip beg and end chars)
(\BIN WSTRM)
(\BIN WSTRM)
(SETQ XSIZE (\WIN WSTRM))
(COND
((OR (EQ PSIZE (QUOTE *))
(EQ MICASIZE XSIZE)
(AND (EQ XSIZE 0)
(SETQ XSIZE MICASIZE)))
(* if XSIZE is 0, the font widths are relative and are to be used for all font sizes. In this case, if the user
asked about a particular size, claim that it is there.)
(SETQ XROTATION (\WIN WSTRM))
(COND
((OR (EQ ROTATION (QUOTE *))
(EQ XROTATION ROTATION))
(push FONTSFOUND (LIST XFAMILY (FIXR (FQUOTIENT (ITIMES XSIZE
72)
2540))
XFACE XROTATION (QUOTE PRESS]
(0 (RETURN FONTSFOUND))
NIL])
(\PRESSFAMILYCODELST
[LAMBDA (WSTRM) (* rrb "26-Sep-84 09:55")
(* returns an ALIST of code -
family pairs from the press font widths file WSTRM.)
(* leaving the file positioned at the beginning of the
next file entry.)
(bind PAIRS TYPE (NEXT ← 0)
do (SETFILEPTR WSTRM NEXT)
(SETQ TYPE (\BIN WSTRM))
(add NEXT (LLSH (IPLUS (\BIN WSTRM)
(LLSH (LOGAND TYPE 15)
8))
1))
(SELECTQ (LRSH TYPE 4)
(1 (SETQ PAIRS (CONS [CONS (\WIN WSTRM)
(PACKC (for I from 1 to (\BIN WSTRM)
collect (\BIN WSTRM]
PAIRS)))
(0 (RETURN PAIRS))
NIL])
(\DECODEPRESSFACEBYTE
[LAMBDA (FACECODE) (* rrb "26-Sep-84 14:28")
(* * returns a list of (weight slope expansion) from a press widths file byte code.)
(COND
[(ILESSP FACECODE 18)
(PROG (EXP SLOPE WEIGHT)
[SETQ EXP (COND
((IGEQ FACECODE 12)
(SETQ FACECODE (IDIFFERENCE FACECODE 12))
(QUOTE EXPANDED))
((IGEQ FACECODE 6)
(SETQ FACECODE (IDIFFERENCE FACECODE 6))
(QUOTE COMPRESSED))
(T (QUOTE REGULAR]
[SETQ WEIGHT (COND
((IGEQ FACECODE 4)
(SETQ FACECODE (IDIFFERENCE FACECODE 4))
(QUOTE LIGHT))
((IGEQ FACECODE 2)
(SETQ FACECODE (IDIFFERENCE FACECODE 2))
(QUOTE BOLD))
(T (QUOTE MEDIUM]
[SETQ SLOPE (COND
((EQ FACECODE 1)
(QUOTE ITALIC))
(T (QUOTE REGULAR]
(RETURN (LIST WEIGHT SLOPE EXP]
(T (* non xerox font)
NIL])
(\CREATEPRESSFONT
[LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE) (* rmk: " 4-Dec-84 10:06")
(* 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 PRESSFONTWIDTHSFILES))
(RESETLST (* RESETLST to make sure the fontfiles get closed)
(PROG [WSTRM STRMCACHE XLATEDFAM FIXEDFLAGS RELFLAG FIRSTCHAR LASTCHAR TEM WIDTHSY
(WIDTHS (ARRAY (ADD1 \MAXCHAR)
(QUOTE SMALLPOSP)
0 0))
(PRESSMICASIZE (IQUOTIENT (ITIMES PSIZE 2540)
72))
(NSMICASIZE (FIXR (FQUOTIENT (ITIMES PSIZE 2540)
72)))
(FD (create FONTDESCRIPTOR
FONTDEVICE ← DEVICE
FONTFAMILY ← FAMILY
FONTSIZE ← PSIZE
FONTFACE ← FACE
\SFFACECODE ←(\FACECODE FACE)
ROTATION ← ROTATION
FONTSCALE ←(CONSTANT (FQUOTIENT 2540 72]
(* The PRESS world and the NS world disagree on whether to truncate or round when converting from points to micas.
Hence the different values PRESSMICASIZE and NSMICASIZE.)
(OR [for F inside PRESSFONTWIDTHSFILES when (INFILEP F)
do (* Look thru the candidate PRESSFONTWIDTHSFILES for a
file that has a description for this font.)
[COND
[(SETQ WSTRM (\GETSTREAM F (QUOTE INPUT)
T))
(COND
((RANDACCESSP WSTRM)
(RESETSAVE NIL (LIST (QUOTE SETFILEPTR)
WSTRM
(GETFILEPTR WSTRM)))
(SETFILEPTR WSTRM 0]
(T (RESETSAVE (SETQ WSTRM (OPENSTREAM F (QUOTE INPUT)
(QUOTE OLD)
8))
(QUOTE (PROGN (CLOSEF? OLDVALUE]
[OR (RANDACCESSP WSTRM)
(COPYBYTES WSTRM (SETQ WSTRM (OPENSTREAM (QUOTE {NODIRCORE})
(QUOTE BOTH)
(QUOTE NEW]
(push STRMCACHE WSTRM) (* Save for coercions below)
(COND
((SETQ RELFLAG (\FINDFONT FD WSTRM PRESSMICASIZE NSMICASIZE))
(* OK, we found this font described in this file.)
(RETURN T]
[AND (SETQ XLATEDFAM (SELECTQ FAMILY
(MODERN (QUOTE HELVETICA))
(CLASSIC (QUOTE TIMESROMAN))
(LOGOTYPE (QUOTE LOGO))
(TERMINAL (QUOTE GACHA))
NIL))
(for old WSTRM in (SETQ STRMCACHE (DREVERSE STRMCACHE))
first (replace FONTFAMILY of FD with XLATEDFAM)
do (* Now try coercing the family name)
(* We know the file was left open and is randaccessp from the previous loop, which must have run off the end of the
file list)
(SETFILEPTR WSTRM 0)
(COND
((SETQ RELFLAG (\FINDFONT FD WSTRM PRESSMICASIZE NSMICASIZE))
(replace FONTDEVICESPEC of FD
with (LIST XLATEDFAM PSIZE FACE ROTATION DEVICE))
(replace FONTFAMILY of FD with FAMILY)
(RETURN T]
[AND (SETQ XLATEDFAM (SELECTQ FAMILY
(MODERN (QUOTE FRUTIGER))
(CLASSIC (QUOTE CENTURY))
NIL))
(for old WSTRM in STRMCACHE first (replace FONTFAMILY of FD
with XLATEDFAM)
do (SETFILEPTR WSTRM 0)
(COND
((SETQ RELFLAG (\FINDFONT FD WSTRM PRESSMICASIZE NSMICASIZE))
(replace FONTDEVICESPEC of FD
with (LIST XLATEDFAM PSIZE FACE ROTATION DEVICE))
(replace FONTFAMILY of FD with FAMILY)
(RETURN T]
(RETURN NIL))
(SETQ RELFLAG (ZEROP RELFLAG)) (* Actually, \FINDFONT returns zero if the font metrics
are size-relative and must be scaled.)
(SETFILEPTR WSTRM (UNFOLD (\FIXPIN WSTRM)
BYTESPERWORD))
(* Locate the segment)
(replace (FONTDESCRIPTOR FBBOX) of FD with (SIGNED (\WIN WSTRM)
BITSPERWORD))
(replace \SFDescent of FD with (IMINUS (SIGNED (\WIN WSTRM)
BITSPERWORD)))
(* Descent is -FBBOY)
(replace (FONTDESCRIPTOR FBBDX) of FD with (SIGNED (\WIN WSTRM)
BITSPERWORD))
(replace \SFHeight of FD with (SIGNED (\WIN WSTRM)
BITSPERWORD))
(* Height is FBBDY)
(replace \SFWidths of FD with WIDTHS)
(SETQ FIRSTCHAR (fetch FIRSTCHAR of FD))
(SETQ LASTCHAR (fetch LASTCHAR of FD))
[COND
(RELFLAG (* Dimensions are relative, must be scaled)
(replace (FONTDESCRIPTOR FBBOX) of FD
with (IQUOTIENT (ITIMES (fetch (FONTDESCRIPTOR FBBOX) of FD)
PRESSMICASIZE)
1000))
(replace \SFDescent of FD with (IQUOTIENT (ITIMES (fetch \SFDescent
of FD)
PRESSMICASIZE)
1000))
(replace (FONTDESCRIPTOR FBBDX) of FD
with (IQUOTIENT (ITIMES (fetch (FONTDESCRIPTOR FBBDX) of FD)
PRESSMICASIZE)
1000))
(replace \SFHeight of FD with (IQUOTIENT (ITIMES (fetch \SFHeight
of FD)
PRESSMICASIZE)
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))
(SETQ TEM (\WIN WSTRM)) (* The fixed width for this font)
[COND
((AND RELFLAG (NOT (ZEROP TEM)))
(SETQ TEM (IQUOTIENT (ITIMES TEM PRESSMICASIZE)
1000]
(for I from FIRSTCHAR to LASTCHAR do (SETA WIDTHS I TEM)))
(T (AIN WIDTHS FIRSTCHAR (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))
WSTRM)
(for I from FIRSTCHAR to LASTCHAR when (EQ noInfoCode (ELT WIDTHS I))
do (SETA WIDTHS I 0))
(COND
(RELFLAG (for I from FIRSTCHAR to LASTCHAR
do (SETA WIDTHS I (IQUOTIENT (ITIMES (ELT WIDTHS I)
PRESSMICASIZE)
1000]
[COND
[(EQ 1 (LOGAND FIXEDFLAGS 1))
(SETQ WIDTHSY (\WIN WSTRM)) (* 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 PRESSMICASIZE)
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))
WSTRM)
(for I from FIRSTCHAR to LASTCHAR when (EQ noInfoCode (ELT WIDTHSY I))
do (SETA WIDTHSY I 0))
(COND
(RELFLAG (for I from FIRSTCHAR to LASTCHAR
do (SETA WIDTHSY I (IQUOTIENT (ITIMES (ELT WIDTHSY I)
PRESSMICASIZE)
1000]
(RETURN FD])
)
(RPAQ? PRESSFONTWIDTHSFILES (QUOTE {ERIS}<LISP>FONTS>FONTS.WIDTHS))
(ADDTOVAR SYSTEMINITVARS (PRESSFONTWIDTHSFILES {DSK}FONTS.WIDTHS))
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(RPAQQ noInfoCode 32768)
(CONSTANTS noInfoCode)
)
)
(DEFINEQ
(PRESSBITMAP
[LAMBDA (FILE BITMAP SCALEFACTOR CLIPPINGREGION) (* gbn "16-Sep-84 18:44")
(* * This routine uses the whole page (ie PRTOP and PRRIGHT as opposed to PRWIDTH and PRHEIGHT) to produce a SPRUCE
Press file. It will truncate if necessary since SPRUCE does not support scaling)
(PROG ((PRSTREAM (OPENPRSTREAM FILE))
WIDTH HEIGHT PRDATA XPOS YPOS (PRESSPAGEHEIGHT (fetch HEIGHT of PRESSBITMAPREGION))
(PRESSPAGEWIDTH (fetch WIDTH of PRESSBITMAPREGION)))
(SETQ PRDATA (fetch IMAGEDATA of PRSTREAM))
(if (AND SCALEFACTOR (NOT (EQUAL SCALEFACTOR 1)))
then (ERROR "Spruce cannot scale bitmaps. Try pressing to a full press printer."))
(* Get width and height in screen pts)
[COND
(CLIPPINGREGION (SETQ WIDTH (fetch WIDTH of CLIPPINGREGION))
(SETQ HEIGHT (fetch HEIGHT of CLIPPINGREGION)))
(T (SETQ WIDTH (BITMAPWIDTH BITMAP))
(SETQ HEIGHT (BITMAPHEIGHT BITMAP]
(SETQ XPOS (IQUOTIENT (IDIFFERENCE PRESSPAGEWIDTH (FIX (TIMES MicasPerPoint WIDTH)))
2))
(SETQ YPOS (IQUOTIENT (IDIFFERENCE PRESSPAGEHEIGHT (FIX (TIMES MicasPerPoint HEIGHT)))
2))
[COND
((OR (ILESSP XPOS 0)
(ILESSP YPOS 0))
(printout T "Warning: Bitmap too large for Spruce PRESS page, will be clipped..." T)
(SETQ XPOS (IMAX 0 XPOS))
(SETQ YPOS (IMAX 0 YPOS))
(SETQ CLIPPINGREGION (if CLIPPINGREGION
then [CREATEREGION (fetch LEFT of CLIPPINGREGION)
(fetch BOTTOM of CLIPPINGREGION)
(FIX (MIN WIDTH (QUOTIENT PRESSPAGEWIDTH
MicasPerPoint)))
(FIX (MIN HEIGHT (QUOTIENT PRESSPAGEHEIGHT
MicasPerPoint]
else (CREATEREGION 0 0 (FIX (MIN WIDTH (QUOTIENT PRESSPAGEWIDTH
MicasPerPoint)))
(FIX (MIN HEIGHT (QUOTIENT PRESSPAGEHEIGHT
MicasPerPoint]
(\WRITEPRESSBITMAP BITMAP (IPLUS (fetch LEFT of PRESSBITMAPREGION)
XPOS)
(IPLUS (fetch BOTTOM of PRESSBITMAPREGION)
YPOS)
SCALEFACTOR CLIPPINGREGION PRSTREAM)
(RETURN (CLOSEF PRSTREAM])
(FULLPRESSBITMAP
[LAMBDA (FILE BITMAP SCALEFACTOR CLIPPINGREGION) (* gbn "16-Sep-84 18:51")
(* * This routine uses the whole page (ie PRTOP and PRRIGHT as opposed to PRWIDTH and PRHEIGHT) to produce a full
Press file. It will scale if necessary)
(* * When this fn is called from HARDCOPYW, the scalefactor should already be correct. On a direct call, it will
handle it itself)
(PROG ((PRSTREAM (OPENPRSTREAM FILE))
WIDTH HEIGHT PRDATA XPOS YPOS (PRESSPAGEHEIGHT (fetch HEIGHT of PRESSBITMAPREGION))
(PRESSPAGEWIDTH (fetch WIDTH of PRESSBITMAPREGION)))
(SETQ PRDATA (fetch IMAGEDATA of PRSTREAM))
(if (NOT SCALEFACTOR)
then (SETQ SCALEFACTOR 1.0)) (* Get width and height in screen pts)
[COND
(CLIPPINGREGION (SETQ WIDTH (fetch WIDTH of CLIPPINGREGION))
(SETQ HEIGHT (fetch HEIGHT of CLIPPINGREGION)))
(T (SETQ WIDTH (BITMAPWIDTH BITMAP))
(SETQ HEIGHT (BITMAPHEIGHT BITMAP]
(SETQ XPOS (IQUOTIENT (IDIFFERENCE PRESSPAGEWIDTH (FIX (TIMES MicasPerPoint WIDTH
SCALEFACTOR)))
2))
(SETQ YPOS (IQUOTIENT (IDIFFERENCE PRESSPAGEHEIGHT (FIX (TIMES MicasPerPoint HEIGHT
SCALEFACTOR)))
2))
[COND
((OR (ILESSP XPOS 0)
(ILESSP YPOS 0))
(printout T "Warning: Bitmap too large for PRESS page, will be scaled..." T)
(SETQ SCALEFACTOR (PRESS.BITMAPSCALE WIDTH HEIGHT))
(SETQ XPOS (IQUOTIENT (IDIFFERENCE PRESSPAGEWIDTH (FIX (TIMES MicasPerPoint WIDTH
SCALEFACTOR)))
2))
(SETQ YPOS (IQUOTIENT (IDIFFERENCE PRESSPAGEHEIGHT (FIX (TIMES MicasPerPoint HEIGHT
SCALEFACTOR)))
2))
(if (OR (ILESSP XPOS 0)
(ILESSP YPOS 0))
then (ERROR "Internal consistency check failed in FULLPRESSBITMAP."]
(\WRITEPRESSBITMAP BITMAP (IPLUS (fetch LEFT of PRESSBITMAPREGION)
XPOS)
(IPLUS (fetch BOTTOM of PRESSBITMAPREGION)
YPOS)
SCALEFACTOR CLIPPINGREGION PRSTREAM)
(RETURN (CLOSEF PRSTREAM])
(SHOWREGION
[LAMBDA (REGION STREAM) (* gbn "16-Sep-84 19:14")
(* * comment)
(PROG NIL
(MOVETO (fetch LEFT of REGION)
(fetch BOTTOM of REGION)
STREAM)
(RELDRAWTO (fetch WIDTH of REGION)
0 NIL NIL STREAM)
(RELDRAWTO 0 (fetch HEIGHT of REGION)
NIL NIL STREAM)
(RELDRAWTO (MINUS (fetch WIDTH of REGION))
0 NIL NIL STREAM)
(RELDRAWTO 0 (MINUS (fetch HEIGHT of REGION))
NIL NIL STREAM)
(RETURN STREAM])
(SHOWPRESSBITMAPREGION
[LAMBDA NIL (* gbn "16-Sep-84 19:18")
(* * comment)
(PROG [(STR (OPENIMAGESTREAM (QUOTE {LPT})
(QUOTE PRESS]
(SHOWREGION PRESSBITMAPREGION STR)
(RETURN (CLOSEF STR])
(PRESSWINDOW
[LAMBDA (W) (* rmk: " 7-Sep-84 14:18")
(* First Try)
(PROG ((PRSTREAM (OPENPRSTREAM (QUOTE {CORE}WINDOW.PRESS)
(LIST (QUOTE HEADING)
"Press Stream Window Image"
(QUOTE BREAKPAGEFILENAME)
"Press Stream Window Image")))
[BITMAP (WINDOW.BITMAP (OR W (WHICHW]
WIDTH HEIGHT (PTSTOMICAS 35))
(SETQ WIDTH (BITMAPWIDTH BITMAP))
(SETQ HEIGHT (BITMAPHEIGHT BITMAP))
(DSPXPOSITION (IPLUS (fetch PRLEFT of (fetch IMAGEDATA of PRSTREAM))
(IQUOTIENT (IDIFFERENCE (fetch PRWIDTH of (fetch IMAGEDATA
of PRSTREAM))
(ITIMES PTSTOMICAS WIDTH))
2))
PRSTREAM)
(DSPYPOSITION (IPLUS (fetch PRBOTTOM of (fetch IMAGEDATA of PRSTREAM))
(IQUOTIENT (IDIFFERENCE (fetch PRHEIGHT of (fetch IMAGEDATA
of PRSTREAM))
(ITIMES PTSTOMICAS HEIGHT))
2))
PRSTREAM)
(\WRITEPRESSBITMAP BITMAP NIL NIL PRSTREAM)
(RETURN (CLOSEF PRSTREAM])
(WINDOW.BITMAP
[LAMBDA (W) (* rmk: "19-Jun-84 01:57")
(* Returns all of the bitmap of the window)
(PROG [BM (REGION (WINDOWPROP W (QUOTE REGION]
(CLOSEW W)
(SETQ BM (BITMAPCREATE (fetch WIDTH of REGION)
(fetch HEIGHT of REGION)))
(BITBLT (WINDOWPROP W (QUOTE IMAGECOVERED))
NIL NIL BM)
(OPENW W)
(RETURN BM])
(\WRITEPRESSBITMAP
[LAMBDA (BITMAP XPOS YPOS SCALEFACTOR CLIPPINGREGION PRSTREAM)
(* hdj "11-Mar-85 18:25")
(* This should define the origin of the bitmap on the
page)
[COND
(CLIPPINGREGION (* UGH)
(SETQ BITMAP (PROG [(BM (BITMAPCREATE (fetch WIDTH of CLIPPINGREGION)
(fetch HEIGHT of CLIPPINGREGION]
(with REGION CLIPPINGREGION
(BITBLT BITMAP LEFT BOTTOM BM NIL NIL WIDTH HEIGHT))
(RETURN BM]
(PROG ((PRDATA (fetch IMAGEDATA of PRSTREAM))
(WW (fetch BITMAPRASTERWIDTH of BITMAP))
(HT (fetch BITMAPHEIGHT of BITMAP))
ELSTREAM TOTCOUNT CURX CURY)
(SETQ ELSTREAM (fetch ELSTREAM of PRDATA))
(SETQ CURX (fetch PRXPOS of PRDATA))
(SETQ CURY (fetch PRYPOS of PRDATA))
(SHOW.PRESS PRSTREAM) (* flush chars before ending entity)
(\ENTITYEND.PRESS PRSTREAM)
(* Close previous entity because we used to specify a translation for the bitmap entity. But now we are using the
current x and y position. All this stuff might therefore be unnecessary)
(\ENTITYSTART.PRESS PRSTREAM)
(SETXY.PRESS PRSTREAM XPOS YPOS)
(COND
((NULL SCALEFACTOR)
(SETQ SCALEFACTOR 1.0)))
(\WOUT PRSTREAM 256) (* Output <<Set-Coding>>. (0 notates bitmap, followed
by 2byte width (in dots) and height
(in dots)))
(\WOUT PRSTREAM (UNFOLD WW BITSPERWORD)) (* Width)
(\WOUT PRSTREAM HT) (* Height)
(\WOUT PRSTREAM (IPLUS 512 3)) (* <<Set-Mode>> notates that the Lisp bitmap is stored
left-to-right and top-to-bottom)
(\WOUT PRSTREAM 2) (* you might think it should be MicasPerPoint -
ha ha ha! Only the value 32 works! Oops!)
[\WOUT PRSTREAM (FIXR (FTIMES SCALEFACTOR (TIMES 32 (UNFOLD WW BITSPERWORD]
[\WOUT PRSTREAM (FIXR (FTIMES SCALEFACTOR (TIMES 32 HT]
(\WOUT PRSTREAM 1)
(* Set Window. 2 bytes of how many bytes to skip, 2 bytes of how many dots wide to display followed by the same for
lines)
(\WOUT PRSTREAM 0) (* skip 0 dots)
(\WOUT PRSTREAM (UNFOLD WW BITSPERWORD))
(\WOUT PRSTREAM 0) (* skip 0 lines)
(\WOUT PRSTREAM HT)
(\WOUT PRSTREAM 3) (* <<Dots-Follow>>)
(* TOTCOUNT is a word count.)
(\BOUTS PRSTREAM (fetch BITMAPBASE of BITMAP)
0
(UNFOLD (SETQ TOTCOUNT (ITIMES HT WW))
BYTESPERWORD))
(\BOUT ELSTREAM ShowDotsCode)
(\FIXPOUT ELSTREAM (IPLUS TOTCOUNT 13)) (* Number of DL bytes)
(\ENTITYEND.PRESS PRSTREAM)
(\ENTITYSTART.PRESS PRSTREAM) (* Since START reestablishes X and Y, following might
not be necessary)
(SETXY.PRESS PRSTREAM CURX CURY])
)
(DEFINEQ
(\BCPLSOUT.PRESS
[LAMBDA (STRM X N) (* rmk: "14-Jun-84 19:36")
(* Puts out a Bcpl string X in N bytes, filling with
zeroes or truncating if needed.)
(PROG [(NC (IMIN (NCHARS X)
(SETQ N (SUB1 N]
(\BOUT STRM NC)
(for I from 1 to NC do (\BOUT STRM (NTHCHARCODE X I)))
(for I from (ADD1 NC) to N do (\BOUT STRM 0])
(\PAGEPAD.PRESS
[LAMBDA (STRM) (* rmk: "14-Jun-84 18:30")
(* Move the fileptr to the next record boundary,
returning the number of words skipped.)
(PROG (PADDING (P (GETFILEPTR STRM)))
(SETQ PADDING (MODUP P BYTESPERRECORD))
(COND
((IGREATERP PADDING 0) (* SETFILEPTR for all but 1, then \BOUT to make sure the
file gets extended.)
[AND (NEQ PADDING 1)
(SETFILEPTR STRM (IPLUS P (SUB1 PADDING]
(\BOUT STRM 0)))
(RETURN (FOLDLO PADDING BYTESPERWORD])
)
(DEFINEQ
(\ENTITYEND.PRESS
[LAMBDA (PRSTREAM XOFFSET YOFFSET ETYPE) (* rmk: "23-Aug-84 21:56")
(PROG (ELSTREAM DLLENGTH (PRDATA (fetch IMAGEDATA of PRSTREAM)))
(SETQ ELSTREAM (fetch ELSTREAM of PRDATA))
(SETQ DLLENGTH (IDIFFERENCE (\GETFILEPTR PRSTREAM)
(fetch DLSTARTBYTE of PRDATA)))
(COND
((ODDP (GETFILEPTR ELSTREAM))
(\BOUT ELSTREAM NopCode)))
(\BOUT ELSTREAM (OR ETYPE LISPENTITYTYPE))
(\BOUT ELSTREAM (OR (fetch FONTSET# of (fetch PRCURRFDE of PRDATA))
0)) (* fontset)
(\FIXPOUT ELSTREAM (IDIFFERENCE (fetch DLSTARTBYTE of PRDATA)
(UNFOLD (fetch PRPARTSTART of PRDATA)
BYTESPERRECORD)))
(* (IDIFFERENCE (fetch DLSTARTBYTE of PRDATA)
(UNFOLD (fetch PRPARTSTART of PRDATA) BYTESPERRECORD)))
(* part relative start of data list for this entity)
(\FIXPOUT ELSTREAM DLLENGTH) (* length of data)
(\WOUT ELSTREAM (OR XOFFSET 0)) (* Entity origin)
(\WOUT ELSTREAM (OR YOFFSET 0))
(\WOUT ELSTREAM (fetch PRLEFT of PRDATA)) (* The bounding box for this entity -
MAYBE LEFT AND BOTTOM ARE SIGNED?)
(\WOUT ELSTREAM (fetch PRBOTTOM of PRDATA))
(\WOUT ELSTREAM (IDIFFERENCE (fetch PRRIGHT of PRDATA)
(fetch PRLEFT of PRDATA)))
(* width)
(\WOUT ELSTREAM (IDIFFERENCE (fetch PRTOP of PRDATA)
(fetch PRBOTTOM of PRDATA)))
(* height)
(\WOUT ELSTREAM (ADD1 (FOLDLO (IDIFFERENCE (GETFILEPTR ELSTREAM)
(fetch ELSTARTBYTE of PRDATA))
BYTESPERWORD))) (* Length in words--ADD1 for the length itself)
])
(\PARTEND.PRESS
[LAMBDA (PRSTREAM PARTTYPE) (* rmk: "20-Jun-84 11:16")
(* Closes one part and sets up for the next, by saving
the partstart and emptying the entitylist stream)
(PROG (START PDSTREAM (PRDATA (fetch IMAGEDATA of PRSTREAM)))
(SETQ PDSTREAM (fetch PDSTREAM of PRDATA))
(SETQ START (fetch PRPARTSTART of PRDATA))
(\WOUT PDSTREAM PARTTYPE)
(\WOUT PDSTREAM START) (* Starting record)
(* Update starting record for next part, and record
length in records of this part)
(\WOUT PDSTREAM (IDIFFERENCE (replace PRPARTSTART of PRDATA with (FOLDHI (GETFILEPTR
PRSTREAM)
BYTESPERRECORD))
START))
(\WOUT PDSTREAM (\PAGEPAD.PRESS PRSTREAM))
(SETFILEPTR (fetch ELSTREAM of PRDATA)
0])
(\ENTITYSTART.PRESS
[LAMBDA (PRSTREAM) (* rmk: "28-Nov-84 09:01")
(PROG ((PRDATA (fetch IMAGEDATA of PRSTREAM)))
(freplace PRSPACEWIDTH of PRDATA with NIL)
(* This really should be the spacewidth of the current font. But then, if we switch fonts to one whose
space*spacefactor comes out the same, we won't know to put out a setspace command. So when we actually set up the
first font in this entity, we will end up putting out an explicit setspace (even if the space factor is 1))
(freplace PRFONT of PRDATA with NIL)
(* We set the font to NIL, knowing that the current font can be recoverd from the PRCURRFDE.
This font will be set in the press file before the first show, if no explicit dspfont intervenes.
Note, however, that up until the first dspfont, the widthscache still corresponds to what was the PRFONT.)
(freplace DLSTARTBYTE of PRDATA with (\GETFILEPTR PRSTREAM))
(freplace ELSTARTBYTE of PRDATA with (\GETFILEPTR (fetch ELSTREAM of PRDATA)))
(freplace STARTCHARBYTE of PRDATA with (\GETFILEPTR PRSTREAM))
(* Entity starts with position at 0,0 so must
re-establish current position
(?))
(SETXY.PRESS PRSTREAM (fetch PRXPOS of PRDATA)
(fetch PRYPOS of PRDATA])
(SETX.PRESS
[LAMBDA (PRSTREAM X) (* rmk: "17-Dec-84 10:00")
(PROG [(ELSTREAM (fetch ELSTREAM of (fetch IMAGEDATA of PRSTREAM]
(COND
((AND (IGEQ X SPRUCEPAPERLEFTMICAS)
(ILEQ X SPRUCEPAPERRIGHTMICAS))
(\BOUT ELSTREAM SetXCode) (* Outcharfn ignores characters that are not in the
clipping region)
(\WOUT ELSTREAM X)))
(replace PRXPOS of (fetch IMAGEDATA of PRSTREAM) with X])
(SETXY.PRESS
[LAMBDA (PRSTREAM X Y) (* rmk: "17-Dec-84 10:59")
(PROG (ELSTREAM (PRDATA (fetch IMAGEDATA of PRSTREAM)))
(SETQ ELSTREAM (fetch ELSTREAM of PRDATA))
(COND
((AND (IGEQ X SPRUCEPAPERLEFTMICAS)
(ILEQ X SPRUCEPAPERRIGHTMICAS))
(\BOUT ELSTREAM SetXCode)
(\WOUT ELSTREAM X)))
(replace PRXPOS of PRDATA with X)
(COND
((AND (IGEQ Y SPRUCEPAPERBOTTOMMICAS)
(ILEQ Y SPRUCEPAPERTOPMICAS))
(\BOUT ELSTREAM SetYCode)
(\WOUT ELSTREAM Y)))
(RETURN (replace PRYPOS of PRDATA with Y])
(SETY.PRESS
[LAMBDA (PRSTREAM Y) (* rmk: "17-Dec-84 10:59")
(PROG [(ELSTREAM (fetch ELSTREAM of (fetch IMAGEDATA of PRSTREAM]
(COND
((AND (IGEQ Y SPRUCEPAPERBOTTOMMICAS)
(ILEQ Y SPRUCEPAPERTOPMICAS))
(\BOUT ELSTREAM SetYCode)
(\WOUT ELSTREAM Y)))
(replace PRYPOS of (fetch IMAGEDATA of PRSTREAM) with Y])
(SHOW.PRESS
[LAMBDA (PRSTREAM) (* rmk: "28-Jun-84 15:16")
(PROG (CNT ELSTREAM (PRDATA (fetch IMAGEDATA of PRSTREAM))
(CURBYTE (\GETFILEPTR PRSTREAM)))
(SETQ ELSTREAM (fetch ELSTREAM of PRDATA))
(SETQ CNT (IDIFFERENCE CURBYTE (fetch STARTCHARBYTE of PRDATA)))
[COND
((IGREATERP CNT 0)
[COND
((NULL (fetch PRFONT of PRDATA))
(* This is the first run of characters in this entity, and there has been no explicit dspfont.
We therefore re-establish the current font as of the end of the last entity)
(replace PRFONT of PRDATA with (fetch DESCR of (fetch PRCURRFDE of PRDATA)))
(\BOUT (fetch ELSTREAM of PRDATA)
(LOGOR FontCode (fetch (FONTDIRENTRY FONT#) of (fetch PRCURRFDE
of PRDATA]
(COND
((ILESSP CNT 33) (* short form)
(\BOUT ELSTREAM (IPLUS ShowCharactersShortCode CNT -1)))
(T (* Break up every 255)
(while (IGREATERP CNT 255)
do (\BOUT ELSTREAM ShowCharactersCode)
(\BOUT ELSTREAM 255)
(SETQ CNT (IDIFFERENCE CNT 255))
finally (\BOUT ELSTREAM ShowCharactersCode)
(\BOUT ELSTREAM CNT]
(replace STARTCHARBYTE of PRDATA with CURBYTE])
)
(DEFINEQ
(OPENPRSTREAM
[LAMBDA (PRFILE OPTIONS) (* rmk: "17-Dec-84 10:34")
(* Opens a Press stream, to which user can do OUTCHAR. OPTIONS can include a REGION, HEADING, BREAKPAGEFILENAME, and
FONTS. FONTS is a list of fonts to be set up initially. Headings will be printed in the first font in FONTS.
If FONTS is NIL, then the stream is initialized with the PRESS DEFAULTFONT)
(DECLARE (GLOBALVARS DEFAULTPAGEREGION \PRESSIMAGEOPS))
(PROG [OPT PRDATA (PRSTREAM (OPENSTREAM PRFILE (QUOTE OUTPUT)
(QUOTE NEW)
8
(QUOTE ((TYPE BINARY]
[SETQ PRDATA (create PRESSDATA
PRPAGEREGION ←(COND
([type? REGION (SETQ OPT (LISTGET OPTIONS (QUOTE REGION]
OPT)
(T DEFAULTPAGEREGION))
PDSTREAM ←(PROG1 (OPENSTREAM (QUOTE {NODIRCORE})
(QUOTE BOTH)
(QUOTE OLD/NEW))
(* Make sure the fileptr of the following is zero
(GETRESOURCE \PRESSPDSTREAM)
(and free this in \CLOSE.PRESS))
)
ELSTREAM ←(PROG1 (OPENSTREAM (QUOTE {NODIRCORE})
(QUOTE BOTH)
(QUOTE OLD/NEW))
(* Make sure the fileptr of the following is zero
(GETRESOURCE \PRESSELSTREAM)
(and free this in \CLOSE.PRESS))
)
PRDOCNAME ←(LISTGET OPTIONS (QUOTE DOCUMENT.NAME]
(COND
((OR (NEQ \NOIMAGEOPS (fetch (STREAM IMAGEOPS) of PRSTREAM))
(NEQ 0 (GETEOFPTR PRSTREAM)))
(ERROR "can't convert existing file to Press" (FULLNAME PRSTREAM))
(* GETEOFPTR might bomb on some streams)
))
(replace (STREAM OUTCHARFN) of PRSTREAM with (FUNCTION \OUTCHARFN.PRESS))
(replace (STREAM IMAGEOPS) of PRSTREAM with \PRESSIMAGEOPS)
(replace (STREAM IMAGEDATA) of PRSTREAM with PRDATA)
(COND
((SETQ OPT (LISTGET OPTIONS (QUOTE HEADING)))
(replace PRHEADING of PRDATA with OPT)))
(SETUPFONTS.PRESS PRSTREAM (LISTGET OPTIONS (QUOTE FONTS)))
(\STARTPAGE.PRESS PRSTREAM)
(RETURN PRSTREAM])
(\BITBLT.PRESS
[LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH
HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT
CLIPPEDSOURCEBOTTOM) (* hdj " 5-Dec-84 18:39")
(LET* ((OLDX (\DSPXPOSITION.PRESS DESTINATION))
(OLDY (\DSPYPOSITION.PRESS DESTINATION))
(DESTINATIONLEFT (OR DESTINATIONLEFT OLDX))
(DESTINATIONBOTTOM (OR DESTINATIONBOTTOM OLDY)))
(\DSPXPOSITION.PRESS DESTINATION DESTINATIONLEFT)
(\DSPYPOSITION.PRESS DESTINATION DESTINATIONBOTTOM)
(\WRITEPRESSBITMAP SOURCEBITMAP DESTINATIONLEFT DESTINATIONBOTTOM 1
(COND
(CLIPPINGREGION (INTERSECTREGIONS CLIPPINGREGION
(CREATEREGION CLIPPEDSOURCELEFT
CLIPPEDSOURCEBOTTOM WIDTH
HEIGHT)))
(T (CREATEREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM WIDTH HEIGHT)))
DESTINATION)
(\DSPXPOSITION.PRESS DESTINATION OLDX)
(\DSPYPOSITION.PRESS DESTINATION OLDY))
T])
(\BLTSHADE.PRESS
[LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION)
(* hdj "12-Mar-85 12:30")
(LET* ((REGION (CREATEREGION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT))
(DESTREGION (if CLIPPINGREGION
then (INTERSECTREGIONS REGION CLIPPINGREGION)
else REGION)))
(* * (SHOWSHADE.IP STREAM TEXTURE DESTREGION OPERATION))
(* Dovers print at 32 micas per point)
(\BLTSHADE.GENERICPRINTER TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT
OPERATION CLIPPINGREGION 32])
(\SCALEDBITBLT.PRESS
[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.PRESS DESTINATION))
(OLDY (\DSPYPOSITION.PRESS DESTINATION))
(DESTINATIONLEFT (OR DESTINATIONLEFT OLDX))
(DESTINATIONBOTTOM (OR DESTINATIONBOTTOM OLDY)))
(\DSPXPOSITION.PRESS DESTINATION DESTINATIONLEFT)
(\DSPYPOSITION.PRESS DESTINATION DESTINATIONBOTTOM)
(\WRITEPRESSBITMAP SOURCEBITMAP DESTINATIONLEFT DESTINATIONBOTTOM SCALE
(COND
(CLIPPINGREGION (INTERSECTREGIONS CLIPPINGREGION
(CREATEREGION CLIPPEDSOURCELEFT
CLIPPEDSOURCEBOTTOM WIDTH
HEIGHT)))
(T (CREATEREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM WIDTH HEIGHT)))
DESTINATION)
(\DSPXPOSITION.PRESS DESTINATION OLDX)
(\DSPYPOSITION.PRESS DESTINATION OLDY))
T])
(\BITMAPSIZE.PRESS
[LAMBDA (STREAM BITMAP DIMENSION) (* rmk: "17-Dec-84 10:22")
(SELECTQ DIMENSION
(WIDTH (UNFOLD (BITMAPWIDTH BITMAP)
32))
(HEIGHT (UNFOLD (BITMAPHEIGHT BITMAP)
32))
(NIL (CONS (UNFOLD (BITMAPWIDTH BITMAP)
32)
(UNFOLD (BITMAPHEIGHT BITMAP)
32)))
(\ILLEGAL.ARG DIMENSION])
(\CHARWIDTH.PRESS
[LAMBDA (STREAM CHARCODE) (* rmk: "16-Nov-84 11:43")
(* Gets the width of CHARCODE in an Interpress STREAM,
observing spacefactor)
(COND
((EQ CHARCODE (CHARCODE SPACE))
(ffetch PRSPACEWIDTH of (ffetch IMAGEDATA of STREAM)))
(T (\FGETWIDTH (ffetch PRWIDTHSCACHE of (ffetch IMAGEDATA of STREAM))
(LOGAND CHARCODE \CHARMASK])
(\CLOSEF.PRESS
[LAMBDA (PRSTREAM) (* rmk: " 3-Dec-84 11:26")
(* FILENAME is for the printer break page)
(\ENDPAGE.PRESS PRSTREAM)
(PROG (PDSTREAM (PRDATA (fetch IMAGEDATA of PRSTREAM)))
(SETQ PDSTREAM (fetch PDSTREAM of PRDATA))
(COND
((NEQ 0 (GETFILEPTR PDSTREAM))
(for FDE DESCR in (fetch PRESSFONTDIR of PRDATA) as I from 0
do (SETQ DESCR (fetch DESCR of FDE))
(\WOUT PRSTREAM 16)
(\BOUT PRSTREAM (fetch FONTSET# of FDE))
(* Fontset)
(\BOUT PRSTREAM (fetch FONT# of FDE)) (* font#)
(\BOUT PRSTREAM (fetch FIRSTCHAR of DESCR))
(\BOUT PRSTREAM (fetch LASTCHAR of DESCR))
(\BCPLSOUT.PRESS PRSTREAM (FONTPROP DESCR (QUOTE DEVICEFAMILY))
20)
[\BOUT PRSTREAM (\FACECODE (FONTPROP DESCR (QUOTE DEVICEFACE]
(\BOUT PRSTREAM (fetch FIRSTCHAR of DESCR))
(\WOUT PRSTREAM (FONTPROP DESCR (QUOTE DEVICESIZE)))
(\WOUT PRSTREAM (fetch ROTATION of DESCR)))
(\WOUT PRSTREAM 0) (* Font part ends with 0 word)
(\PARTEND.PRESS PRSTREAM 1)
(COPYBYTES PDSTREAM PRSTREAM 0 (GETFILEPTR PDSTREAM))
(\PAGEPAD.PRESS PRSTREAM)
(PROG (DDRECORD (DDFILEPTR (GETFILEPTR PRSTREAM)))
(* Write document directory)
(SETQ DDRECORD (FOLDLO DDFILEPTR BYTESPERRECORD))
(\WOUT PRSTREAM 27183) (* password)
(\WOUT PRSTREAM (ADD1 DDRECORD))
(\WOUT PRSTREAM (FOLDLO (GETFILEPTR PDSTREAM)
8)) (* number of parts, since each occupies 8 bytes in PD)
(\WOUT PRSTREAM (fetch PRPARTSTART of PRDATA))
(* part directory)
(\WOUT PRSTREAM (IDIFFERENCE DDRECORD (fetch PRPARTSTART of PRDATA)))
(\SIGNEDWOUT PRSTREAM -1) (* obselete)
(\FIXPOUT PRSTREAM (LISP.TO.ALTO.DATE (IDATE)))
(\WOUT PRSTREAM 1)
(\WOUT PRSTREAM 1) (* copies)
(\SIGNEDWOUT PRSTREAM -1)
(\SIGNEDWOUT PRSTREAM -1) (* first and last pages)
(\SIGNEDWOUT PRSTREAM -1) (* printing mode default)
(SETFILEPTR PRSTREAM (IPLUS DDFILEPTR 256))
(\BCPLSOUT.PRESS PRSTREAM (OR (fetch PRDOCNAME of PRDATA)
(FULLNAME PRSTREAM))
52)
(\BCPLSOUT.PRESS PRSTREAM USERNAME 32)
(\BCPLSOUT.PRESS PRSTREAM (GETFILEINFO PRSTREAM (QUOTE CREATIONDATE))
40)
(\PAGEPAD.PRESS PRSTREAM])
(\DRAWLINE.PRESS
[LAMBDA (PRSTREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR) (* rmk: "21-Sep-84 09:00")
(\DRAWCURVE.PRESS PRSTREAM (LIST (CREATEPOSITION X1 Y1)
(CREATEPOSITION X2 Y2))
NIL
(LIST (QUOTE BUTT)
WIDTH)
NIL)
Y2])
(\ENDPAGE.PRESS
[LAMBDA (PRSTREAM) (* rmk: "28-Jun-84 15:14")
(PROG [(ELSTREAM (fetch ELSTREAM of (fetch IMAGEDATA of PRSTREAM]
(SHOW.PRESS PRSTREAM)
(\ENTITYEND.PRESS PRSTREAM)
(COND
((NEQ 0 (\GETFILEPTR ELSTREAM))
(COND
((ODDP (\GETFILEPTR PRSTREAM))
(\BOUT PRSTREAM 0)))
(\WOUT PRSTREAM 0) (* 0 word to separate DL from EL)
(COPYBYTES ELSTREAM PRSTREAM 0 (\GETFILEPTR ELSTREAM))
(\PARTEND.PRESS PRSTREAM 0])
(NEWLINE.PRESS
[LAMBDA (PRSTREAM) (* rmk: " 4-Oct-84 10:00")
(* Go to next line (or next page))
(PROG (NEWYPOS (PRDATA (ffetch IMAGEDATA of PRSTREAM)))
(SETQ NEWYPOS (IPLUS (ffetch PRYPOS of PRDATA)
(ffetch PRLINEFEED of PRDATA)))
(COND
((ILESSP NEWYPOS (ffetch PRBOTTOM of PRDATA))
(NEWPAGE.PRESS PRSTREAM))
(T (SHOW.PRESS PRSTREAM)
(SETXY.PRESS PRSTREAM (ffetch PRLEFT of PRDATA)
NEWYPOS])
(NEWPAGE.PRESS
[LAMBDA (PRSTREAM) (* rmk: "16-Jun-84 14:29")
(\ENDPAGE.PRESS PRSTREAM)
(\STARTPAGE.PRESS PRSTREAM])
(SETUPFONTS.PRESS
[LAMBDA (PRSTREAM FONTS) (* rmk: "15-Sep-84 02:15")
(* Sets up fonts in the initial fontset. and sets heading font. Leaves PRFONT as NIL. This means that \DSPFONT.PRESS
of the heading font will establish that as the current font when the first page opens.)
(for F FLG inside (OR FONTS DEFAULTFONT)
do (SETQ F (FONTCREATE F NIL NIL NIL (QUOTE PRESS)))
(COND
(FLG (\DEFINEFONT.PRESS PRSTREAM F))
(T (\DSPFONT.PRESS PRSTREAM F) (* Install first font as current font and heading font.
font.)
(\ENTITYEND.PRESS PRSTREAM)
(replace PRHEADINGFONT of (fetch IMAGEDATA of PRSTREAM) with F)
(SETQ FLG T])
(\DEFINEFONT.PRESS
[LAMBDA (PRSTREAM FONT) (* rmk: "15-Jun-84 17:10")
(PROG ((PRDATA (fetch IMAGEDATA of PRSTREAM)))
(RETURN (OR (FASSOC FONT (fetch PRESSFONTDIR of PRDATA))
(CAR (push (fetch PRESSFONTDIR of PRDATA)
(PROG1 (create FONTDIRENTRY
DESCR ← FONT
FONT# ←(fetch PRNEXTFONT# of PRDATA)
FONTSET# ←(fetch PRMAXFONTSET of PRDATA))
(COND
((EQ 16 (add (fetch PRNEXTFONT# of PRDATA)
1))
(add (fetch PRMAXFONTSET of PRDATA)
1)
(replace PRNEXTFONT# of PRDATA with 0])
(\DSPBOTTOMMARGIN.PRESS
[LAMBDA (PRSTREAM YPOSITION) (* rmk: "26-Jun-84 14:05")
(PROG1 (fetch PRBOTTOM of (fetch IMAGEDATA of PRSTREAM))
(COND
(YPOSITION (replace PRBOTTOM of (fetch IMAGEDATA of PRSTREAM) with YPOSITION])
(\DSPCLIPPINGREGION.PRESS
[LAMBDA (STREAM REGION) (* jds "11-Jan-85 16:56")
(* sets the clipping region of a PRESS stream.)
(PROG ((PRDATA (FETCH IMAGEDATA OF STREAM)))
(RETURN (PROG1 (ffetch PRClippingRegion of PRDATA)
(COND
(REGION (OR (type? REGION REGION)
(ERROR REGION " is not a REGION."))
(UNINTERRUPTABLY
(freplace PRClippingRegion of PRDATA with REGION))])
(\DSPFONT.PRESS
[LAMBDA (PRSTREAM FONT) (* rmk: "30-Nov-84 08:56")
(PROG (OLDFONT FDENTRY (PRDATA (ffetch IMAGEDATA of PRSTREAM)))
(SETQ OLDFONT (ffetch PRFONT of PRDATA))
(COND
([OR (NULL FONT)
(EQ OLDFONT (SETQ FONT (OR (\GETFONTDESC FONT (QUOTE PRESS)
T)
(FONTCOPY OLDFONT FONT]
(RETURN OLDFONT)))
(SHOW.PRESS PRSTREAM)
(SETQ FDENTRY (\DEFINEFONT.PRESS PRSTREAM FONT))
(COND
((NEQ (ffetch FONTSET# of FDENTRY)
(ffetch FONTSET# of (ffetch PRCURRFDE of PRDATA)))
(* Swtich font sets)
(\ENTITYEND.PRESS PRSTREAM)
(\ENTITYSTART.PRESS PRSTREAM)))
(freplace PRCURRFDE of PRDATA with FDENTRY)
(freplace PRFONT of PRDATA with FONT)
(\BOUT (ffetch ELSTREAM of PRDATA)
(LOGOR FontCode (ffetch FONT# of FDENTRY)))
(freplace PRWIDTHSCACHE of PRDATA with (ffetch (ARRAYP BASE) of (ffetch \SFWidths
of FONT)))
[\SETSPACE.PRESS PRSTREAM (FIXR (TIMES (ffetch PRSPACEFACTOR of PRDATA)
(\FGETWIDTH (ffetch PRWIDTHSCACHE of PRDATA)
(CHARCODE SPACE]
[freplace PRLINEFEED of PRDATA with (IDIFFERENCE (CONSTANT (IMINUS MicasPerPoint))
(FONTPROP FONT (QUOTE HEIGHT]
(\FIXLINELENGTH.PRESS PRSTREAM)
(RETURN OLDFONT])
(\DSPLEFTMARGIN.PRESS
[LAMBDA (PRSTREAM XPOSITION) (* rmk: " 4-Oct-84 10:35")
(PROG1 (ffetch PRLEFT of (ffetch IMAGEDATA of PRSTREAM))
(COND
(XPOSITION (freplace PRLEFT of (ffetch IMAGEDATA of PRSTREAM) with XPOSITION)
(\FIXLINELENGTH.PRESS PRSTREAM])
(\DSPLINEFEED.PRESS
[LAMBDA (PRSTREAM DELTAY) (* rmk: " 4-Oct-84 09:31")
(* sets the amount that a line feed increases the y
coordinate by.)
(PROG ((PRDATA (ffetch IMAGEDATA of PRSTREAM)))
(RETURN (PROG1 (ffetch PRLINEFEED of PRDATA)
(AND DELTAY (COND
((NUMBERP DELTAY)
(freplace PRLINEFEED of PRDATA with DELTAY))
(T (\ILLEGAL.ARG DELTAY])
(\DSPRIGHTMARGIN.PRESS
[LAMBDA (PRSTREAM XPOSITION) (* rmk: " 4-Oct-84 10:35")
(PROG1 (ffetch PRRIGHT of (ffetch IMAGEDATA of PRSTREAM))
(COND
(XPOSITION (freplace PRRIGHT of (ffetch IMAGEDATA of PRSTREAM) with XPOSITION)
(\FIXLINELENGTH.PRESS PRSTREAM])
(\DSPSPACEFACTOR.PRESS
[LAMBDA (STREAM FACTOR) (* rmk: "28-Nov-84 09:03")
(PROG ((PRDATA (ffetch IMAGEDATA of STREAM)))
(RETURN (PROG1 (ffetch PRSPACEFACTOR of PRDATA)
(COND
(FACTOR (SHOW.PRESS STREAM)
(freplace PRSPACEFACTOR of PRDATA with FACTOR)
(\SETSPACE.PRESS STREAM
(FIXR (TIMES FACTOR (\FGETWIDTH (ffetch
PRWIDTHSCACHE
of PRDATA)
(CHARCODE SPACE])
(\DSPTOPMARGIN.PRESS
[LAMBDA (PRSTREAM YPOSITION) (* rmk: "26-Jun-84 14:04")
(PROG1 (fetch PRTOP of (fetch IMAGEDATA of PRSTREAM))
(COND
(YPOSITION (replace PRTOP of (fetch IMAGEDATA of PRSTREAM) with YPOSITION])
(\DSPXPOSITION.PRESS
[LAMBDA (PRSTREAM XPOSITION) (* rmk: "14-Jun-84 20:17")
(PROG1 (fetch PRXPOS of (fetch IMAGEDATA of PRSTREAM))
(COND
(XPOSITION (SHOW.PRESS PRSTREAM)
(SETX.PRESS PRSTREAM XPOSITION])
(\DSPYPOSITION.PRESS
[LAMBDA (PRSTREAM YPOSITION) (* rmk: "14-Jun-84 20:17")
(PROG1 (fetch PRYPOS of (fetch IMAGEDATA of PRSTREAM))
(COND
(YPOSITION (SHOW.PRESS PRSTREAM)
(SETY.PRESS PRSTREAM YPOSITION])
(\FIXLINELENGTH.PRESS
[LAMBDA (PRSTREAM) (* rmk: "27-Nov-84 18:28")
(* PRSTREAM is known to be a stream of type press. Called by RIGHTMARGIN LEFTMARGIN and \DSPFONT.PRESS to update the
LINELENGTH field in the stream. also called when the stream is created.)
(PROG (LLEN (PRDATA (ffetch IMAGEDATA of PRSTREAM)))
(freplace (STREAM LINELENGTH) of PRSTREAM
with (COND
((IGREATERP [SETQ LLEN (IQUOTIENT (IDIFFERENCE (ffetch PRRIGHT of PRDATA)
(ffetch PRLEFT of PRDATA))
(fetch FONTAVGCHARWIDTH
of (fetch PRFONT of PRDATA]
1)
LLEN)
(T 10])
(\OUTCHARFN.PRESS
[LAMBDA (PRSTREAM CHARCODE) (* jds "11-Jan-85 17:01")
(* Handle all the special-purpose characters going to a
PRESS file)
(SELCHARQ CHARCODE
(EOL (* New Line)
(NEWLINE.PRESS PRSTREAM)
(replace (STREAM CHARPOSITION) of PRSTREAM with 0))
[LF (* Line feed--move down, but not over)
(\DSPXPOSITION.PRESS PRSTREAM (PROG1 (DSPXPOSITION NIL PRSTREAM)
(NEWLINE.PRESS PRSTREAM]
(↑L (* Form Feed)
(replace (STREAM CHARPOSITION) of PRSTREAM with 0)
(NEWPAGE.PRESS PRSTREAM))
(PROG (XPOS NEWXPOS CLIPPINGREGION (PRDATA (fetch IMAGEDATA of PRSTREAM)))
(SETQ XPOS (fetch PRXPOS of PRDATA))
[SETQ NEWXPOS (IPLUS XPOS (COND
((EQ CHARCODE (CHARCODE SPACE))
(ffetch PRSPACEWIDTH of PRDATA))
(T (\FGETWIDTH (ffetch PRWIDTHSCACHE of PRDATA)
CHARCODE]
(COND
((AND [IGEQ XPOS (fetch LEFT of (SETQ CLIPPINGREGION (fetch PRClippingRegion
of PRDATA]
(ILEQ NEWXPOS (fetch RIGHT of CLIPPINGREGION))
(IGEQ (fetch PRYPOS of PRDATA)
(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.)
[COND
((NOT (ffetch CHARWASDISPLAYING of PRDATA))
(* Was being clipped, now not)
(freplace CHARWASDISPLAYING of PRDATA with T)
(SHOW.PRESS PRSTREAM) (* SHOW shouldn't be necessary, but ...)
(SETXY.PRESS PRSTREAM XPOS (fetch PRYPOS of PRDATA]
(\BOUT PRSTREAM CHARCODE))
(T (SHOW.PRESS PRSTREAM) (* Don't put out any characters if out of the clipping
region)
(freplace CHARWASDISPLAYING of PRDATA with NIL)))
(replace PRXPOS of PRDATA with NEWXPOS])
(\SETSPACE.PRESS
[LAMBDA (PRSTREAM S) (* rmk: " 3-Dec-84 12:05")
(PROG (ELSTREAM (PRDATA (fetch IMAGEDATA of PRSTREAM)))
(AND (EQ S (ffetch PRSPACEWIDTH of PRDATA))
(RETURN))
(SETQ ELSTREAM (fetch ELSTREAM of (fetch IMAGEDATA of PRSTREAM)))
(if (ILEQ S 2047)
then (\WOUT ELSTREAM (IPLUS (LLSH SetSpaceXShortCode 8)
S))
else (\BOUT ELSTREAM SetSpaceXCode)
(\WOUT ELSTREAM S))
(freplace PRSPACEWIDTH of PRDATA with S])
(\STARTPAGE.PRESS
[LAMBDA (PRSTREAM) (* rmk: "28-Nov-84 09:16")
(* Should be called only when no previous page is open)
(PROG (CFONT HFONT SPACEFACTOR (PRDATA (ffetch IMAGEDATA of PRSTREAM)))
(SETQ CFONT (ffetch PRFONT of PRDATA))
(* Save current font so that \ENTITYSTART.PRESS can make PRFONT be NIL, indicating that there is no actual font at
the beginning of a page)
(\ENTITYSTART.PRESS PRSTREAM)
[COND
((ffetch PRHEADING of PRDATA)
(SETQ SPACEFACTOR (ffetch PRSPACEFACTOR of PRDATA))
(freplace PRSPACEFACTOR of PRDATA with 1)
(SETQ HFONT (ffetch PRHEADINGFONT of PRDATA))
(\DSPFONT.PRESS PRSTREAM HFONT) (* Set up heading font)
[SETXY.PRESS PRSTREAM (ffetch PRLEFT of PRDATA)
(IDIFFERENCE (ffetch PRTOP of PRDATA)
(FONTPROP HFONT (QUOTE ASCENT]
(PRIN3 (ffetch PRHEADING of PRDATA)
PRSTREAM) (* Skip an inch before page number)
(SHOW.PRESS PRSTREAM)
(SETX.PRESS PRSTREAM (IPLUS MICASPERINCH (ffetch PRXPOS of PRDATA)))
(PRIN3 "Page " PRSTREAM)
(PRIN3 (add (ffetch PRPAGENUM of PRDATA)
1)
PRSTREAM)
(NEWLINE.PRESS PRSTREAM) (* Skip 2 lines)
(NEWLINE.PRESS PRSTREAM)
(freplace PRSPACEFACTOR of PRDATA with SPACEFACTOR))
(T (SETXY.PRESS PRSTREAM (ffetch PRLEFT of PRDATA)
(IDIFFERENCE (ffetch PRTOP of PRDATA)
(FONTPROP CFONT (QUOTE ASCENT]
(* Now we set the font to our
(previous) current font)
(\DSPFONT.PRESS PRSTREAM CFONT])
(\STRINGWIDTH.PRESS
[LAMBDA (STREAM STRING RDTBL) (* rmk: "16-Nov-84 11:42")
(* Returns the width of STRING in the press STREAM,
observing spacefactor)
(\STRINGWIDTH.GENERIC STRING (ffetch PRWIDTHSCACHE of (ffetch IMAGEDATA of STREAM))
RDTBL
(ffetch PRSPACEWIDTH of (ffetch IMAGEDATA of STREAM])
(SHOWRECTANGLE.PRESS
[LAMBDA (PRSTREAM WIDTH HEIGHT) (* rmk: "14-Jun-84 19:39")
(PROG [(ELSTREAM (fetch ELSTREAM of (fetch IMAGEDATA of PRSTREAM]
(\BOUT ELSTREAM ShowRectangleCode)
(\WOUT ELSTREAM WIDTH)
(\WOUT ELSTREAM HEIGHT])
)
(* Drawcurve code)
(DEFINEQ
(\ENDVECRUN
[LAMBDA (PRSTREAM HALFVECWIDTH) (* hdj "27-Feb-85 11:52")
(SHOW.PRESS PRSTREAM)
(PROG ((PRDATA (fetch IMAGEDATA of PRSTREAM))
ORIGXPOS ORIGYPOS XPOS YPOS WASDISPLAYING ORIGWASDISPLAYING)
(COND
((NOT (fetch VECMOVINGRIGHT of PRDATA)) (* We've been moving to the left, so it's time to
uncache those characters we saved.)
(SETQ XPOS (fetch VECCURX of PRDATA))
(SETQ YPOS (fetch VECCURY of PRDATA))
(SETQ ORIGXPOS (FIXR (FTIMES MicasPerScan XPOS)))
(* Remember where the end of the line is, so we can
come back here.)
(SETQ ORIGYPOS (FIXR (FTIMES MicasPerScan YPOS)))
[SETQ ORIGWASDISPLAYING (AND (IGEQ XPOS (IPLUS SPRUCEPAPERLEFTSCANS HALFVECWIDTH))
(IGEQ YPOS (IPLUS SPRUCEPAPERBOTTOMSCANS HALFVECWIDTH))
(ILESSP YPOS (IDIFFERENCE SPRUCEPAPERTOPSCANS HALFVECWIDTH)
)
(ILESSP XPOS (IDIFFERENCE SPRUCEPAPERRIGHTSCANS
HALFVECWIDTH]
(SETQ WASDISPLAYING ORIGWASDISPLAYING) (* Decide whether to start out by displaying any
characters or not.)
(COND
(WASDISPLAYING (SETXY.PRESS PRSTREAM ORIGXPOS ORIGYPOS)))
(* We may have been adjusting the X and Y position in
the PRDATA without actually putting out the file
commands)
[for CH in (fetch VECSEGCHARS of PRDATA)
do (COND
[(AND (IGEQ XPOS (IPLUS SPRUCEPAPERLEFTSCANS HALFVECWIDTH))
(IGEQ YPOS (IPLUS SPRUCEPAPERBOTTOMSCANS HALFVECWIDTH))
(ILESSP YPOS (IDIFFERENCE SPRUCEPAPERTOPSCANS HALFVECWIDTH))
(ILESSP XPOS (IDIFFERENCE SPRUCEPAPERRIGHTSCANS HALFVECWIDTH)))
(* We're on-paper. Go ahead and display the character.)
(COND
((NOT WASDISPLAYING) (* We haven't really been displaying characters up to
now--we need to reposition.)
(SHOW.PRESS PRSTREAM)
(SETXY.PRESS PRSTREAM (FIXR (FTIMES MicasPerScan XPOS))
(FIXR (FTIMES MicasPerScan YPOS)))
(SETQ WASDISPLAYING T)))
(\BOUT PRSTREAM (\VECENCODE (IMINUS (CAR CH))
(IMINUS (CDR CH]
(T (* We are off-paper. Stop displaying, and remember that
we took a hiatus)
(SETQ WASDISPLAYING NIL)))
(SETQ XPOS (IDIFFERENCE XPOS (CAR CH)))
(SETQ YPOS (IDIFFERENCE YPOS (CDR CH]
(SHOW.PRESS PRSTREAM)
(SETXY.PRESS PRSTREAM ORIGXPOS ORIGYPOS)
(replace VECWASDISPLAYING of PRDATA with ORIGWASDISPLAYING)))
(replace VECSEGCHARS of PRDATA with NIL])
(\VECENCODE
[LAMBDA (DX DY) (* jds "18-DEC-81 15:48")
(* Given dx and dy in dover pixels, decide which Vector
Font character represents that move, and return it.)
(if (ILESSP 0 DY)
then (IDIFFERENCE (IPLUS 160 DX (IMINUS DY))
(ITIMES 9 (IMAX DX DY)))
else (IDIFFERENCE (IDIFFERENCE (IDIFFERENCE 160 DX)
DY)
(ITIMES 7 (IMAX DX (IMINUS DY])
(\VECPUT
[LAMBDA (PRSTREAM DX DY HALFVECWIDTH) (* rmk: "17-Dec-84 10:15")
(* Send this dx,dy pair to the press file;
hold and reverse any strings which run right-to-left on
the page.)
(PROG ((PRDATA (fetch IMAGEDATA of PRSTREAM))
XPOS YPOS)
(COND
((OR (AND (fetch VECMOVINGRIGHT of PRDATA)
(ILESSP DX 0))
(AND (NOT (fetch VECMOVINGRIGHT of PRDATA))
(ILESSP 0 DX))) (* We switched direction (LEFT->RIGHT or RIGHT->LEFT).
Put out what we've got, and start the new run.)
(\ENDVECRUN PRSTREAM HALFVECWIDTH)
(replace VECMOVINGRIGHT of PRDATA with (NOT (fetch VECMOVINGRIGHT of PRDATA)))
(* Switch the direction we think we're moving.)
))
(SETQ XPOS (fetch VECCURX of PRDATA)) (* In DOVER spots)
(SETQ YPOS (fetch VECCURY of PRDATA))
(replace VECCURX of PRDATA with (IPLUS XPOS DX))
(replace VECCURY of PRDATA with (IPLUS YPOS DY))
(COND
[(fetch VECMOVINGRIGHT of PRDATA) (* We're moving right, and are really putting out
characters.)
(* SPRUCEPAPERTOPSCANS is in dover points)
(COND
((AND (IGEQ YPOS (IPLUS SPRUCEPAPERBOTTOMSCANS HALFVECWIDTH))
(ILESSP YPOS (IDIFFERENCE SPRUCEPAPERTOPSCANS HALFVECWIDTH))
(IGEQ XPOS (IPLUS SPRUCEPAPERLEFTSCANS HALFVECWIDTH))
(ILESSP XPOS (IDIFFERENCE SPRUCEPAPERRIGHTSCANS HALFVECWIDTH)))
(* We're on-paper. Go ahead and display this
character.)
(COND
((NOT (fetch VECWASDISPLAYING of PRDATA))
(* We haven't been displaying.
before really putting out the character,)
(SHOW.PRESS PRSTREAM)
(SETXY.PRESS PRSTREAM (FIXR (FTIMES MicasPerScan XPOS))
(FIXR (FTIMES MicasPerScan YPOS)))
(* So move to where we're emerging onto the paper.)
(replace VECWASDISPLAYING of PRDATA with T)))
(\BOUT PRSTREAM (\VECENCODE DX DY)))
(T (* We're off-page. Remember to do a SETXY when we get
back on.)
(replace VECWASDISPLAYING of PRDATA with NIL]
(T (* We're moving left--and so caching characters for
later. Don't bother making any checks going this way.)
(push (fetch VECSEGCHARS of PRDATA)
(CONS DX DY)) (* Just cache the DX,DY pair)
])
(\VECSKIP
[LAMBDA (PRSTREAM DX DY) (* rmk: "17-Dec-84 10:10")
(* Put out blank space for DX, DY)
(\ENDVECRUN PRSTREAM)
(SETQ VecCurX (IPLUS VecCurX DX))
(SETQ VecCurY (IPLUS VecCurY DY))
(\ENDVECRUN PRSTREAM])
(\VECFONTINIT
[LAMBDA NIL (* rmk: "30-Nov-84 09:01")
(* Initialize \VecFontDir, a list of lists of dummy font descriptors for the ReDraw vector fonts.
The structure is ((round brushes) (square brushes) (horizontal brushes) (vertical brushes)))
(DECLARE (GLOBALVARS \VecFontDir))
(* WIDTHS is a dummy array descriptor so that \DSPFONT.PRESS doesn't get confused. If any real character output were
done with this descriptor in force, the results would be disastrous. But the RESETSAVE in \PRESSCURVE2 should
prevent this.)
(* NOTE: Perhaps we should just use the unit widths
vector for this)
(OR \VecFontDir (SETQ \VecFontDir (for FMLY (WIDTHS ←(ARRAY 256 (QUOTE SMALLP)
1 0))
in (QUOTE (NEWVEC SNEWVEC HNEWVEC VNEWVEC))
collect (for BRUSH in (QUOTE (4 8 16 32 64))
collect (create FONTDESCRIPTOR
FONTDEVICE ←(QUOTE PRESS)
FONTFAMILY ← FMLY
FONTSIZE ← BRUSH
FONTFACE ←(QUOTE (MEDIUM REGULAR
REGULAR))
ROTATION ← 0
\SFWidths ← WIDTHS
FONTAVGCHARWIDTH ← 1])
(\DRAWCIRCLE.PRESS
[LAMBDA (STREAM CENTERX CENTERY RADIUS BRUSH DASHING) (* rmk: "27-Sep-84 17:23")
(PROG [(R2RAD (FIXR (FTIMES RADIUS (CONSTANT (FQUOTIENT (SQRT 2)
2]
(DRAWCURVE (LIST (CREATEPOSITION (IPLUS CENTERX RADIUS)
CENTERY)
(CREATEPOSITION (IPLUS CENTERX R2RAD)
(IPLUS CENTERY R2RAD))
(CREATEPOSITION CENTERX (IPLUS CENTERY RADIUS))
(CREATEPOSITION (IDIFFERENCE CENTERX R2RAD)
(IPLUS CENTERY R2RAD))
(CREATEPOSITION (IDIFFERENCE CENTERX RADIUS)
CENTERY)
(CREATEPOSITION (IDIFFERENCE CENTERX R2RAD)
(IDIFFERENCE CENTERY R2RAD))
(CREATEPOSITION CENTERX (IDIFFERENCE CENTERY RADIUS))
(CREATEPOSITION (IPLUS CENTERX R2RAD)
(IDIFFERENCE CENTERY R2RAD)))
T BRUSH DASHING STREAM))
(MOVETO CENTERX CENTERY STREAM])
(\DRAWCURVE.PRESS
[LAMBDA (PRSTREAM KNOTS CLOSED BRUSH DASHING) (* rmk: "20-Nov-84 13:59")
(* draws a spline curve with a given brush brush.
Knots and brushwidth assumed to be in micas)
[COND
((LISTP KNOTS)
(SHOW.PRESS PRSTREAM)
(PROG [LASTKNOT (DASHLST (AND DASHING (OR (AND (LISTP DASHING)
(EVERY DASHING (FUNCTION FIXP))
DASHING)
(\ILLEGAL.ARG DASHING]
(* The above makes sure that DASHING is a list of
numbers.)
[OR (CDR KNOTS)
(SETQ KNOTS (LIST (CAR KNOTS)
(CAR KNOTS] (* Handle the trival one-knot case.)
(COND
((AND (NULL DASHING)
(EQ 2 (LENGTH KNOTS))
(\DRAWCURVE.PRESS.LINE PRSTREAM (fetch XCOORD of (CAR KNOTS))
(fetch YCOORD of (CAR KNOTS))
(fetch XCOORD of (CADR KNOTS))
(fetch YCOORD of (CADR KNOTS))
BRUSH DASHING))
(* There were only two knots, and no dashing.
\DRAWCURVE.PRESS.LINE returned T if it managed to draw
the line the fast way.)
(* Have to move to the endpoint of the line.)
)
(T (* Otherwise, use the full-strength curve drawer.)
(\PRESSCURVE2 PRSTREAM (PARAMETRICSPLINE [for KNOT in KNOTS
collect
(CREATEPOSITION
(FIXR (FTIMES (fetch XCOORD
of KNOT)
ScansPerMica))
(FIXR (FTIMES (fetch YCOORD
of KNOT)
ScansPerMica]
CLOSED)
DASHING
(\GETBRUSHFONT.PRESS BRUSH))
(* This already leaves the current position at the
endpoint of the curve.)
))
(SETQ LASTKNOT (CAR (LAST KNOTS)))
(SETXY.PRESS PRSTREAM (fetch XCOORD of LASTKNOT)
(fetch YCOORD of LASTKNOT]
PRSTREAM])
(\DRAWCURVE.PRESS.LINE
[LAMBDA (PRSTREAM X1 Y1 X2 Y2 BRUSH DASHING) (* rmk: "17-Dec-84 10:05")
(* Returns T if this is a horizontal or vertical line,
hence can be drawn as a rectangle.)
(PROG (WIDTH BACKOFF LEFT BOTTOM DIST LB TR (SHAPE (QUOTE ROUND)))
(SETQ WIDTH (OR (COND
((LISTP BRUSH)
(SETQ SHAPE (CAR BRUSH))
(CADR BRUSH))
(T BRUSH))
1))
[SELECTQ SHAPE
(BUTT (SETQ BACKOFF 0))
(ROUND (RETURN NIL))
(PROGN (SETQ BACKOFF (IQUOTIENT WIDTH 2]
(* For butt ends, we want the line to end at the given
coordinate position)
(* LB is left or bottom, TR is top or right, depending
on orientation)
(COND
((EQP X1 X2) (* Vertical line)
(SETQ LEFT (IDIFFERENCE X1 (IQUOTIENT WIDTH 2)))
(* Off to the left or right?)
(AND (OR (ILESSP LEFT SPRUCEPAPERLEFTMICAS)
(IGREATERP (IPLUS LEFT WIDTH)
SPRUCEPAPERRIGHTMICAS))
(RETURN T))
(COND
((IGREATERP Y1 Y2)
(SETQ LB Y2)
(SETQ TR Y1))
(T (SETQ LB Y1)
(SETQ TR Y2)))
(SETQ LB (IMAX SPRUCEPAPERBOTTOMMICAS (IDIFFERENCE LB BACKOFF)))
(* Clip to page)
(SETQ TR (IMIN SPRUCEPAPERTOPMICAS (IPLUS TR BACKOFF)))
(SETQ DIST (IDIFFERENCE TR LB))
(OR (IGREATERP DIST 0)
(RETURN T))
(SETXY.PRESS PRSTREAM LEFT LB) (* Move to where the line starts)
(SHOWRECTANGLE.PRESS PRSTREAM WIDTH DIST) (* Draw the rectangle that will do the job.)
(RETURN T))
((EQP Y1 Y2) (* Horizontal line)
(SETQ BOTTOM (IDIFFERENCE Y1 (IQUOTIENT WIDTH 2)))
(* Off to the bottom or top?)
(AND (OR (ILESSP BOTTOM SPRUCEPAPERBOTTOMMICAS)
(IGREATERP (IPLUS BOTTOM WIDTH)
SPRUCEPAPERTOPMICAS))
(RETURN T))
(COND
((IGREATERP X1 X2)
(SETQ LB X2)
(SETQ TR X1))
(T (SETQ LB X1)
(SETQ TR X2)))
(SETQ LB (IMAX SPRUCEPAPERLEFTMICAS (IDIFFERENCE LB BACKOFF)))
(* Clip to page)
(SETQ TR (IMIN SPRUCEPAPERRIGHTMICAS (IPLUS TR BACKOFF)))
(SETQ DIST (IDIFFERENCE TR LB))
(OR (IGREATERP DIST 0)
(RETURN T))
(SETXY.PRESS PRSTREAM LB BOTTOM) (* Move to where the line starts)
(SHOWRECTANGLE.PRESS PRSTREAM DIST WIDTH) (* Draw the rectangle that will do the job.)
(RETURN T])
(\DRAWELLIPSE.PRESS
[LAMBDA (PRSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING)
(* rmk: "23-Aug-84 10:51")
(PROG [(SINOR (COND
(ORIENTATION (SIN ORIENTATION))
(T 0.0)))
(COSOR (COND
(ORIENTATION (COS ORIENTATION))
(T 1.0]
(\DRAWCURVE.PRESS PRSTREAM [LIST (CREATEPOSITION (PLUS CENTERX (FTIMES COSOR
SEMIMAJORRADIUS))
(PLUS CENTERY (FTIMES SINOR
SEMIMAJORRADIUS)))
(CREATEPOSITION (DIFFERENCE CENTERX (FTIMES SINOR
SEMIMINORRADIUS))
(PLUS CENTERY (FTIMES COSOR
SEMIMINORRADIUS)))
(CREATEPOSITION (DIFFERENCE CENTERX (FTIMES COSOR
SEMIMAJORRADIUS))
(DIFFERENCE CENTERY (FTIMES SINOR
SEMIMAJORRADIUS)))
(CREATEPOSITION (PLUS CENTERX (FTIMES SINOR
SEMIMINORRADIUS))
(DIFFERENCE CENTERY (FTIMES COSOR
SEMIMINORRADIUS]
T BRUSH DASHING)
(MOVETO CENTERX CENTERY PRSTREAM])
(\GETBRUSHFONT.PRESS
[LAMBDA (BRUSH) (* rmk: "17-Dec-84 10:13")
(\VECFONTINIT)
(PROG [(LIST1 (SELECTQ (CAR (LISTP BRUSH))
(ROUND (CAR \VecFontDir))
(SQUARE (CADR \VecFontDir))
(HORIZONTAL (CADDR \VecFontDir))
(VERTICAL (CADDDR \VecFontDir))
(BUTT (CAR \VecFontDir))
(CAR \VecFontDir]
(AND (LISTP BRUSH)
(SETQ BRUSH (CADR BRUSH)))
(RETURN (SELECTQ (FIXR (FTIMES (OR BRUSH 1)
PointsPerMica))
((0 1)
(CAR LIST1))
(2 (CADR LIST1))
((3 4 5)
(CADDR LIST1))
((6 7 8)
(CADDDR LIST1))
(CADDDR LIST1])
(\PRESSCURVE2
[LAMBDA (PRSTREAM SPLINE DASHING BRUSHFONT) (* hdj "13-Mar-85 18:07")
(* Given a spline curve and a font, draw the lines to
PRSTREAM)
(RESETLST (RESETSAVE NIL (LIST (QUOTE DSPFONT)
(DSPFONT BRUSHFONT PRSTREAM)
PRSTREAM))
(\BOUT (fetch ELSTREAM of (fetch IMAGEDATA of PRSTREAM))
ResetSpaceCode) (* because the space code shouldn't be interpreted
specially when we are drawing in the vector font)
(PROG ((XPOLY (create POLYNOMIAL))
(X'POLY (create POLYNOMIAL))
(YPOLY (create POLYNOMIAL))
(Y'POLY (create POLYNOMIAL))
(X (fetch (SPLINE SPLINEX) of SPLINE))
(Y (fetch (SPLINE SPLINEY) of SPLINE))
(X'(fetch (SPLINE SPLINEDX) of SPLINE))
(Y'(fetch (SPLINE SPLINEDY) of SPLINE))
(X''(fetch (SPLINE SPLINEDDX) of SPLINE))
(Y''(fetch (SPLINE SPLINEDDY) of SPLINE))
(X'''(fetch (SPLINE SPLINEDDDX) of SPLINE))
(Y'''(fetch (SPLINE SPLINEDDDY) of SPLINE))
(#KNOTS (fetch #KNOTS of SPLINE))
(X0 (ELT (fetch (SPLINE SPLINEX) of SPLINE)
1))
(Y0 (ELT (fetch (SPLINE SPLINEY) of SPLINE)
1))
IX IY DX DY XT YT X'T Y'T NEWXT NEWYT XDIFF YDIFF XWALLDT YWALLDT DUPLICATEKNOT
EXTRANEOUS TT NEWT DELTA DASHON DASHLST DASHCNT HALFVECWIDTH PUTDX EXTRADX PUTDY
EXTRADY)
(SETQ HALFVECWIDTH (FONTPROP BRUSHFONT (QUOTE SIZE)))
(* Half the width of the brush, in dots.
Used to help decide when the line we're drawing goes
off-paper.)
(SETQ DASHON T) (* These are initialized outside the prog-bindings
cause the compiler can't hack so many initialized
variables)
(SETQ DASHLST DASHING)
(SETQ DASHCNT (CAR DASHING))
(SETXY.PRESS PRSTREAM (FIXR (FTIMES X0 MicasPerScan))
(FIXR (FTIMES Y0 MicasPerScan)))
(* Move to the first knot on the curve)
(replace VECMOVINGRIGHT of (fetch IMAGEDATA of PRSTREAM) with T)
(* Start by assuming we're moving in increasing X
(since the vector fonts only have strokes that work in
that direction))
(replace VECWASDISPLAYING of (fetch IMAGEDATA of PRSTREAM)
with (AND (GEQ X0 0)
(GEQ Y0 0)))
(replace VECSEGCHARS of (fetch IMAGEDATA of PRSTREAM) with NIL)
(replace VECCURX of (fetch IMAGEDATA of PRSTREAM) with X0)
(* And set the current X and Y positions, denominated
in dover spots)
(replace VECCURY of (fetch IMAGEDATA of PRSTREAM) with Y0)
(* Set up initial values in vec variables, perform
SetX/SetY.)
(SETQ TT 0.0)
(SETQ DELTA 16)
(SETQ IX (FIXR X0))
(SETQ IY (FIXR Y0))
[for KNOT# from 1 to (SUB1 #KNOTS)
do (LOADPOLY XPOLY X'POLY (ELT X''' KNOT#)
(ELT X'' KNOT#)
(ELT X' KNOT#)
(ELT X KNOT#)) (* Set up the polynomials that describe X and X' over
this segment)
(LOADPOLY YPOLY Y'POLY (ELT Y''' KNOT#)
(ELT Y'' KNOT#)
(ELT Y' KNOT#)
(ELT Y KNOT#)) (* Set up the polynomials that describe Y and Y' over
this segment)
(SETQ XT (POLYEVAL TT XPOLY 3)) (* XT ← X (t) --Evaluate the next point)
(SETQ YT (POLYEVAL TT YPOLY 3)) (* YT ← Y (t))
(COND
[(NOT (IEQP KNOT# (SUB1 #KNOTS)))
(* This isn't the last knot.
Check to see if the next knot in line is a duplicated
knot.)
(SETQ DUPLICATEKNOT (AND (EQP (ELT X (ADD1 KNOT#))
(ELT X (IPLUS KNOT# 2)))
(EQP (ELT Y (ADD1 KNOT#))
(ELT Y (IPLUS KNOT# 2]
(T (SETQ DUPLICATEKNOT NIL)))
[until (GEQ TT 1.0)
do
(* Run the parameter, TT, from 0.0 up to 1.0. That moves the X and Y locations smoothly from this knot to the next
one.)
(SETQ X'T (POLYEVAL TT X'POLY 2))
(* X'T ← X' (t))
(SETQ Y'T (POLYEVAL TT Y'POLY 2))
(* Y'T ← Y' (t))
(COND
((EQP X'T 0.0) (* Never let X' really get to 0.0 -- things become
ill-conditioned there.)
(SETQ X'T .0005)))
(COND
((EQP Y'T 0.0) (* Likewise Y'.)
(SETQ Y'T .0005)))
[COND
((FGTP X'T 0.0) (* If X' is positive, we'll try moving in the +X
direction)
(SETQ DX DELTA))
(T (* If not, we'll try the -X direction.)
(SETQ DX (IMINUS DELTA]
[COND
((FGTP Y'T 0.0) (* Likewise, if Y' is positive, try moving by DELTA in
the +Y direction)
(SETQ DY DELTA))
(T (SETQ DY (IMINUS DELTA]
(SETQ XWALLDT (FQUOTIENT (FDIFFERENCE (IPLUS IX DX)
XT)
X'T))
(* Compute a dT, based on moving by DELTA in X.)
(SETQ YWALLDT (FQUOTIENT (FDIFFERENCE (IPLUS IY DY)
YT)
Y'T))
(* And a dT based on moving by DELTA in Y.)
[COND
((FLESSP XWALLDT YWALLDT)
(* Use the smaller of the two dT's. In this case, dT for X was smaller, so compute a new DY as depending on DX.)
(SETQ NEWT (FPLUS TT XWALLDT))
(SETQ DY (IDIFFERENCE (FIXR (FPLUS YT (FTIMES XWALLDT Y'T)))
IY)))
(T (* Changing Y gave the smaller dT.
Compute a new DX, as though it depended on DY.)
(SETQ NEWT (FPLUS TT YWALLDT))
(SETQ DX (IDIFFERENCE (FIXR (FPLUS XT (FTIMES YWALLDT X'T)))
IX]
(SETQ PUTDX DX)
(SETQ EXTRADX 0)
(SETQ PUTDY DY)
(SETQ EXTRADY 0)
[COND
((IGREATERP DX 16)
(SETQ PUTDX 16)
(SETQ EXTRADX (IDIFFERENCE DX 16]
[COND
((IGREATERP -16 DX)
(SETQ PUTDX -16)
(SETQ EXTRADX (IPLUS DX 16]
[COND
((IGREATERP DY 16)
(SETQ PUTDY 16)
(SETQ EXTRADY (IDIFFERENCE DY 16]
[COND
((IGREATERP -16 DY)
(SETQ PUTDY -16)
(SETQ EXTRADY (IPLUS DY 16]
(COND
([AND (FGTP NEWT 1.0)
(OR DUPLICATEKNOT (EQ KNOT# (SUB1 #KNOTS]
(SETQ NEWT 1.0)))
(SETQ NEWXT (POLYEVAL NEWT XPOLY 3))
(* New XT ← X (new t))
(SETQ NEWYT (POLYEVAL NEWT YPOLY 3))
(* New YT ← Y (new t))
(SETQ XDIFF (ABS (FDIFFERENCE (IPLUS IX DX)
NEWXT)))
(SETQ YDIFF (ABS (FDIFFERENCE (IPLUS IY DY)
NEWYT)))
(COND
((AND (IGREATERP DELTA 1)
(OR (FGTP XDIFF 1.0)
(FGTP YDIFF 1.0)))
(* If we're more than a dover spot off where we'd expect to be because of the size of DELTA--and if there's room to
make DELTA smaller--then try DELTA←DELTA/2)
(SETQ DELTA (LRSH DELTA 1)))
(T (* No, this estimate is close enough.
Put out a vector segment based on it, and move to the
new TT.)
(\VECPUT PRSTREAM PUTDX PUTDY HALFVECWIDTH)
(* Print out a stroke using the vector font.)
(COND
((OR (NEQ EXTRADX 0)
(NEQ EXTRADY 0))
(* If, actually, it was too big for one stroke, use
another.)
(\VECPUT PRSTREAM EXTRADX EXTRADY HALFVECWIDTH)))
(SETQ IX (IPLUS IX DX))
(* Our new current location, in Dover spots)
(SETQ IY (IPLUS IY DY))
(SETQ TT NEWT) (* Set TT to its new value)
(SETQ XT NEWXT) (* And set the new floating-point values for X
(t) and Y (t).)
(SETQ YT NEWYT)
(COND
((AND (ILESSP DELTA 16)
(OR (FLESSP XDIFF .5)
(FLESSP YDIFF .5)))
(* If we were especially close, try making DELTA larger
for the next go round.)
(SETQ DELTA (LLSH DELTA 1]
(SETQ TT (FDIFFERENCE TT 1.0))
(* Having moved past a knot, back the value of the parameter TT back down. However, don't set it to 0.0--let's try
to keep the line going from where it got to in passing the last knot.)
(COND
(DUPLICATEKNOT
(* This next knot is a duplicate. Skip over it, and start from the following knot. This will avoid odd problems
trying to go nowhere while obeying the constraints of X' and Y' at that knot--since it's a duplicate, X' and Y' are
discontinuous there.)
(add KNOT# 1]
(\ENDVECRUN PRSTREAM HALFVECWIDTH])
)
(RPAQ? \VecFontDir )
(DECLARE: EVAL@COMPILE
(RPAQQ \MicasPerInch 2540)
(CONSTANTS (\MicasPerInch 2540))
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(RPAQQ ScansPerIn 384)
(RPAQQ PointsPerIn 72.27)
(RPAQ MicasPerScan (FQUOTIENT \MicasPerInch ScansPerIn))
(RPAQ ScansPerMica (FQUOTIENT ScansPerIn \MicasPerInch))
(RPAQ ScansPerPoint (FQUOTIENT ScansPerIn PointsPerIn))
(RPAQ PointsPerScan (FQUOTIENT PointsPerIn ScansPerIn))
(RPAQ MicasPerPoint (FQUOTIENT \MicasPerInch PointsPerIn))
(RPAQ PointsPerMica (FQUOTIENT PointsPerIn \MicasPerInch))
(RPAQQ SPRUCEPAPERTOPSCANS 4096)
(RPAQ SPRUCEPAPERTOPMICAS (FIX (FQUOTIENT (FTIMES SPRUCEPAPERTOPSCANS \MicasPerInch)
ScansPerIn)))
(RPAQ SPRUCEPAPERRIGHTMICAS (FIX (FTIMES 8.5 \MicasPerInch)))
(RPAQ SPRUCEPAPERRIGHTSCANS (FIX (FTIMES 8.5 ScansPerIn)))
(RPAQQ SPRUCEPAPERBOTTOMSCANS 0)
(RPAQQ SPRUCEPAPERBOTTOMMICAS 0)
(RPAQQ SPRUCEPAPERLEFTSCANS 0)
(RPAQQ SPRUCEPAPERLEFTMICAS 0)
(CONSTANTS (ScansPerIn 384)
(PointsPerIn 72.27)
(MicasPerScan (FQUOTIENT \MicasPerInch ScansPerIn))
(ScansPerMica (FQUOTIENT ScansPerIn \MicasPerInch))
(ScansPerPoint (FQUOTIENT ScansPerIn PointsPerIn))
(PointsPerScan (FQUOTIENT PointsPerIn ScansPerIn))
(MicasPerPoint (FQUOTIENT \MicasPerInch PointsPerIn))
(PointsPerMica (FQUOTIENT PointsPerIn \MicasPerInch))
(SPRUCEPAPERTOPSCANS 4096)
(SPRUCEPAPERTOPMICAS (FIX (FQUOTIENT (FTIMES SPRUCEPAPERTOPSCANS \MicasPerInch)
ScansPerIn)))
(SPRUCEPAPERRIGHTMICAS (FIX (FTIMES 8.5 \MicasPerInch)))
(SPRUCEPAPERRIGHTSCANS (FIX (FTIMES 8.5 ScansPerIn)))
(SPRUCEPAPERBOTTOMSCANS 0)
(SPRUCEPAPERBOTTOMMICAS 0)
(SPRUCEPAPERLEFTSCANS 0)
(SPRUCEPAPERLEFTMICAS 0))
)
)
(DEFINEQ
(\PRESSINIT
[LAMBDA NIL (* hdj "12-Mar-85 12:32")
(DECLARE (GLOBALVARS \PRESSIMAGEOPS))
(SETQ \PRESSIMAGEOPS (create IMAGEOPS
IMAGETYPE ←(QUOTE PRESS)
IMCLOSEFN ←(FUNCTION \CLOSEF.PRESS)
IMXPOSITION ←(FUNCTION \DSPXPOSITION.PRESS)
IMYPOSITION ←(FUNCTION \DSPYPOSITION.PRESS)
IMFONT ←(FUNCTION \DSPFONT.PRESS)
IMLEFTMARGIN ←(FUNCTION \DSPLEFTMARGIN.PRESS)
IMRIGHTMARGIN ←(FUNCTION \DSPRIGHTMARGIN.PRESS)
IMLINEFEED ←(FUNCTION \DSPLINEFEED.PRESS)
IMDRAWLINE ←(FUNCTION \DRAWLINE.PRESS)
IMDRAWCURVE ←(FUNCTION \DRAWCURVE.PRESS)
IMDRAWCIRCLE ←(FUNCTION \DRAWCIRCLE.PRESS)
IMDRAWELLIPSE ←(FUNCTION \DRAWELLIPSE.PRESS)
IMFILLCIRCLE ←[FUNCTION (LAMBDA (STREAM)
(\UNIMPIMAGEOP STREAM (QUOTE FILLCIRCLE]
IMBLTSHADE ←(FUNCTION \BLTSHADE.PRESS)
IMBITBLT ←(FUNCTION \BITBLT.PRESS)
IMSCALE ←[FUNCTION (LAMBDA NIL
(CONSTANT (FQUOTIENT MICASPERINCH 72]
IMTERPRI ←(FUNCTION NEWLINE.PRESS)
IMBOTTOMMARGIN ←(FUNCTION \DSPBOTTOMMARGIN.PRESS)
IMTOPMARGIN ←(FUNCTION \DSPTOPMARGIN.PRESS)
IMFONTCREATE ←(QUOTE PRESS)
IMNEWPAGE ←(FUNCTION NEWPAGE.PRESS)
IMSPACEFACTOR ←(FUNCTION \DSPSPACEFACTOR.PRESS)
IMSTRINGWIDTH ←(FUNCTION \STRINGWIDTH.PRESS)
IMCHARWIDTH ←(FUNCTION \CHARWIDTH.PRESS)
IMBITMAPSIZE ←(FUNCTION \BITMAPSIZE.PRESS)
IMCLIPPINGREGION ←(FUNCTION \DSPCLIPPINGREGION.PRESS)
IMSCALEDBITBLT ←(FUNCTION \SCALEDBITBLT.PRESS])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(\PRESSINIT)
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(DATATYPE PRESSDATA (PRHEADING (* The string to be printed atop each page.)
PRHEADINGFONT (* Font to print the heading in)
PRXPOS (* Current X position)
PRYPOS (* Current Y position)
PRFONT (* Current font)
PRCURRFDE PRESSFONTDIR PRWIDTHSCACHE PRCOLOR PRLINEFEED PRPAGESTATE
PDSTREAM ELSTREAM XPRPAGEREGION PRDOCNAME (PRLEFT WORD)
(* Page left margin)
(PRBOTTOM WORD) (* Page bottom margin)
(PRRIGHT WORD) (* Page right margin)
(PRTOP WORD) (* Page top margin)
(PRPAGENUM WORD) (* Current Page number)
(PRNEXTFONT# BYTE)
(PRMAXFONTSET BYTE)
(PRPARTSTART INTEGER)
(DLSTARTBYTE INTEGER)
(ELSTARTBYTE INTEGER)
(STARTCHARBYTE INTEGER)
(VECMOVINGRIGHT FLAG) (* If we're drawing a curve with vector fonts, are we
moving to the right?)
(VECWASDISPLAYING FLAG) (* Used during curve/line clipping to remember whether
we were on-screen or not, so we know when to force a
SETXY.)
VECSEGCHARS (* Cache for vector characters while we're moving to
the left.)
VECCURX (* Current X position within vector code, in Dover
spots)
VECCURY (* Current Y position with vector code, in Dover spots)
PRSPACEFACTOR PRSPACEWIDTH (CHARWASDISPLAYING FLAG)
(* Says whether we have been printing characters inside
the clipping region)
PRClippingRegion
(* The edges of the paper, as far as PRESS is concerned. Used to protect SPRUCE users who get killed when the image
goes off-paper)
)
PRSPACEFACTOR ← 1 PRXPOS ← 0 PRYPOS ← 0
(* We assume that the origin is translated to the
bottom-left of the page region)
PRClippingRegion ←(create REGION
LEFT ← SPRUCEPAPERLEFTMICAS
BOTTOM ← SPRUCEPAPERBOTTOMMICAS
WIDTH ←(DIFFERENCE SPRUCEPAPERRIGHTMICAS
SPRUCEPAPERLEFTMICAS)
HEIGHT ← 29210)
[ACCESSFNS ((PRWIDTH (IDIFFERENCE (fetch (PRESSDATA PRRIGHT) of DATUM)
(fetch (PRESSDATA PRLEFT) of DATUM)))
(PRHEIGHT (IDIFFERENCE (fetch (PRESSDATA PRTOP) of DATUM)
(fetch (PRESSDATA PRBOTTOM) of DATUM)))
(PRPAGEREGION (fetch (PRESSDATA XPRPAGEREGION) of DATUM)
(PROGN (replace (PRESSDATA XPRPAGEREGION) of DATUM
with NEWVALUE)
(replace (PRESSDATA PRLEFT) of DATUM
with (fetch (REGION LEFT) of NEWVALUE))
(replace (PRESSDATA PRBOTTOM) of DATUM
with (fetch (REGION BOTTOM) of NEWVALUE))
(replace (PRESSDATA PRRIGHT) of DATUM
with (IPLUS (fetch (REGION LEFT)
of NEWVALUE)
(fetch (REGION WIDTH)
of NEWVALUE)))
(replace (PRESSDATA PRTOP) of DATUM
with (IPLUS (fetch (REGION BOTTOM)
of NEWVALUE)
(fetch (REGION HEIGHT)
of NEWVALUE])
(RECORD FONTDIRENTRY (DESCR FONT# FONTSET#))
]
(/DECLAREDATATYPE (QUOTE PRESSDATA)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD
WORD BYTE BYTE FIXP FIXP FIXP FIXP FLAG FLAG POINTER POINTER
POINTER POINTER POINTER FLAG POINTER)))
)
(/DECLAREDATATYPE (QUOTE PRESSDATA)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD
WORD BYTE BYTE FIXP FIXP FIXP FIXP FLAG FLAG POINTER POINTER
POINTER POINTER POINTER FLAG POINTER)))
(RPAQ? DEFAULTPAGEREGION (CREATEREGION 2794 1905 16256 24765))
(RPAQ? PRESSBITMAPREGION (CREATEREGION 1270 1270 (FIX (TIMES 7.5 \MicasPerInch))
(TIMES 10 \MicasPerInch)))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DEFAULTPAGEREGION)
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(RPAQQ BYTESPERRECORD 512)
(RPAQQ LISPENTITYTYPE 6)
(RPAQ MICASPERINCH \MicasPerInch)
(CONSTANTS (BYTESPERRECORD 512)
(LISPENTITYTYPE 6)
(MICASPERINCH \MicasPerInch))
)
(RPAQQ PRESSOPS (SetX SetY ShowCharacters ShowCharactersShortCode SkipCharactersShortCode
ShowCharactersAndSkipCode SetSpaceXShortCode SetSpaceYShortCode FontCode
SkipControlBytesImmediateCode AlternativeCode OnlyOnCopyCode SetXCode SetYCode
ShowCharactersCode SkipCharactersCode SkipControlBytesCode
ShowCharacterImmediateCode SetSpaceXCode SetSpaceYCode ResetSpaceCode SpaceCode
SetBrightnessCode SetHueCode SetSaturationCode ShowObjectCode ShowDotsCode
ShowDotsOpaqueCode ShowRectangleCode NopCode))
(DECLARE: EVAL@COMPILE
(RPAQQ SetX 0)
(RPAQQ SetY 1)
(RPAQQ ShowCharacters 2)
(RPAQQ ShowCharactersShortCode 0)
(RPAQQ SkipCharactersShortCode 40Q)
(RPAQQ ShowCharactersAndSkipCode 100Q)
(RPAQQ SetSpaceXShortCode 140Q)
(RPAQQ SetSpaceYShortCode 150Q)
(RPAQQ FontCode 160Q)
(RPAQQ SkipControlBytesImmediateCode 353Q)
(RPAQQ AlternativeCode 354Q)
(RPAQQ OnlyOnCopyCode 355Q)
(RPAQQ SetXCode 356Q)
(RPAQQ SetYCode 357Q)
(RPAQQ ShowCharactersCode 360Q)
(RPAQQ SkipCharactersCode 361Q)
(RPAQQ SkipControlBytesCode 362Q)
(RPAQQ ShowCharacterImmediateCode 363Q)
(RPAQQ SetSpaceXCode 364Q)
(RPAQQ SetSpaceYCode 365Q)
(RPAQQ ResetSpaceCode 366Q)
(RPAQQ SpaceCode 367Q)
(RPAQQ SetBrightnessCode 370Q)
(RPAQQ SetHueCode 371Q)
(RPAQQ SetSaturationCode 372Q)
(RPAQQ ShowObjectCode 373Q)
(RPAQQ ShowDotsCode 374Q)
(RPAQQ ShowDotsOpaqueCode 375Q)
(RPAQQ ShowRectangleCode 376Q)
(RPAQQ NopCode 377Q)
(CONSTANTS SetX SetY ShowCharacters ShowCharactersShortCode SkipCharactersShortCode
ShowCharactersAndSkipCode SetSpaceXShortCode SetSpaceYShortCode FontCode
SkipControlBytesImmediateCode AlternativeCode OnlyOnCopyCode SetXCode SetYCode
ShowCharactersCode SkipCharactersCode SkipControlBytesCode ShowCharacterImmediateCode
SetSpaceXCode SetSpaceYCode ResetSpaceCode SpaceCode SetBrightnessCode SetHueCode
SetSaturationCode ShowObjectCode ShowDotsCode ShowDotsOpaqueCode ShowRectangleCode NopCode)
)
)
(DEFINEQ
(MAKEPRESS
[LAMBDA (FILE PFILE FONTS HEADING TABS) (* rmk: "14-Sep-84 12:01")
(TEXTTOIMAGEFILE FILE PFILE (QUOTE PRESS)
FONTS HEADING TABS])
(PRESSFILEP
[LAMBDA (FILE) (* rmk: " 1-DEC-82 22:27")
(* Returns FILE if it looks like a Press file)
(AND (SETQ FILE (FINDFILE FILE))
(PROG [(LEN (GETFILEINFO FILE (QUOTE LENGTH]
(AND (NOT (ZEROP LEN))
(EVENP LEN BYTESPERRECORD)
[RESETLST [COND
[(OPENP FILE (QUOTE INPUT))
(RESETSAVE NIL (LIST (QUOTE SETFILEPTR)
FILE
(GETFILEPTR FILE]
(T (RESETSAVE (OPENFILE FILE (QUOTE INPUT)
(QUOTE OLD)
10Q)
(QUOTE (PROGN (CLOSEF? OLDVALUE]
(SETFILEPTR FILE (IDIFFERENCE LEN BYTESPERRECORD))
(IEQP 65057Q (\WIN (\GETOFD FILE (QUOTE INPUT]
(RETURN FILE])
(PRESS.BITMAPSCALE
[LAMBDA (WIDTH HEIGHT) (* gbn "16-Sep-84 18:50")
(MIN (FQUOTIENT (TIMES (fetch HEIGHT of PRESSBITMAPREGION)
PointsPerMica)
HEIGHT)
(FQUOTIENT (TIMES (fetch WIDTH of PRESSBITMAPREGION)
PointsPerMica)
WIDTH)
(PROG1 2 (* MAXPRESSRATIO)])
)
(ADDTOVAR IMAGESTREAMTYPES (PRESS (OPENSTREAM OPENPRSTREAM)
(FONTCREATE \CREATEPRESSFONT)
(FONTSAVAILABLE \SEARCHPRESSFONTS)))
(ADDTOVAR PRINTERTYPES ((PRESS SPRUCE PENGUIN DOVER)
(CANPRINT (PRESS))
(STATUS PUP.PRINTER.STATUS)
(PROPERTIES PUP.PRINTER.PROPERTIES)
(SEND EFTP)
(BITMAPSCALE NIL)
(BITMAPFILE (PRESSBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION TITLE)))
((FULLPRESS RAVEN)
(* same as PRESS but can scale bitmaps)
(CANPRINT (PRESS))
(STATUS TRUE)
(PROPERTIES NILL)
(SEND EFTP)
(BITMAPSCALE PRESS.BITMAPSCALE)
(BITMAPFILE (FULLPRESSBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION TITLE))))
(ADDTOVAR PRINTFILETYPES [PRESS (TEST PRESSFILEP)
(EXTENSION (PRESS))
(CONVERSION (TEXT MAKEPRESS TEDIT
(LAMBDA (FILE PFILE FONTS HEADING)
(SETQ FILE (OPENTEXTSTREAM FILE))
(TEDIT.FORMAT.HARDCOPY FILE PFILE T NIL NIL
NIL (QUOTE PRESS))
(CLOSEF? FILE)
PFILE])
(PUTPROPS PRESS COPYRIGHT ("Xerox Corporation" 3675Q 3676Q 3677Q 3700Q 3701Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (10301Q 43543Q (\SEARCHPRESSFONTS 10313Q . 12252Q) (\GETPRESSFONTNAMES 12254Q . 17620Q)
(\PRESSFAMILYCODELST 17622Q . 21445Q) (\DECODEPRESSFACEBYTE 21447Q . 23562Q) (\CREATEPRESSFONT 23564Q
. 43541Q)) (44133Q 72057Q (PRESSBITMAP 44145Q . 51071Q) (FULLPRESSBITMAP 51073Q . 55622Q) (SHOWREGION
55624Q . 57026Q) (SHOWPRESSBITMAPREGION 57030Q . 57527Q) (PRESSWINDOW 57531Q . 62006Q) (WINDOW.BITMAP
62010Q . 63005Q) (\WRITEPRESSBITMAP 63007Q . 72055Q)) (72060Q 74362Q (\BCPLSOUT.PRESS 72072Q . 73075Q
) (\PAGEPAD.PRESS 73077Q . 74360Q)) (74363Q 114060Q (\ENTITYEND.PRESS 74375Q . 100536Q) (
\PARTEND.PRESS 100540Q . 102636Q) (\ENTITYSTART.PRESS 102640Q . 105666Q) (SETX.PRESS 105670Q . 106762Q
) (SETXY.PRESS 106764Q . 110302Q) (SETY.PRESS 110304Q . 111217Q) (SHOW.PRESS 111221Q . 114056Q)) (
114061Q 174441Q (OPENPRSTREAM 114073Q . 121031Q) (\BITBLT.PRESS 121033Q . 123114Q) (\BLTSHADE.PRESS
123116Q . 124457Q) (\SCALEDBITBLT.PRESS 124461Q . 126554Q) (\BITMAPSIZE.PRESS 126556Q . 127403Q) (
\CHARWIDTH.PRESS 127405Q . 130436Q) (\CLOSEF.PRESS 130440Q . 136372Q) (\DRAWLINE.PRESS 136374Q .
137054Q) (\ENDPAGE.PRESS 137056Q . 140177Q) (NEWLINE.PRESS 140201Q . 141405Q) (NEWPAGE.PRESS 141407Q
. 141674Q) (SETUPFONTS.PRESS 141676Q . 143377Q) (\DEFINEFONT.PRESS 143401Q . 144664Q) (
\DSPBOTTOMMARGIN.PRESS 144666Q . 145355Q) (\DSPCLIPPINGREGION.PRESS 145357Q . 146523Q) (\DSPFONT.PRESS
146525Q . 152002Q) (\DSPLEFTMARGIN.PRESS 152004Q . 152550Q) (\DSPLINEFEED.PRESS 152552Q . 153623Q) (
\DSPRIGHTMARGIN.PRESS 153625Q . 154374Q) (\DSPSPACEFACTOR.PRESS 154376Q . 155464Q) (
\DSPTOPMARGIN.PRESS 155466Q . 156144Q) (\DSPXPOSITION.PRESS 156146Q . 156602Q) (\DSPYPOSITION.PRESS
156604Q . 157240Q) (\FIXLINELENGTH.PRESS 157242Q . 160630Q) (\OUTCHARFN.PRESS 160632Q . 165636Q) (
\SETSPACE.PRESS 165640Q . 167026Q) (\STARTPAGE.PRESS 167030Q . 173016Q) (\STRINGWIDTH.PRESS 173020Q .
173742Q) (SHOWRECTANGLE.PRESS 173744Q . 174437Q)) (174475Q 262532Q (\ENDVECRUN 174507Q . 202615Q) (
\VECENCODE 202617Q . 203677Q) (\VECPUT 203701Q . 212105Q) (\VECSKIP 212107Q . 212655Q) (\VECFONTINIT
212657Q . 215366Q) (\DRAWCIRCLE.PRESS 215370Q . 217304Q) (\DRAWCURVE.PRESS 217306Q . 224037Q) (
\DRAWCURVE.PRESS.LINE 224041Q . 232310Q) (\DRAWELLIPSE.PRESS 232312Q . 234421Q) (\GETBRUSHFONT.PRESS
234423Q . 236033Q) (\PRESSCURVE2 236035Q . 262530Q)) (266134Q 271353Q (\PRESSINIT 266146Q . 271351Q))
(307270Q 312057Q (MAKEPRESS 307302Q . 307602Q) (PRESSFILEP 307604Q . 311211Q) (PRESS.BITMAPSCALE
311213Q . 312055Q)))))
STOP