(FILECREATED "28-Sep-84 18:47:41" {ERIS}<LISPCORE>SOURCES>HARDCOPY.;17 38907
changes to: (FNS HARDCOPYSTREAMTYPE UNMAKEHARDCOPYSTREAM)
previous date: "24-Sep-84 17:24:40" {ERIS}<LISPCORE>SOURCES>HARDCOPY.;15)
(* Copyright (c) 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT HARDCOPYCOMS)
(RPAQQ HARDCOPYCOMS [(COMS (* Interface for PRINTERS and IMAGEFILES)
(FNS CAN.PRINT.DIRECTLY CONVERT.FILE.TO.TYPE.FOR.PRINTER EMPRESS HARDCOPYW
LISTFILES1 PRINTER.BITMAPFILE PRINTER.BITMAPSCALE
PRINTER.SCRATCH.FILE PRINTERPROP PRINTERSTATUS PRINTERTYPE
PRINTFILEPROP PRINTFILETYPE SEND.FILE.TO.PRINTER)
(P (* for backward compatibility)
(MOVD? (QUOTE NILL)
(QUOTE PRINTERMODE)))
(INITVARS (DEFAULTPRINTINGHOST)
(DEFAULTPRINTERTYPE (QUOTE PRESS))
(EMPRESS.SCRATCH (QUOTE (30 {DSK}EMPRESS.SCRATCH)))
(EMPRESS#SIDES T))
(FNS TEXTTOIMAGEFILE))
(COMS (* stuff to support hardcopy streams on the display.)
(FNS MAKEHARDCOPYSTREAM UNMAKEHARDCOPYSTREAM HARDCOPYSTREAMTYPE \CHARWIDTH.HDCPYDISPLAY
\DSPFONT.HDCPYDISPLAY \DSPRIGHTMARGIN.HDCPYDISPLAY \DSPXPOSITION.HDCPYDISPLAY
\DSPYPOSITION.HDCPYDISPLAY \STRINGWIDTH.HDCPYDISPLAY \HDCPYBLTCHAR
\HDCPYDISPLAY.FIX.XPOS \HDCPYDISPLAY.FIX.YPOS \HDCPYDISPLAYINIT \HDCPYDSPPRINTCHAR
\SLOWHDCPYBLTCHAR)
(DECLARE: DONTCOPY DOEVAL@COMPILE (VARS (MICASPERPT (FQUOTIENT 2540 72))
(IHALFMICASPERPT 17)
(IMICASPERPT 35)))
(DECLARE: DONTEVAL@LOAD DOCOPY (P (\HDCPYDISPLAYINIT])
(* Interface for PRINTERS and IMAGEFILES)
(DEFINEQ
(CAN.PRINT.DIRECTLY
[LAMBDA (PRINTERTYPE FILETYPE) (* lmm " 7-OCT-83 12:05")
(FMEMB FILETYPE (PRINTERPROP PRINTERTYPE (QUOTE CANPRINT])
(CONVERT.FILE.TO.TYPE.FOR.PRINTER
[LAMBDA (FILE FILETYPE PRINTERTYPE HEADING) (* lmm " 6-Sep-84 14:59")
(SETQ FILETYPE (OR FILETYPE (QUOTE TEXT)))
(PROG ((SCRATCH (PRINTER.SCRATCH.FILE FILE PRINTERTYPE)))
(APPLY* (OR (LISTGET (PRINTERPROP PRINTERTYPE (QUOTE CONVERSION))
FILETYPE)
(for CANPRINT in (PRINTERPROP PRINTERTYPE (QUOTE CANPRINT)) bind CONVERTER
when (SETQ CONVERTER (LISTGET (PRINTFILEPROP CANPRINT (QUOTE CONVERSION))
FILETYPE))
do (RETURN CONVERTER))
(ERROR (CONCAT "Can't convert a " FILETYPE " for a " PRINTERTYPE " printer")
FILE))
FILE SCRATCH NIL HEADING)
(RESETSAVE NIL (LIST (FUNCTION [LAMBDA (SCRATCH)
(CLOSEF? SCRATCH)
(DELFILE SCRATCH])
SCRATCH))
(RETURN SCRATCH])
(EMPRESS
[LAMBDA (FILE #COPIES HOST HEADING #SIDES PRINTOPTIONS) (* lmm " 3-OCT-83 20:21")
(SEND.FILE.TO.PRINTER FILE HOST (NCONC (COND
(HEADING (LIST (QUOTE HEADING)
HEADING)))
(COND
(#COPIES (LIST (QUOTE #COPIES)
#COPIES)))
(COND
(#SIDES (LIST (QUOTE #SIDES)
#SIDES)))
PRINTOPTIONS])
(HARDCOPYW
[LAMBDA (WINDOW/BITMAP/REGION FILE HOST SCALEFACTOR ROTATION PRINTERTYPE)
(* lmm " 1-Sep-84 12:22")
(* makes a hard copy of a window)
(* WINDOW/BITMAP/REGION can be a WINDOW, a REGION, a
BITMAP, or NIL = select region)
(* If FILE supplied, output goes there.
If HOST supplied, IT is printed.
If neither FILE nor HOST supplied, default is to print)
(PROG ((BITMAP (SCREENBITMAP))
REGION
(PRINTHOST HOST))
[SETQ REGION (COND
((WINDOWP WINDOW/BITMAP/REGION)
(COND
((OPENWP WINDOW/BITMAP/REGION)
(TOTOPW WINDOW/BITMAP/REGION)
(WINDOWPROP WINDOW/BITMAP/REGION (QUOTE REGION)))
(T (SETQ BITMAP (WINDOWPROP WINDOW/BITMAP/REGION (QUOTE IMAGECOVERED)))
NIL)))
((BITMAPP WINDOW/BITMAP/REGION)
(SETQ BITMAP WINDOW/BITMAP/REGION)
NIL)
((type? REGION WINDOW/BITMAP/REGION)
WINDOW/BITMAP/REGION)
(T (GETREGION]
RETRY
(COND
[PRINTERTYPE (COND
[PRINTHOST (COND
((NEQ PRINTERTYPE (PRINTERTYPE PRINTHOST))
(ERROR PRINTHOST (CONCAT "not of printer type " PRINTERTYPE)
)
(GO RETRY]
(FILE (* don't need a PRINTHOST if you give a file)
)
[(SETQ PRINTHOST (find HOST inside DEFAULTPRINTINGHOST
suchthat (EQ PRINTERTYPE (PRINTERTYPE HOST]
(T (ERROR
"Can't find a printing host in DEFAULTPRINTINGHOST that is of type "
PRINTERTYPE)
(GO RETRY]
(PRINTHOST (SETQ PRINTERTYPE (PRINTERTYPE PRINTHOST)))
[DEFAULTPRINTINGHOST (for X inside DEFAULTPRINTINGHOST when (PRINTERPROP (SETQ
PRINTERTYPE
(PRINTERTYPE
X))
(QUOTE
BITMAPSCALE))
do (RETURN (SETQ PRINTHOST X))
finally (SETQ PRINTERTYPE (PRINTERTYPE (SETQ PRINTHOST
(COND
((LISTP
DEFAULTPRINTINGHOST)
(CAR
DEFAULTPRINTINGHOST))
(T DEFAULTPRINTINGHOST]
[FILE (COND
((NOT (SETQ PRINTERTYPE (PRINTFILETYPE FILE T)))
(ERROR FILE
"Can't tell what kind of print file to produce -- PRINTERTYPE, DEFAULTPRINTERTYPE, DEFAULTPRINTINGHOST all NIL"
)
(GO RETRY]
(T (ERROR "Can't tell where to send window image -- HOST, DEFAULTPRINTINGHOST are NIL")
(GO RETRY)))
[COND
((NOT SCALEFACTOR)
[SETQ SCALEFACTOR (COND
(REGION (PRINTER.BITMAPSCALE (fetch WIDTH of REGION)
(fetch HEIGHT of REGION)
PRINTERTYPE PRINTHOST))
(T (PRINTER.BITMAPSCALE (fetch BITMAPWIDTH of BITMAP)
(fetch BITMAPHEIGHT of BITMAP)
PRINTERTYPE PRINTHOST]
(COND
((LISTP SCALEFACTOR)
(SETQ ROTATION (CDR SCALEFACTOR))
(SETQ SCALEFACTOR (CAR SCALEFACTOR]
(SETQ FULLFILE (PRINTER.BITMAPFILE (OR FILE (PRINTER.SCRATCH.FILE))
PRINTERTYPE BITMAP SCALEFACTOR REGION ROTATION
"Window Image"))
[COND
((OR HOST (NULL FILE))
(ADD.PROCESS [BQUOTE (PROGN (, (PRINTERPROP PRINTERTYPE (QUOTE SEND))
(QUOTE , (COND ((LISTP PRINTHOST)
(CADR PRINTHOST))
(T PRINTHOST)))
(QUOTE , FULLFILE)
(QUOTE (DOCUMENT.NAME "Window Image")))
,
(AND (NULL FILE)
(BQUOTE (DELFILE (QUOTE , FULLFILE]
(QUOTE NAME)
(QUOTE HARDCOPYW]
(RETURN (COND
((NULL FILE)
NIL)
(T FULLFILE])
(LISTFILES1
[LAMBDA (FILE) (* lmm " 4-OCT-83 02:56")
(SEND.FILE.TO.PRINTER FILE])
(PRINTER.BITMAPFILE
[LAMBDA (FILE PRINTERTYPE BITMAP SCALEFACTOR REGION ROTATION TITLE)
(* lmm " 3-OCT-83 21:40")
(* convert a bitmap into a file)
(DECLARE (SPECVARS . T))
(EVAL (PRINTERPROP PRINTERTYPE (QUOTE BITMAPFILE])
(PRINTER.BITMAPSCALE
[LAMBDA (WIDTH HEIGHT PRINTERTYPE HOST) (* lmm " 3-OCT-83 21:32")
(* could ask the host what size paper it has)
(PROG NIL
(RETURN (APPLY* (OR (PRINTERPROP PRINTERTYPE (QUOTE BITMAPSCALE))
(RETURN 1))
WIDTH HEIGHT HOST])
(PRINTER.SCRATCH.FILE
[LAMBDA (FULLFILE) (* lmm "25-Jun-84 17:05")
(COND
[(AND FULLFILE (FIXP (CAR (LISTP EMPRESS.SCRATCH)))
(IGREATERP (OR (GETFILEINFO FULLFILE (QUOTE SIZE))
0)
(CAR EMPRESS.SCRATCH)))
(CAR (LISTP (CDR EMPRESS.SCRATCH]
(T (QUOTE {CORE}EMPRESS.SCRATCH])
(PRINTERPROP
[LAMBDA (PRINTERTYPE PROP) (* lmm " 5-OCT-83 16:11")
(for X in PRINTERTYPES when (EQMEMB PRINTERTYPE (CAR X))
do (RETURN (CADR (ASSOC PROP (CDR X])
(PRINTERSTATUS
[LAMBDA (PRINTER) (* lmm " 5-OCT-83 15:19")
(PROG [(STATUSFN (PRINTERPROP (PRINTERTYPE PRINTER)
(QUOTE STATUS]
(RETURN (AND STATUSFN (APPLY* STATUSFN PRINTER])
(PRINTERTYPE
[LAMBDA (HOST) (* lmm " 5-OCT-83 16:42")
(SELECTQ HOST
[(NIL LPT)
(SETQ HOST (COND
((LISTP DEFAULTPRINTINGHOST)
(CAR DEFAULTPRINTINGHOST))
(T DEFAULTPRINTINGHOST]
NIL)
(COND
((LISTP HOST)
(CAR HOST))
((NULL HOST)
DEFAULTPRINTERTYPE)
((GETPROP HOST (QUOTE PRINTERTYPE)))
((STRPOS ":" HOST)
(QUOTE INTERPRESS))
(T DEFAULTPRINTERTYPE])
(PRINTFILEPROP
[LAMBDA (PRINTFILETYPE PROP) (* rmk: "11-OCT-83 13:00")
(for X in PRINTFILETYPES when (EQMEMB PRINTFILETYPE (CAR X))
do (RETURN (CADR (ASSOC PROP (CDR X])
(PRINTFILETYPE
[LAMBDA (FILE DONTOPEN) (* lmm " 1-Jun-84 10:21")
(* could be extended to know about TEDIT etc. documents)
(OR [AND (NOT DONTOPEN)
(OR (NOT (OPENP FILE))
(RANDACCESSP FILE))
(for TYPE in PRINTFILETYPES when (CAR (NLSETQ (APPLY* (CADR (ASSOC (QUOTE TEST)
(CDR TYPE)))
FILE)))
do (RETURN (CAR TYPE]
(bind (EXT ←(FILENAMEFIELD FILE (QUOTE EXTENSION))) for TYPE in PRINTFILETYPES
when [FMEMB EXT (CADR (ASSOC (QUOTE EXTENSION)
(CDR TYPE]
do (RETURN (CAR TYPE])
(SEND.FILE.TO.PRINTER
[LAMBDA (FILE HOST PRINTOPTIONS) (* lmm " 1-Sep-84 12:26")
(* Returns file name if successful, NIL if not. The RESETLST makes sure the scratch file, if any, is deleted.
EMPRESS.SCRATCH sets a limit on the size of the file that will be converted to a CORE file so as not to use up too
much virtual memory)
(RESETLST (PROG (FULLFILE FILETYPE PRINTERTYPE PFILE)
[RESETSAVE NIL (LIST (COND
[(LISTGET PRINTOPTIONS (QUOTE DELETE))
(FUNCTION (LAMBDA (FL)
(CLOSEF? FL)
(DELFILE FL]
(T (FUNCTION CLOSEF?)))
(SETQ FULLFILE (OPENFILE FILE (QUOTE INPUT)
(QUOTE OLD)
8]
(* Do we need to convert the FILE ?)
(SETQ FILETYPE (PRINTFILETYPE (SETQ PFILE FULLFILE)))
RETRY
[COND
[HOST (SETQ PRINTERTYPE (PRINTERTYPE HOST))
(COND
((CAN.PRINT.DIRECTLY PRINTERTYPE FILETYPE)
(* IS OK, NO CONVERSION)
)
(T (SETQ PFILE (CONVERT.FILE.TO.TYPE.FOR.PRINTER PFILE FILETYPE
PRINTERTYPE
(LISTGET PRINTOPTIONS
(QUOTE
HEADING]
((NULL DEFAULTPRINTINGHOST)
(ERROR "DEFAULTPRINTINGHOST and HOST arg are NIL; don't know where to print "
FILE)
(GO RETRY))
([AND FILETYPE (for X inside (OR DEFAULTPRINTINGHOST (QUOTE (NIL)))
when (CAN.PRINT.DIRECTLY (SETQ PRINTERTYPE (PRINTERTYPE
X))
FILETYPE)
do (RETURN (SETQ HOST X]
(* no conversion necessary)
)
(T (SETQ PFILE (CONVERT.FILE.TO.TYPE.FOR.PRINTER PFILE FILETYPE
[SETQ PRINTERTYPE
(PRINTERTYPE
(SETQ HOST
(COND
((LISTP
DEFAULTPRINTINGHOST)
(CAR
DEFAULTPRINTINGHOST))
(T DEFAULTPRINTINGHOST]
(LISTGET PRINTOPTIONS
(QUOTE HEADING]
(COND
([NLISTP (SETQ PFILE (APPLY* (OR (PRINTERPROP PRINTERTYPE (QUOTE SEND))
(ERROR (CONCAT "Don't know how to send to a "
PRINTERTYPE)
HOST))
(COND
((LISTP HOST)
(CADR HOST))
(T HOST))
PFILE
(APPEND (OR PRINTOPTIONS (QUOTE (#COPIES 1)))
(LIST (QUOTE DOCUMENT.NAME)
FULLFILE]
(RETURN FULLFILE))
(T (LISPXPRIN1 (CDR PFILE)
T)
(LISPXTERPRI T)
(RETURN NIL])
)
(* for backward compatibility)
(MOVD? (QUOTE NILL)
(QUOTE PRINTERMODE))
(RPAQ? DEFAULTPRINTINGHOST )
(RPAQ? DEFAULTPRINTERTYPE (QUOTE PRESS))
(RPAQ? EMPRESS.SCRATCH (QUOTE (30 {DSK}EMPRESS.SCRATCH)))
(RPAQ? EMPRESS#SIDES T)
(DEFINEQ
(TEXTTOIMAGEFILE
[LAMBDA (FILE IMAGEFILE IMAGETYPE FONTS HEADING TABS) (* rmk: "14-Sep-84 12:01")
(* Generic function for converting PSPOOL format text
files into image files)
(DECLARE (GLOBALVARS PRESSTABSTOPS))
(RESETLST
(PROG (IMAGESTREAM INSTRM OUTCHARFN INFILE INEOLC MTABS MAXFONT FONTARRAY)
(* FONTARRAY is an array of font-descriptors)
[RESETSAVE [SETQ INFILE (OPENFILE FILE (QUOTE INPUT)
(QUOTE OLD)
8
(QUOTE ((SEQUENTIAL T]
(QUOTE (PROGN (CLOSEF? OLDVALUE] (* Strip off the extension if we are generating the
name from the INFILE, so that OPENIMAGESTREAM can pack
on the appropriate extension)
[RESETSAVE [SETQ IMAGESTREAM
(OPENIMAGESTREAM (OR IMAGEFILE (PACKFILENAME (QUOTE EXTENSION)
NIL
(QUOTE VERSION)
NIL
(QUOTE BODY)
INFILE))
IMAGETYPE
(APPEND [AND (NEQ HEADING T)
(LIST (QUOTE HEADING)
(OR HEADING (CONCAT INFILE " "
(GETFILEINFO
INFILE
(QUOTE
CREATIONDATE]
(LIST (QUOTE BREAKPAGEFILENAME)
INFILE]
(QUOTE (AND RESETSTATE (DELFILE (CLOSEF? OLDVALUE]
(SETQ FONTARRAY (FONTMAPARRAY FONTS))
(SETQ MAXFONT (ARRAYSIZE FONTARRAY))
(SETQ OUTCHARFN (fetch (STREAM OUTCHARFN) of IMAGESTREAM))
(SETQ INSTRM (\INSTREAMARG INFILE))
(replace (STREAM ENDOFSTREAMOP) of INSTRM with (FUNCTION ZERO))
(SETQ INEOLC (fetch EOLCONVENTION of INSTRM)) (* Make \BIN return NIL on EOS)
[bind C FC
do (SETQ C (\BIN INSTRM))
(COND
([IGREATERP C (CONSTANT (APPLY (FUNCTION MAX)
(CHARCODE (↑F CR LF ↑L TAB NULL]
(SPREADAPPLY* OUTCHARFN IMAGESTREAM C))
(T (SELCHARQ C
[↑F (* Font shift)
(SELCHARQ (SETQ FC (\BIN INSTRM))
[↑T (* tab to absolute pos.)
(COND
((EQ 0 (SETQ FC (\BIN INSTRM)))
(SPREADAPPLY* OUTCHARFN IMAGESTREAM
(CHARCODE ↑F))
(SPREADAPPLY* OUTCHARFN IMAGESTREAM
(CHARCODE ↑T))
(AND (\EOFP INSTRM)
(RETURN))
(SPREADAPPLY* OUTCHARFN IMAGESTREAM FC))
(T [OR MTABS (SETQ MTABS
(for TAB in (OR TABS PRESSTABSTOPS)
collect (millsToMicas TAB]
(SETQ FC (OR (CAR (NTH MTABS FC))
(ERROR
"Undefined absolute tab number"
FC)))
(DSPXPOSITION FC IMAGESTREAM]
(NULL (SPREADAPPLY* OUTCHARFN IMAGESTREAM
(CHARCODE ↑F))
(AND (\EOFP INSTRM)
(RETURN))
(SPREADAPPLY* OUTCHARFN IMAGESTREAM FC)
(* EOS after ↑F)
)
(COND
((AND (IGEQ MAXFONT FC)
(NEQ FC 0))
(DSPFONT (ELT FONTARRAY FC)
IMAGESTREAM))
(T (SPREADAPPLY* OUTCHARFN IMAGESTREAM (CHARCODE
↑F))
(SPREADAPPLY* OUTCHARFN IMAGESTREAM C]
(CR (SELECTC INEOLC
(CR.EOLC (IMAGEOP (QUOTE IMTERPRI)
IMAGESTREAM IMAGESTREAM))
[CRLF.EOLC (COND
((EQ (CHARCODE LF)
(\PEEKBIN INSTRM T))
(\BIN INSTRM)
(IMAGEOP (QUOTE IMTERPRI)
IMAGESTREAM IMAGESTREAM))
(T (DSPXPOSITION (DSPLEFTMARGIN NIL
IMAGESTREAM)
IMAGESTREAM)
(* Move to left margin)
]
(DSPXPOSITION (DSPLEFTMARGIN NIL IMAGESTREAM)
IMAGESTREAM)))
[LF (COND
((EQ INEOLC LF.EOLC)
(IMAGEOP (QUOTE IMTERPRI)
IMAGESTREAM IMAGESTREAM))
(T (DSPXPOSITION (PROG1 (DSPXPOSITION NIL IMAGESTREAM)
(IMAGEOP (QUOTE IMTERPRI)
IMAGESTREAM IMAGESTREAM))
IMAGESTREAM]
(↑L (IMAGEOP (QUOTE IMNEWPAGE)
IMAGESTREAM IMAGESTREAM))
(TAB (RELMOVETO (UNFOLD (CHARWIDTH (CHARCODE SPACE)
(DSPFONT NIL IMAGESTREAM))
8)
0 IMAGESTREAM))
(NULL (AND (\EOFP INSTRM)
(RETURN))
(SPREADAPPLY* OUTCHARFN IMAGESTREAM C))
(SPREADAPPLY* OUTCHARFN IMAGESTREAM C]
(RETURN (LIST (CLOSEF INFILE)
(CLOSEF IMAGESTREAM])
)
(* stuff to support hardcopy streams on the display.)
(DEFINEQ
(MAKEHARDCOPYSTREAM
[LAMBDA (DISPLAYSTREAM IMAGETYPE) (* rmk: "24-Sep-84 17:05")
(* * creates a hardcopy stream from a display stream.)
(DECLARE (GLOBALVARS \HDCPYDISPLAYIMAGEOPS))
(PROG [(DS (COND
((DISPLAYSTREAMP DISPLAYSTREAM))
((WINDOWP DISPLAYSTREAM)
(WINDOWPROP DISPLAYSTREAM (QUOTE DSP)))
((NULL DISPLAYSTREAM)
(DSPCREATE))
(T (\ILLEGAL.ARG DISPLAYSTREAM]
(replace (STREAM IMAGEOPS) of DS with \HDCPYDISPLAYIMAGEOPS)
(STREAMPROP DS (QUOTE HARDCOPYIMAGETYPE)
(OR IMAGETYPE (PRINTERTYPE))) (* set the bout fn to one that updates the mica fields
and sets the position from them.)
(replace (STREAM STRMBOUTFN) of DS with (FUNCTION \HDCPYDSPPRINTCHAR))
(replace (STREAM OUTCHARFN) of DS with (FUNCTION \HDCPYDSPPRINTCHAR))
(* set the parameters that are different to initialize
the mica defined fields.)
(DSPFONT (DSPFONT NIL DS)
DS)
(DSPXPOSITION 0 DS)
(DSPYPOSITION 0 DS)
(DSPRIGHTMARGIN (DSPRIGHTMARGIN NIL DS)
DS)
(RETURN DS])
(UNMAKEHARDCOPYSTREAM
[LAMBDA (DISPLAYSTREAM) (* rrb "28-Sep-84 15:26")
(* * returns a hardcopy stream to a display stream.)
(DECLARE (GLOBALVARS \DISPLAYIMAGEOPS))
(PROG [(DS (COND
((DISPLAYSTREAMP DISPLAYSTREAM))
((WINDOWP DISPLAYSTREAM)
(WINDOWPROP DISPLAYSTREAM (QUOTE DSP)))
(T (\ILLEGAL.ARG DISPLAYSTREAM]
(COND
((FMEMB (QUOTE HARDCOPY)
(IMAGESTREAMTYPE DS)))
(T (RETURN DS)))
(replace (STREAM IMAGEOPS) of DS with \DISPLAYIMAGEOPS)
(STREAMPROP DS (QUOTE HARDCOPYIMAGETYPE)
NIL) (* restore the bout fn)
(replace (STREAM STRMBOUTFN) of DS with (FUNCTION \DSPPRINTCHAR))
(replace (STREAM OUTCHARFN) of DS with (FUNCTION \DSPPRINTCHAR))
(RETURN DS])
(HARDCOPYSTREAMTYPE
[LAMBDA (IMAGESTREAM) (* rrb "28-Sep-84 18:41")
(* * returns the type of a hard copy stream which is either PRESS or INTERPRESS.)
(PROG (STREAM)
(RETURN (AND (SETQ STREAM (\OUTSTREAMARG IMAGESTREAM T))
(STREAMPROP STREAM (QUOTE HARDCOPYIMAGETYPE])
(\CHARWIDTH.HDCPYDISPLAY
[LAMBDA (STREAM CHARCODE) (* rmk: "12-Sep-84 11:37")
(* gets the width of a character code in a hardcopy
stream. Should be updated for spacefactor)
(IQUOTIENT (IPLUS (\FGETWIDTH (ffetch (\DISPLAYDATA DDCHARIMAGEWIDTHS)
of (fetch IMAGEDATA of STREAM))
CHARCODE)
(CONSTANT IHALFMICASPERPT))
(CONSTANT IMICASPERPT])
(\DSPFONT.HDCPYDISPLAY
[LAMBDA (HDCPYDSTREAM FONT) (* rmk: "24-Sep-84 17:24")
(* changes the font of a hardcopy display stream. Does what the display does then puts the hardcopy widths where
they can be found {FOR NOW USE THE DDCHARIMAGEWIDTHS FIELD})
(PROG1 (\DSPFONT.DISPLAY HDCPYDSTREAM FONT)
(AND FONT (PROG [(DD (fetch IMAGEDATA of HDCPYDSTREAM))
(FD (FONTCREATE FONT NIL NIL NIL (STREAMPROP HDCPYDSTREAM (QUOTE
HARDCOPYIMAGETYPE]
(* For now, use a streamprop instead of a special field
in the dispay data)
(* Scale widths to micas, so we don't have to fetch the
constants to scale by for every char we print)
(replace DDCHARIMAGEWIDTHS of DD
with (fetch (ARRAYP BASE)
of (PROG [W (SCALE (FONTPROP FD (QUOTE SCALE]
[COND
((EQP SCALE (CONSTANT MICASPERPT))
(RETURN (fetch \SFWidths of FD]
(SETQ W (COPYARRAY (fetch \SFWidths of FD)))
(SETQ SCALE (FQUOTIENT (CONSTANT MICASPERPT)
SCALE))
(* This is very slow, but presumably works)
[for I from (ARRAYORIG W) to (PLUS (ARRAYSIZE W)
(ARRAYORIG W)
-1)
do (SETA W I (FIXR (FTIMES (ELT W I)
SCALE]
(RETURN W])
(\DSPRIGHTMARGIN.HDCPYDISPLAY
[LAMBDA (DISPLAYSTREAM XPOSITION) (* rrb "21-Aug-84 18:30")
(* * Sets the right margin that determines when a cr is inserted by print for the hardcopy display stream.)
(* mica right margin is kept accurately using 35.27778. Since the updating at each character is done with 35, this
may lead to a small error.)
(PROG1 (\DSPRIGHTMARGIN.DISPLAY DISPLAYSTREAM XPOSITION)
(AND XPOSITION (replace (\DISPLAYDATA DDMICARIGHTMARGIN) of (fetch IMAGEDATA of
DISPLAYSTREAM)
with (FIX (FTIMES XPOSITION (CONSTANT MICASPERPT])
(\DSPXPOSITION.HDCPYDISPLAY
[LAMBDA (HARDCOPYSTREAM XPOSITION) (* rrb "20-Aug-84 17:51")
(* updates the mica xposition too.)
(PROG1 (\DSPXPOSITION.DISPLAY HARDCOPYSTREAM XPOSITION)
(AND XPOSITION (\HDCPYDISPLAY.FIX.XPOS HARDCOPYSTREAM])
(\DSPYPOSITION.HDCPYDISPLAY
[LAMBDA (HARDCOPYSTREAM YPOSITION) (* rrb "20-Aug-84 17:51")
(* updates the mica xposition too.)
(PROG1 (\DSPYPOSITION.DISPLAY HARDCOPYSTREAM YPOSITION)
(AND YPOSITION (\HDCPYDISPLAY.FIX.YPOS HARDCOPYSTREAM])
(\STRINGWIDTH.HDCPYDISPLAY
[LAMBDA (STREAM STR RDTBL) (* rmk: "12-Sep-84 11:11")
(* Returns the width of for the current font/spacefactor
in hardcopy stream STREAM.)
(PROG (WIDTHSBASE)
(RETURN (IQUOTIENT (IPLUS (\STRINGWIDTH.GENERIC STR (SETQ WIDTHSBASE
(ffetch (\DISPLAYDATA DDCHARIMAGEWIDTHS)
of (ffetch IMAGEDATA of STREAM)))
RDTBL
(\FGETWIDTH WIDTHSBASE (CHARCODE SPACE)))
(CONSTANT IHALFMICASPERPT))
(CONSTANT IMICASPERPT])
(\HDCPYBLTCHAR
[LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* rrb "21-Aug-84 18:36")
(* puts a character on a hardcopy 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 a DisplayStream.)
(DECLARE (LOCALVARS . T))
(PROG (LOCAL1 RIGHT LEFT CURX MICARIGHT)
[COND
((ffetch (\DISPLAYDATA DDSlowPrintingCase) of DISPLAYDATA)
(RETURN (\SLOWHDCPYBLTCHAR CHARCODE DISPLAYSTREAM]
CRLP(SETQ CURX (ffetch DDXPOSITION of DISPLAYDATA))
[COND
((IGREATERP (SETQ MICARIGHT (IPLUS (ffetch (\DISPLAYDATA DDMICAXPOS) of DISPLAYDATA)
(\FGETWIDTH (ffetch (\DISPLAYDATA DDCHARIMAGEWIDTHS)
of DISPLAYDATA)
CHARCODE)))
(ffetch (\DISPLAYDATA DDMICARIGHTMARGIN) 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 (CHARCODE EOL)
DISPLAYSTREAM) (* reuse the code in the test of this conditional rather
than repeat it here.)
(GO CRLP]
(freplace (\DISPLAYDATA DDMICAXPOS) of DISPLAYDATA with MICARIGHT)
(* update the display stream x position.
Make sure that there is at least one point width for
each character.)
[freplace DDXPOSITION of DISPLAYDATA with (IMAX (ADD1 CURX)
(IQUOTIENT (IPLUS MICARIGHT (CONSTANT
IHALFMICASPERPT))
(CONSTANT IMICASPERPT]
(* transforms an x coordinate into the destination
coordinate.)
(SETQ CURX (IPLUS CURX (ffetch DDXOFFSET of DISPLAYDATA)))
(SETQ RIGHT (IPLUS CURX (\DSPGETCHARWIDTH CHARCODE DISPLAYDATA)))
(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. DISPLAYSTREAM (freplace PBTDESTBIT of LOCAL1 with LEFT)
(freplace PBTWIDTH of LOCAL1 with (IDIFFERENCE RIGHT LEFT))
(freplace PBTSOURCEBIT of LOCAL1
with (IDIFFERENCE (IPLUS (\DSPGETCHAROFFSET CHARCODE
DISPLAYDATA)
LEFT)
CURX))
(\PILOTBITBLT LOCAL1 0))
T])
(\HDCPYDISPLAY.FIX.XPOS
[LAMBDA (HARDCOPYSTREAM) (* rrb "20-Aug-84 17:47")
(* * updates the mica X position from the x position in the display stream. This is called whenever the X position
changes in a hardcopy stream.)
(PROG ((DD (fetch IMAGEDATA of HARDCOPYSTREAM)))
(replace (\DISPLAYDATA DDMICAXPOS) of DD with (FIX (FTIMES (fetch (\DISPLAYDATA DDXPOSITION)
of DD)
(CONSTANT MICASPERPT])
(\HDCPYDISPLAY.FIX.YPOS
[LAMBDA (HARDCOPYSTREAM) (* rrb "20-Aug-84 17:50")
(* * updates the mica Y position from the Y position in the display stream. This is called whenever the Y position
changes in a hardcopy stream.)
(PROG ((DD (fetch IMAGEDATA of HARDCOPYSTREAM)))
(replace (\DISPLAYDATA DDMICAYPOS) of DD with (FIX (FTIMES (fetch (\DISPLAYDATA DDYPOSITION)
of DD)
(CONSTANT MICASPERPT])
(\HDCPYDISPLAYINIT
[LAMBDA NIL (* rmk: "24-Sep-84 17:04")
(* * Initializes global variables for the hardcopy Display device. This device appears to the user as an INTERPRESS
or PRESS device meaning units in micas but outputs to the screen. Much of this code was borrowed from the display
case.)
(DECLARE (GLOBALVARS \HDCPYDISPLAYIMAGEOPS))
(SETQ \HDCPYDISPLAYIMAGEOPS (create IMAGEOPS using \DISPLAYIMAGEOPS IMAGETYPE ←(QUOTE
(HARDCOPY DISPLAY))
IMFONT ←(FUNCTION \DSPFONT.HDCPYDISPLAY)
IMRIGHTMARGIN ←(FUNCTION
\DSPRIGHTMARGIN.HDCPYDISPLAY)
IMXPOSITION ←(FUNCTION
\DSPXPOSITION.HDCPYDISPLAY)
IMYPOSITION ←(FUNCTION
\DSPYPOSITION.HDCPYDISPLAY)
IMSTRINGWIDTH ←(FUNCTION
\STRINGWIDTH.HDCPYDISPLAY)
IMCHARWIDTH ←(FUNCTION \CHARWIDTH.HDCPYDISPLAY]
)
(\HDCPYDSPPRINTCHAR
[LAMBDA (STREAM CHARCODE) (* rrb "21-Aug-84 10:17")
(* * displays a character on a hardcopy display stream. This uses a display font but updates the x position
according to hardcopy widths.)
(PROG ((DD (fetch IMAGEDATA of STREAM)))
(\CHECKCARET STREAM)
(RETURN
(SELECTC
(fetch CCECHO of (\SYNCODE \PRIMTERMSA CHARCODE))
[INDICATE.CCE (PROG ((CC CHARCODE))
(add (fetch CHARPOSITION of STREAM)
(IPLUS (COND
((IGREATERP CC 127)
(* META character)
(\HDCPYBLTCHAR (CHARCODE #)
STREAM DD)
(SETQ CC (LOGAND CC 127))
1)
(T 0))
(COND
((ILESSP CC 32)
(* CONTROL character)
(\HDCPYBLTCHAR (CHARCODE ↑)
STREAM DD)
(SETQ CC (LOGOR CC 64))
1)
(T 0))
(PROGN (\HDCPYBLTCHAR CC STREAM DD)
1]
[SIMULATE.CCE
(SELCHARQ CHARCODE
((EOL CR LF)
(\DSPPRINTCR/LF CHARCODE STREAM)
(replace CHARPOSITION of STREAM with 0))
(ESCAPE (\HDCPYBLTCHAR (CHARCODE $)
STREAM DD)
(add (fetch CHARPOSITION of STREAM)
1))
[BELL (* make switching of bits uninterruptable but allow
interrupts between flashes.)
(SELECTQ (MACHINETYPE)
[DANDELION (PLAYTUNE (QUOTE ((880 . 2500]
(FLASHWINDOW (WFROMDS STREAM]
[TAB (PROG (TABWIDTH (SPACEWIDTH (CHARWIDTH (CHARCODE SPACE)
STREAM)))
(SETQ TABWIDTH (UNFOLD SPACEWIDTH 8))
(COND
((IGREATERP (\DISPLAYSTREAMINCRXPOSITION
(SETQ TABWIDTH
(IDIFFERENCE TABWIDTH
(MOD (IDIFFERENCE (fetch
DDXPOSITION
of DD)
(ffetch
DDLeftMargin
of DD))
TABWIDTH)))
DD)
(ffetch DDRightMargin of DD))
(* tab was past rightmargin, force cr.)
(\DSPPRINTCR/LF (CHARCODE EOL)
STREAM)))
(* return the number of spaces taken.)
(add (fetch CHARPOSITION of STREAM)
(IQUOTIENT TABWIDTH SPACEWIDTH]
(PROGN (* this case was copied from \DSCCOUT.)
(\HDCPYBLTCHAR CHARCODE STREAM DD)
(add (fetch CHARPOSITION of STREAM)
1]
[REAL.CCE (SELECTC CHARCODE
((CHARCODE (EOL CR LF))
(\DSPPRINTCR/LF CHARCODE STREAM)
(replace CHARPOSITION of STREAM with 0))
(ERASECHARCODE (DSPBACKUP (CHARWIDTH (CHARCODE A)
STREAM)
STREAM)
(* line buffering routines have already taken care of
backing up the position)
0)
(PROGN (\HDCPYBLTCHAR CHARCODE STREAM DD)
(add (fetch CHARPOSITION of STREAM)
1]
(IGNORE.CCE)
(SHOULDNT])
(\SLOWHDCPYBLTCHAR
[LAMBDA (CHARCODE DISPLAYSTREAM) (* rrb "21-Aug-84 09:44")
(* * THIS HAS BEEN SEPARATED OUT BUT HASN'T BEEN EDITTED TO DO CORRECT THING WRT UPDATING MICA FIELDS.)
(* case of BLTCHAR where either font is rotated or
destination is a color bitmap.
DISPLAYSTREAM is known to be a hardcopy display stream.)
(PROG (ROTATION (DD (fetch IMAGEDATA of DISPLAYSTREAM)))
(SETQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of (fetch DDFONT of DD)))
(RETURN
(COND
[(EQ 0 ROTATION)
(PROG (NEWX LEFT RIGHT (CURX (ffetch DDXPOSITION of DD)))
[COND
((IGREATERP (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHARCODE DD)))
(ffetch DDRightMargin of DD))
(* past RIGHT margin, force eol)
(\DSPPRINTCR/LF (CHARCODE EOL)
DISPLAYSTREAM)
(SETQ CURX (ffetch DDXPOSITION of DD))
(SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHARCODE DD]
(* update the x position.)
(freplace DDXPOSITION of DD with NEWX)
(SETQ CURX (\DSPTRANSFORMX CURX DD))
(SETQ LEFT (IMAX (ffetch DDClippingLeft of DD)
CURX))
(SETQ RIGHT (IMIN (ffetch DDClippingRight of DD)
(\DSPTRANSFORMX NEWX DD)))
(RETURN (COND
((AND (ILESSP LEFT RIGHT)
(NEQ (fetch PBTHEIGHT of (SETQ NEWX (ffetch DDPILOTBBT
of DD)))
0))
(SELECTQ (fetch (BITMAP BITMAPBITSPERPIXEL)
of (ffetch (\DISPLAYDATA DDDestination) of DD))
(1 (.WHILE.TOP.DS. DISPLAYSTREAM
(freplace PBTDESTBIT of NEWX
with LEFT)
(freplace PBTWIDTH of NEWX
with (IDIFFERENCE RIGHT LEFT))
(freplace PBTSOURCEBIT of NEWX
with (IDIFFERENCE
(IPLUS (\DSPGETCHAROFFSET
CHARCODE DD)
LEFT)
CURX))
(\PILOTBITBLT NEWX 0)))
(4 (OR (\DDHASFONT DD)
(\DDSETCOLORFONT DISPLAYSTREAM))
(.WHILE.TOP.DS.
DISPLAYSTREAM
(freplace PBTDESTBIT of NEWX
with (SETQ LEFT (LLSH LEFT 2)))
(freplace PBTWIDTH of NEWX
with (IDIFFERENCE (LLSH RIGHT 2)
LEFT))
(freplace PBTSOURCEBIT of NEWX
with (IDIFFERENCE (IPLUS (LLSH (\DSPGETCHAROFFSET
CHARCODE DD)
2)
LEFT)
(LLSH CURX 2)))
(\PILOTBITBLT NEWX 0)))
(8 (OR (\DDHASFONT DD)
(\DDSETCOLORFONT DISPLAYSTREAM))
(.WHILE.TOP.DS.
DISPLAYSTREAM
(freplace PBTDESTBIT of NEWX
with (SETQ LEFT (LLSH LEFT 3)))
(freplace PBTWIDTH of NEWX
with (IDIFFERENCE (LLSH RIGHT 3)
LEFT))
(freplace PBTSOURCEBIT of NEWX
with (IDIFFERENCE (IPLUS (LLSH (\DSPGETCHAROFFSET
CHARCODE DD)
3)
LEFT)
(LLSH CURX 3)))
(\PILOTBITBLT NEWX 0)))
(SHOULDNT))
T]
(T (* handle rotated fonts)
(PROG ((YPOS (ffetch DDYPOSITION of DD))
(HEIGHTMOVED (\DSPGETCHARWIDTH CHARCODE DD))
(FONT (ffetch DDFONT of DD)))
(RETURN (COND
((EQ ROTATION 90) (* don't force CR for rotated fonts.)
(\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IPLUS YPOS HEIGHTMOVED))
(* update the display stream x position.)
(BITBLT (fetch (FONTDESCRIPTOR CHARACTERBITMAP) of FONT)
0
(\DSPGETCHAROFFSET CHARCODE DD)
DISPLAYSTREAM
(ADD1 (IDIFFERENCE (ffetch DDXPOSITION of DD)
(FONTASCENT FONT)))
YPOS
(FONTHEIGHT FONT)
HEIGHTMOVED))
((EQ ROTATION 270)
(\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IDIFFERENCE YPOS HEIGHTMOVED)
)
(BITBLT (fetch (FONTDESCRIPTOR CHARACTERBITMAP) of FONT)
0
(\DSPGETCHAROFFSET CHARCODE DD)
DISPLAYSTREAM
(IDIFFERENCE (ffetch DDXPOSITION of DD)
(FONTDESCENT FONT))
(ffetch DDYPOSITION of DISPLAYSTREAM)
(FONTHEIGHT FONT)
HEIGHTMOVED))
(T (ERROR "Not implemented to rotate by other than 0, 90 or 270"])
)
(DECLARE: DONTCOPY DOEVAL@COMPILE
(RPAQ MICASPERPT (FQUOTIENT 2540 72))
(RPAQQ IHALFMICASPERPT 17)
(RPAQQ IMICASPERPT 35)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(\HDCPYDISPLAYINIT)
)
(PUTPROPS HARDCOPY COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1643 12849 (CAN.PRINT.DIRECTLY 1653 . 1838) (CONVERT.FILE.TO.TYPE.FOR.PRINTER 1840 .
2709) (EMPRESS 2711 . 3103) (HARDCOPYW 3105 . 7003) (LISTFILES1 7005 . 7148) (PRINTER.BITMAPFILE 7150
. 7524) (PRINTER.BITMAPSCALE 7526 . 7892) (PRINTER.SCRATCH.FILE 7894 . 8251) (PRINTERPROP 8253 . 8486
) (PRINTERSTATUS 8488 . 8741) (PRINTERTYPE 8743 . 9220) (PRINTFILEPROP 9222 . 9462) (PRINTFILETYPE
9464 . 10137) (SEND.FILE.TO.PRINTER 10139 . 12847)) (13101 18188 (TEXTTOIMAGEFILE 13111 . 18186)) (
18251 38634 (MAKEHARDCOPYSTREAM 18261 . 19627) (UNMAKEHARDCOPYSTREAM 19629 . 20599) (
HARDCOPYSTREAMTYPE 20601 . 20979) (\CHARWIDTH.HDCPYDISPLAY 20981 . 21494) (\DSPFONT.HDCPYDISPLAY 21496
. 23216) (\DSPRIGHTMARGIN.HDCPYDISPLAY 23218 . 23888) (\DSPXPOSITION.HDCPYDISPLAY 23890 . 24237) (
\DSPYPOSITION.HDCPYDISPLAY 24239 . 24586) (\STRINGWIDTH.HDCPYDISPLAY 24588 . 25228) (\HDCPYBLTCHAR
25230 . 28560) (\HDCPYDISPLAY.FIX.XPOS 28562 . 29086) (\HDCPYDISPLAY.FIX.YPOS 29088 . 29612) (
\HDCPYDISPLAYINIT 29614 . 30627) (\HDCPYDSPPRINTCHAR 30629 . 33958) (\SLOWHDCPYBLTCHAR 33960 . 38632))
)))
STOP