(FILECREATED "11-Jun-87 16:52:54" {QV}<NOTECARDS>1.3K>NEXT>KOTOSYSTEMPATCHES.;11
 14154  

      changes to:  (VARS KOTOSYSTEMPATCHESCOMS)

      previous date: "24-Apr-87 11:49:53" {QV}<NOTECARDS>1.3K>NEXT>KOTOSYSTEMPATCHES.;10)


(* Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT KOTOSYSTEMPATCHESCOMS)

(RPAQQ KOTOSYSTEMPATCHESCOMS
 [(* * to compile SHAPEW must have EXPORTS.ALL loaded)
				(DECLARE: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY (FILES EXPORTS.ALL))
				(FNS SHAPEW \NSPRINT.INTERNAL COPY.TEXT.TO.IMAGE)
				(* * fgh&rht 8/6/86: Insure that correct imageobj HPRINTMACRO is at 
				   front of the HPRINTMACROS list.)
				(FNS WRITE.IMAGEOBJ)
				(ADDVARS (HPRINTMACROS (IMAGEOBJ . WRITE.IMAGEOBJ])
(* * to compile SHAPEW must have EXPORTS.ALL loaded)


(DECLARE: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY 
(FILESLOAD EXPORTS.ALL)
)
(DEFINEQ

(SHAPEW

  (LAMBDA (WINDOW NEWREGION)                                 (* fgh: " 6-Jun-86 19:31")


          (* entry that shapes a window checking the userfns for DON'T and interacting to get a region if necessary.

	  This also checks for a user function to do the actual reshaping. look for a function on windowprop INITCORNERSFN, 

	  which will take the window and return the initcorners for the window, to be passed to getregion.)



    (
SETQ
 WINDOW (
\INSUREWINDOW
 WINDOW))
    (
PROG
 (USERFN X)
	    (
COND

	      ((
\USERFNISDON'T
 (fetch
 (WINDOW RESHAPEFN) of
 WINDOW))
                                                             (* don't allow the window to be reshaped.)

		(
PROMPTPRINT
 "This window cannot be reshaped.")
		(
RETURN
 NIL)))
	    (
SETQ
 X (
MINIMUMWINDOWSIZE
 WINDOW))
	    (
SETQ
 X (
COND

		(NEWREGION (
COND

			     ((
OR
 (
LESSP
 (fetch
 (REGION WIDTH) of
 NEWREGION)
					     (
CAR
 X))
				    (
LESSP
 (fetch
 (REGION HEIGHT) of
 NEWREGION)
					     (
CDR
 X)))     (* given a region that is too small)

			       (
CREATEREGION
 (fetch
 (REGION LEFT) of
 NEWREGION)
					       (fetch
 (REGION BOTTOM) of
 NEWREGION)
					       (
MAX
 (
CAR
 X)
						      (fetch
 (REGION WIDTH) of
 NEWREGION))
					       (
MAX
 (
CDR
 X)
						      (fetch
 (REGION HEIGHT) of
 NEWREGION))))
			     (T NEWREGION)))
		((
WINDOWPROP
 WINDOW (
QUOTE
 INITCORNERSFN))
		  (
GETREGION
 (
CAR
 X)
			       (
CDR
 X)
			       (
WINDOWREGION
 WINDOW (
QUOTE
 SHAPEW))
			       (fetch
 NEWREGIONFN of
 WINDOW)
			       WINDOW
			       (
APPLY*
 (
WINDOWPROP
 WINDOW (
QUOTE
 INITCORNERSFN))
					 WINDOW)))
		(T (
GETREGION
 (
CAR
 X)
				(
CDR
 X)
				(
WINDOWREGION
 WINDOW (
QUOTE
 SHAPEW))
				(fetch
 NEWREGIONFN of
 WINDOW)
				WINDOW))))
	    (
RETURN
 (
COND

			((
SETQ
 USERFN (
WINDOWPROP
 WINDOW (
QUOTE
 DOSHAPEFN)))
			  (
APPLY*
 USERFN WINDOW X))
			(T (
SHAPEW1
 WINDOW X)))))))

(\NSPRINT.INTERNAL

  [LAMBDA (PRINTER OPTIONS TRANSFERFN)                       (* Randy.Gobbel "11-Dec-86 12:37")


          (* * Calls the PRINT program for PRINTER, interpreting OPTIONS as a plist of print options.

	  TRANSFERFN is a function applied to the transfer stream to actually send the Interpress master)



    (
PROG
 ((MEDIUM (
OR
 (
LISTGET
 OPTIONS (
QUOTE
 MEDIUM))
			   NSPRINT.DEFAULT.MEDIUM))
	     (STAPLE? (
LISTGET
 OPTIONS (
QUOTE
 STAPLE?)))
	     (TWO.SIDED? (
EQ
 2 (
OR
 (
LISTGET
 OPTIONS (
QUOTE
 #SIDES))
				       EMPRESS#SIDES)))
	     (SENDER.NAME (
OR
 (
LISTGET
 OPTIONS (
QUOTE
 SENDER.NAME))
				(
USERNAME
 NIL NIL T)))
	     (DOCNAME (
OR
 (
LISTGET
 OPTIONS (
QUOTE
 DOCUMENT.NAME))
			    "Document"))
	     PROPERTIES ATTRIBUTES COURIERSTREAM VALUE PRINTOPTIONS STATUS)
	    [
SETQ
 ATTRIBUTES (
BQUOTE
 ((PRINT.OBJECT.NAME , DOCNAME)
					  (PRINT.OBJECT.CREATE.DATE , (
OR
 (
LISTGET
 OPTIONS
										       (
QUOTE

											 
									   DOCUMENT.CREATION.DATE))
									    (
IDATE
)))
					  (SENDER.NAME , SENDER.NAME]
	    [
SETQ
 PRINTOPTIONS (
BQUOTE
 ((COPY.COUNT , (
FIX
 (
OR
 (
LISTGET
 OPTIONS
										  (
QUOTE
 #COPIES))
								       1]
                                                             (* This "option" seems to be required)

	    [
COND

	      ((
SETQ
 VALUE (
LISTGET
 OPTIONS (
QUOTE
 RECIPIENT.NAME)))
		(push
 PRINTOPTIONS (
LIST
 (
QUOTE
 RECIPIENT.NAME)
					     (
OR
 (
STRINGP
 VALUE)
						   (
MKSTRING
 VALUE]
	    [
COND

	      ((
SETQ
 VALUE (
LISTGET
 OPTIONS (
QUOTE
 PRIORITY)))
		(push
 PRINTOPTIONS (
LIST
 (
QUOTE
 PRIORITY.HINT)
					     (
SELECTQ
 VALUE
							((HOLD LOW NORMAL HIGH)
							  VALUE)
							(
\ILLEGAL.ARG
 VALUE]
	    [
COND

	      ((
SETQ
 VALUE (
LISTGET
 OPTIONS (
QUOTE
 MESSAGE)))
		(push
 PRINTOPTIONS (
LIST
 (
QUOTE
 MESSAGE)
					     (
OR
 (
STRINGP
 VALUE)
						   (
MKSTRING
 VALUE]
	    [
COND

	      ((
SETQ
 VALUE (
LISTGET
 OPTIONS (
QUOTE
 PAGES.TO.PRINT)))
                                                             (* A page range to print, (first# last#))

		(
COND

		  ((
AND
 (
LISTP
 VALUE)
			  (
LISTP
 (
CDR
 VALUE))
			  (
NULL
 (
CDDR
 VALUE))
			  (SMALLPOSP (
CAR
 VALUE))
			  (SMALLPOSP (
CADR
 VALUE)))
		    (push
 PRINTOPTIONS (
LIST
 (
QUOTE
 PAGES.TO.PRINT)
						 VALUE)))
		  (T (
\ILLEGAL.ARG
 VALUE]
	RETRY
	    (
COND

	      ((
NOT
 (
SETQ
 COURIERSTREAM (
\NSPRINT.COURIER.OPEN
 PRINTER)))
		(printout PROMPTWINDOW .TAB0 0 "No response from printer " (fetch
 NSPRINTERNAME
									      of
 PRINTER))
		(
DISMISS
 5000)
		(
GO
 RETRY)))
	    (
RESETSAVE
 NIL (
LIST
 (
FUNCTION
 \SPP.RESETCLOSE)
				     COURIERSTREAM))         (* Check the status of the printer.)

	    (bind
 (LASTSTATUS _ 0)
	       do
 (
SETQ
 STATUS (
COURIER.CALL
 COURIERSTREAM (
QUOTE
 PRINTING)
						   (
QUOTE
 GET.PRINTER.STATUS)
						   (
QUOTE
 RETURNERRORS)))
		    [
COND

		      ((
EQ
 (
CAR
 STATUS)
			     (
QUOTE
 ERROR))
			(
COND

			  ((
NOT
 (
EQUAL
 STATUS LASTSTATUS))
			    (printout PROMPTWINDOW T "[From " (fetch
 NSPRINTERNAME of
 PRINTER)
				      " Error: "
				      (
SUBSTRING
 (
CDR
 STATUS)
						   2 -2)
				      "; will retry]")))     (* Wait longer for this problem)

			(
DISMISS
 30000))
		      ((
NEQ
 (
SETQ
 STATUS (
CADR
 (
ASSOC
 (
QUOTE
 SPOOLER)
							      STATUS)))
			      LASTSTATUS)
			(
SELECTQ
 STATUS
				   (Available (
RETURN
))
				   (Busy (printout PROMPTWINDOW T "[From " (fetch
 NSPRINTERNAME
									      of
 PRINTER)
						   " Status: Spooler busy; will retry]"))
				   (
ERROR
 "Printer spooler" STATUS]
		    (
SETQ
 LASTSTATUS STATUS)
		    (
DISMISS
 5000))
	    [
COND

	      ((
OR
 MEDIUM STAPLE? TWO.SIDED?)              (* Check that the printer supports these options.)

		(
SETQ
 PROPERTIES (
COURIER.CALL
 COURIERSTREAM (
QUOTE
 PRINTING)
						   (
QUOTE
 GET.PRINTER.PROPERTIES)
						   (
QUOTE
 RETURNERRORS)))
		(
COND

		  ((
EQ
 (
CAR
 PROPERTIES)
			 (
QUOTE
 ERROR))
		    (
SETQ
 STATUS PROPERTIES)
		    (
GO
 HANDLE.ERROR)))
		[
COND

		  (MEDIUM (
COND

			    ((
SETQ
 VALUE (
\NSPRINT.MEDIUM.CHECK
 MEDIUM
								    (
CADR
 (
ASSOC
 (
QUOTE
 MEDIA)
										     PROPERTIES))
								    PRINTER))
			      (push
 PRINTOPTIONS (
LIST
 (
QUOTE
 MEDIUM.HINT)
							   VALUE))
			      (
SETQ
 MEDIUM]
		[
COND

		  (STAPLE? (
COND

			     ((
CADR
 (
ASSOC
 (
QUOTE
 STAPLE)
					       PROPERTIES))
			       (push
 PRINTOPTIONS (
LIST
 (
QUOTE
 STAPLE)
							    T))
			       (
SETQ
 STAPLE?))
			     (T (printout PROMPTWINDOW .TAB0 0 
					  "[Printer does not support stapled copies]"]
		(
COND

		  (TWO.SIDED? (
COND

				((
CADR
 (
ASSOC
 (
QUOTE
 TWO.SIDED)
						  PROPERTIES))
				  (push
 PRINTOPTIONS (
QUOTE
 (TWO.SIDED T)))
				  (
SETQ
 TWO.SIDED?))
				(T (printout PROMPTWINDOW .TAB0 0 
					     "Printer does not support two-sided copies"]

          (* * Finally, send the print document)



	    (
SETQ
 STATUS (
COURIER.CALL
 COURIERSTREAM (
QUOTE
 PRINTING)
					   (
QUOTE
 PRINT)
					   TRANSFERFN ATTRIBUTES PRINTOPTIONS (
QUOTE
 RETURNERRORS)))
	    (
COND

	      ((
NEQ
 (
CAR
 STATUS)
		      (
QUOTE
 ERROR))
		(
RETURN
 STATUS)))
	HANDLE.ERROR
	    (
ERROR
 (
CONCAT
 "Unexpected error from " (fetch
 NSPRINTERNAME of
 PRINTER)
			       " attempting to print " DOCNAME "
RETURN to try again.")
		     (
CDR
 STATUS))
	    (
CLOSEF
 COURIERSTREAM)
	    (
GO
 RETRY])

(COPY.TEXT.TO.IMAGE

  [LAMBDA (
INFILE
 IMAGESTREAM FONTS TABS)                  (* Randy.Gobbel "28-Jan-87 18:22")

                                                             (* Copy text to an image stream, obeying PSPOOL 

							     control characters)

    (LET* ((IMAGESTREAM (
GETSTREAM
 IMAGESTREAM (
QUOTE
 OUTPUT)))
	   C FC (FONTARRAY (
FONTMAPARRAY
 FONTS))
	   (
MAXFONT
 (
ARRAYSIZE
 FONTARRAY))
	   (INSTRM (
GETSTREAM
 INFILE (
QUOTE
 INPUT)))
	   (INEOLC (
GETFILEINFO
 INSTRM (
QUOTE
 EOL)))
	   (RIGHTMAR (
DSPRIGHTMARGIN
 NIL IMAGESTREAM)))
          (replace
 (STREAM ENDOFSTREAMOP) of
 INSTRM with
 (
FUNCTION
 ZERO))
          (bind
 (SHIFTEDCHARSET _ (UNFOLD (ffetch
 CHARSET of
 INSTRM)
					    256))
	     do
 (
BLOCK
)
		  (
COND

		    ((
AND
 (
EQ
 0 (
SETQ
 C (\NSIN INSTRM SHIFTEDCHARSET SHIFTEDCHARSET)))
			    (
EOFP
 INSTRM))
		      (
RETURN
))
		    ((
AND
 RIGHTMAR (
IGREATERP
 (
DSPXPOSITION
 NIL IMAGESTREAM)
						  RIGHTMAR))
                                                             (* Not to walk off the right edge of the paper)

		      (
TERPRI
 IMAGESTREAM)))
		  (
COND

		    ([
IGREATERP
 C (
CONSTANT
 (
APPLY
 (
FUNCTION
 MAX)
							 (
CHARCODE
 (^F CR LF ^L TAB NULL]
		      (
\OUTCHAR
 IMAGESTREAM C))
		    (T (SELCHARQ C
				 [^F                         (* Font shift)

				     (SELCHARQ (
SETQ
 FC (\NSIN INSTRM SHIFTEDCHARSET SHIFTEDCHARSET)
						 )
					       [^T           (* tab to absolute pos.)

						   (
COND

						     ((
EQ
 0 (
SETQ
 FC (\NSIN INSTRM SHIFTEDCHARSET 
										SHIFTEDCHARSET)))
						       (
\OUTCHAR
 IMAGESTREAM (
CHARCODE
 ^F))
						       (
\OUTCHAR
 IMAGESTREAM (
CHARCODE
 ^T))
						       (
AND
 (\EOFP INSTRM)
							      (
RETURN
))
						       (
\OUTCHAR
 IMAGESTREAM FC))
						     (T 

          (* TEXTDEFAULTTABS is a hack, since it depends on the units of the stream. Should really be a property of the 

	  stream or imagetype, or defined in terms of standard scale)



							(
SETQ
 FC
							  (
OR
 (
CAR
 (
NTH
 (
OR
 TABS 
										  TEXTDEFAULTTABS)
									      FC))
								(
ERROR
 
								  "Undefined absolute tab number"
									 FC)))
							(
DSPXPOSITION
 FC IMAGESTREAM]
					       (
NULL
 (
\OUTCHAR
 IMAGESTREAM (
CHARCODE
 ^F))
						       (
AND
 (\EOFP INSTRM)
							      (
RETURN
))
						       (
\OUTCHAR
 IMAGESTREAM FC)
                                                             (* EOS after ^F)

						       )
					       (
COND

						 ((
AND
 (
IGEQ
 MAXFONT FC)
							 (
NEQ
 FC 0))
						   (
DSPFONT
 (
ELT
 FONTARRAY FC)
							      IMAGESTREAM))
						 (T (
\OUTCHAR
 IMAGESTREAM (
CHARCODE
 ^F))
						    (
\OUTCHAR
 IMAGESTREAM C]
				 (CR                         (* Don't call generic \CHECKEOLC macro, because we are

							     trying to disciminate the raw CR and raw LF cases for 

							     printing)


          (* Note: Assumes, as does \CHECKEOLC and \FILEOUTCHARFN that the LF character will be generated immediately after 

	  the CR, independent of the encoding, perhaps by a file-transfer protocol)



				     (
SELECTQ
 INEOLC
						(CR (
TERPRI
 IMAGESTREAM))
						[CRLF (
COND

							((
EQ
 (
CHARCODE
 LF)
							       (
\PEEKBIN
 INSTRM T))
							  (
BIN
 INSTRM)
							  (
TERPRI
 IMAGESTREAM))
							(T (
DSPXPOSITION
 (
DSPLEFTMARGIN
 NIL 
										      IMAGESTREAM)
									   IMAGESTREAM)
                                                             (* Move to left margin)

							   ]
						(
DSPXPOSITION
 (
DSPLEFTMARGIN
 NIL IMAGESTREAM)
								IMAGESTREAM)))
				 (
TAB
 (
OR
 (
NLSETQ
 (
RELMOVETO
 (
TIMES
 (
CHARWIDTH

										(
CHARCODE
 SPACE)
										IMAGESTREAM)
									      8)
								     0 IMAGESTREAM))
					      (
\OUTCHAR
 IMAGESTREAM C)))
				 [LF (
COND

				       ((
EQ
 INEOLC (
QUOTE
 LF))
					 (
TERPRI
 IMAGESTREAM))
				       (T (
DSPXPOSITION
 (
PROG1
 (
DSPXPOSITION
 NIL IMAGESTREAM)
								   (
TERPRI
 IMAGESTREAM))
							  IMAGESTREAM]
				 (
NULL
 (
AND
 (
EOFP
 INSTRM)
						(
RETURN
))
					 (
\OUTCHAR
 IMAGESTREAM C))
				 (
\OUTCHAR
 IMAGESTREAM C])
)
(* * fgh&rht 8/6/86: Insure that correct imageobj HPRINTMACRO is at front of the HPRINTMACROS 
list.)


(DEFINEQ

(WRITE.IMAGEOBJ

  (LAMBDA (IMAGEOBJ STREAM)                                  (* rrb "19-Dec-84 14:50")

                                                             (* HPRINT function for writing out IMAGE OBJECTS)

                                                             (* write out the name of the function to read things 

							     back in with.)

    (
PRINT
 (
LIST
 (fetch
 (IMAGEFNS GETFN) of
 (fetch
 (IMAGEOBJ IMAGEOBJFNS) of
 IMAGEOBJ)))
	     STREAM HPRINTRDTBL)
    (
APPLY*
 (fetch
 (IMAGEFNS PUTFN) of
 (fetch
 (IMAGEOBJ IMAGEOBJFNS) of
 IMAGEOBJ))
	      IMAGEOBJ STREAM)
    T))
)

(ADDTOVAR HPRINTMACROS
 (IMAGEOBJ . WRITE.IMAGEOBJ))
(PUTPROPS KOTOSYSTEMPATCHES COPYRIGHT ("Xerox Corporation" 1986 1987))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (888 13234 (SHAPEW 898 . 2993) (\NSPRINT.INTERNAL 2995 . 8853) (COPY.TEXT.TO.IMAGE 8855
 . 13232)) (13343 14004 (WRITE.IMAGEOBJ 13353 . 14002)))))
STOP