;;; -*- Mode:Lisp; Package:Press; Base:8 -*-
;;; PRESS File and DOVER software
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology **

(DEFVAR PRESS-SPECIAL-VARIABLES NIL)

(DEFMACRO DEFINE-PRESS-VARIABLE (NAME &OPTIONAL FORM (DEFVAR-P T))
  `(SI:DEFINE-SPECIAL-VARIABLE ,NAME ,FORM PRESS-SPECIAL-VARIABLES ,DEFVAR-P))

(DEFMACRO BIND-PRESS-VARIABLES (&BODY BODY)
  `(PROGW PRESS-SPECIAL-VARIABLES
     (UNWIND-PROTECT
       (PROGN . ,BODY)
       (DEALLOCATE-RESOURCE 'PRESS-PAGE-ENTITY-BUFFER PRESS-PAGE-ENTITY-BUFFER))))

(DEFINE-PRESS-VARIABLE PRESS-USE-EFTP NIL)	;T => EFTP, NIL => Chaos
(DEFVAR DOVER-ADDRESS 1002)			;2#2#

;Don't get too strung out by the little frob at the end of the message.
(DEFUN PRINT-DOVER-STATUS ()
  (LET ((CONN (CHAOS:OPEN-FOREIGN-CONNECTION DOVER-ADDRESS 21)))
    (UNWIND-PROTECT
      (DO ((N-RETRIES 10. (1- N-RETRIES))
	   (PUP))
	  ((ZEROP N-RETRIES)
	   (FORMAT T "~&Dover is not responding (may be printing).~%"))
	(CHAOS:TRANSMIT-PUP CONN (CHAOS:GET-PUP CONN 200 0) 0)
	(COND ((SETQ PUP (CHAOS:RECEIVE-PUP CONN))
	       (COND ((= (CHAOS:PUP-TYPE PUP) 201)
		      (FORMAT T "~&Dover status: ~[~;Spooler shut off.~;Spooler available.~
				 ~;Spooler busy.~]  ~A~%"
			      (CHAOS:PUP-WORD PUP 0)
			      (CHAOS:PUP-STRING PUP 2))
		      (CHAOS:RETURN-PKT PUP)
		      (RETURN T))
		     (T (CHAOS:RECEIVED-RANDOM-PUP PUP))))))
      (CHAOS:REMOVE-CONN CONN))))

(DEFUN PRINT-DOVER-QUEUE ()
  ;; Avoid opening a new file job to MC if logged in to AI.
  (FS:VIEWF (IF (EQ FS:USER-LOGIN-MACHINE
		    (SI:PARSE-HOST "AI"))
		"AI: DVR: FOO; .FILE. (DIR)"
		"MC: DVR: FOO; .FILE. (DIR)")))

;;; Routines for building Press pages and shipping them out an EFTP connection
;;; The state is all in special variables so you can only do one at a time
;;; Later this might be made into a more stream-like thing (as a "resource")

(DEFINE-PRESS-VARIABLE PRESS-INTERPRET-XGP-ESCAPE NIL)	;177 is special character in input
(DEFINE-PRESS-VARIABLE PRESS-EFTP-STREAM NIL)	;EFTP connection we send through
(DEFINE-PRESS-VARIABLE PRESS-N-CHARS)		;Number of characters sent this part
(DEFINE-PRESS-VARIABLE PRESS-CURRENT-RECORD-NUMBER 0)	;Record number within file
(DEFINE-PRESS-VARIABLE PRESS-X)			;X position computed as characters sent
(DEFINE-PRESS-VARIABLE PRESS-Y)			;Y ..
(DEFINE-PRESS-VARIABLE PRESS-BASELINE-Y)	;Baseline Y, usually the same
(DEFINE-PRESS-VARIABLE PRESS-INTERCHAR-SPACING NIL)	;Between all chars if non-NIL
(DEFINE-PRESS-VARIABLE PRESS-INTERLINE-SPACING NIL)	;Between all lines if non-NIL
(DEFINE-PRESS-VARIABLE PRESS-PAGE-NUMBER 1)	;Serial number of page
(DEFINE-PRESS-VARIABLE PRESS-END-PAGE-HOOK NIL)	;If non-NIL, function to call
(DEFINE-PRESS-VARIABLE PRESS-PENDING-CHARS)	;Number of chars output but not yet known
						;about at the "entity" level

(DEFINE-PRESS-VARIABLE PRESS-DATA-LIST-START)	;Value of PRESS-N-CHARS at start of entity
(DEFINE-PRESS-VARIABLE PRESS-ENTITY-LIST-START)	;Value of (size of entity buffer) at ..

(DEFVAR PRESS-PAGE-ENTITY-BUFFER-EXTENSION-SIZE 4000.)
(DEFRESOURCE PRESS-PAGE-ENTITY-BUFFER ()
  :CONSTRUCTOR (MAKE-ARRAY PRESS-PAGE-ENTITY-BUFFER-EXTENSION-SIZE
			   ':TYPE 'ART-8B
			   ':LEADER-LIST '(0)))
(DEFINE-PRESS-VARIABLE PRESS-PAGE-ENTITY-BUFFER (ALLOCATE-RESOURCE 'PRESS-PAGE-ENTITY-BUFFER))
						;This holds the "entity" portion of the
						;current page

(DEFINE-PRESS-VARIABLE PRESS-PART-LIST NIL)	;List of elements (part-type record-number
						;		   n-records n-padding-words)
(DEFINE-PRESS-VARIABLE PRESS-FONT-LIST NIL)	;List of elements (family-name face-name
						;		   point-size rotation
						;		   width height width-table)
(DEFINE-PRESS-VARIABLE PRESS-CURRENT-FONT NIL)	;Element for selected font

(DEFINE-PRESS-VARIABLE DOVER-X0 2000.)		;2 cm left margin
(DEFINE-PRESS-VARIABLE DOVER-Y0 (FIX (* 9.8 2540.)))	;Where the page number goes
(DEFINE-PRESS-VARIABLE DOVER-Y1 (FIX (* 9.5 2540.)))	;Where the text starts
(DEFINE-PRESS-VARIABLE DOVER-Y2 (FIX (* 0.5 2540.)))	;Margin at the bottom of the page
(DEFINE-PRESS-VARIABLE LINE-WIDTH 25.)		;Line width .01 inch
;(DEFVAR DIAGONAL-LINE-WIDTH 18.)		;Make darkness come out even
;This provides nice thin lines, for thinner lines you might want 2 instead of 4
(DEFVAR PRESS-LINE-FONT '(NEWVEC "" 4 0 0 0 NIL))
;The way these fonts work is that the point size is the thickness of the line,
;and NEWVEC has round ends, HNEWVEC has horizontal ends, and SNEWVEC has square
;ends (that is diamond on a 45-degree line).  The way the characters are organized
;is:  Consider the right half-box, and all its radii, that is lines proceeding
;clockwise from straight-up through straight-down.  The fonts contain vectors to
;all points with integral coordinates on half-boxes of various sizes.  The widths
;of the characters are set up so that the vectors chain properly.
;
;	000-100    The 16.-bit box
;	120-160    The 8.-bit box
;	170-210    The 4.-bit box
;	214-224    The 2.-bit box
;	226-232    The 1.-bit box
;	240        The 0-bit box (or isolated point).

(DEFINE-PRESS-VARIABLE PRESS-XGP-UNDERLINE-START-X)
(DEFINE-PRESS-VARIABLE PRESS-XGP-FONT-LIST NIL)

;;;; Output to the Data and Entity Lists

;;; Macros to output things to the entity buffer

(DEFMACRO PRESS-ENTITY-BYTE (BYTE)
  `(ARRAY-PUSH-EXTEND PRESS-PAGE-ENTITY-BUFFER ,BYTE
		      PRESS-PAGE-ENTITY-BUFFER-EXTENSION-SIZE))

(DEFMACRO PRESS-ENTITY-WORD (WORD)
  (IF (ATOM WORD)
      `(PROGN (ARRAY-PUSH-EXTEND PRESS-PAGE-ENTITY-BUFFER (LDB 1010 ,WORD)
				 PRESS-PAGE-ENTITY-BUFFER-EXTENSION-SIZE)
	      (ARRAY-PUSH-EXTEND PRESS-PAGE-ENTITY-BUFFER (LDB 0010 ,WORD)
				 PRESS-PAGE-ENTITY-BUFFER-EXTENSION-SIZE))
      `(LET ((FOO ,WORD))
	 (PRESS-ENTITY-WORD FOO))))

(DEFMACRO PRESS-ENTITY-32WORD (WORD)
  `(LET ((FOO ,WORD))
     (ARRAY-PUSH-EXTEND PRESS-PAGE-ENTITY-BUFFER (LDB 3010 FOO)
			PRESS-PAGE-ENTITY-BUFFER-EXTENSION-SIZE)
     (ARRAY-PUSH-EXTEND PRESS-PAGE-ENTITY-BUFFER (LDB 2010 FOO)
			PRESS-PAGE-ENTITY-BUFFER-EXTENSION-SIZE)
     (ARRAY-PUSH-EXTEND PRESS-PAGE-ENTITY-BUFFER (LDB 1010 FOO)
			PRESS-PAGE-ENTITY-BUFFER-EXTENSION-SIZE)
     (ARRAY-PUSH-EXTEND PRESS-PAGE-ENTITY-BUFFER (LDB 0010 FOO)
			PRESS-PAGE-ENTITY-BUFFER-EXTENSION-SIZE)))


;;; Macros to output to the data list.  These do not catch format chars (see PRESS-CHAR).

(DEFMACRO PRESS-DATA-BYTE (BYTE)
  `(PROGN (FUNCALL PRESS-EFTP-STREAM ':TYO ,BYTE)
	  (SETQ PRESS-N-CHARS       (1+ PRESS-N-CHARS))  ))

(DEFMACRO PRESS-DATA-WORD (WORD)
  `(LET ((FOO ,WORD))
     (PRESS-DATA-BYTE (LDB 1010 FOO))
     (PRESS-DATA-BYTE (LDB 0010 FOO)) ))

(DEFMACRO PRESS-DATA-32WORD (WORD)
  `(LET ((FOO ,WORD))
     (PRESS-DATA-BYTE (LDB 3010 FOO))
     (PRESS-DATA-BYTE (LDB 2010 FOO))
     (PRESS-DATA-BYTE (LDB 1010 FOO))
     (PRESS-DATA-BYTE (LDB 0010 FOO))))


;;;; PRESS FORMAT DECLARATIONS


;;; Set up so #,<SET-X> turns into 356 -- except the compiler chokes!!

(DEFMACRO DEFPRESS (NAME . BODY)
  `(DEFVAR ,NAME ,(CAR BODY)))

;;; These are ENTITY LIST COMMANDS

(DEFPRESS <SHOW-CHARACTERS-SHORT>		  0 + (N-1 1))
(DEFPRESS <SKIP-CHARACTERS-SHORT>		 40 + (N-1 1))
(DEFPRESS <SHOW-CHARACTERS-AND-SKIP>		100 + (N-1 1))
(DEFPRESS <SET-SPACE-X-SHORT>			140 + (X 2))
(DEFPRESS <SET-SPACE-Y-SHORT>			150 + (Y 2))
(DEFPRESS <FONT>				160 + (FONT 1))
(DEFPRESS <SKIP-CONTROL-BYTES-IMMEDIATE>	353 (N 1))
(DEFPRESS <ALTERNATIVE>				354 (EL-TYPES 2) (EL-BYTES 4) (DL-BYTES 4))
(DEFPRESS <ONLY-ON-COPY>			355 (N 1))
(DEFPRESS <SET-X>				356 (X 2))
(DEFPRESS <SET-Y>				357 (Y 2))
(DEFPRESS <SHOW-CHARACTERS>			360 (N 1))
(DEFPRESS <SKIP-CHARACTERS>			361 (N 1))
(DEFPRESS <SKIP-CONTROL-BYTES>			362 (N 2) (TYPE 1))
(DEFPRESS <SHOW-CHARACTER-IMMEDIATE>		363 (CHAR 1))
(DEFPRESS <SET-SPACE-X>				364 (S 2))
(DEFPRESS <SET-SPACE-Y>				365 (S 2))
(DEFPRESS <RESET-SPACE>				366)
(DEFPRESS <SPACE>				367)
(DEFPRESS <SET-BRIGHTNESS>			370 (B 1))
(DEFPRESS <SET-HUE>				371 (H 1))
(DEFPRESS <SET-SATURATION>			372 (S 1))
(DEFPRESS <SHOW-OBJECT>				373 (N 2))
(DEFPRESS <SHOW-DOTS>				374 (N 4))
(DEFPRESS <SHOW-DOTS-OPAQUE>			375 (N 4))
(DEFPRESS <SHOW-RECTANGLE>			376 (WIDTH 2) (HEIGHT 2))
(DEFPRESS <NOP>					377)


;;; These are DATA LIST COMMANDS

(DEFPRESS <<MOVETO>>				  0)
(DEFPRESS <<DRAWTO>>				  1)
(DEFPRESS <<DRAWCURVE>>				  2)

(DEFPRESS <<SET-CODING>>			  1)
(DEFPRESS <<SET-WINDOW>>			  1)
(DEFPRESS <<SET-MODE>>				  2)
(DEFPRESS <<SET-SIZE>>				  2)
(DEFPRESS <<DOTS-FOLLOW>>			  3)
(DEFPRESS <<GET-DOTS-FROM-FILE>>		  4)
(DEFPRESS <<GET-DOTS-FROM-PRESS-FILE>>		  5)
(DEFPRESS <<SET-SAMPLING-PROPERTIES>>		  6)

(DEFPRESS <<SSP-INPUT-INTENSITY>>		  0)
(DEFPRESS <<SSP-OUTPUT-INTENSITY>>		  1)
(DEFPRESS <<SSP-SCREEN>>			  2)
(DEFPRESS <<SSP-DOT>>				  3)


;;;; Start Press File

;Start generating a press file.  Optional argument is EtherNet host address number
;or a filename string (for delayed or spooled printing)
;There really should be code in here like in the various dover programs,
;that doesn't try to send if Spruce is printing.  Then again, maybe not,
;since the Lisp machine is not really a timesharing system.

(DEFUN PRESS-START-FILE (&OPTIONAL (HOST-ADDRESS DOVER-ADDRESS))
  (OR (BOUNDP 'FONT-WIDTH-DATA)
      (LOAD-FONT-WIDTHS "SYS: PRESS-FONTS; FONTS WIDTHS >"))
  (SETQ PRESS-EFTP-STREAM (PRESS-OPEN-EFTP-STREAM HOST-ADDRESS DOVER-ADDRESS)))

(DEFUN PRESS-OPEN-EFTP-STREAM (HOST-ADDRESS DOVER-ADDRESS)
  (IF (NUMBERP HOST-ADDRESS)
      (IF PRESS-USE-EFTP (CHAOS:MAKE-EFTP-WRITE-STREAM HOST-ADDRESS T)
	  (LET ((CONN (CHAOS:CONNECT "AI-CHAOS-11" "DOVER")))
	    (AND (STRINGP CONN)
		 (FERROR NIL
			 "~A - cannot connect to DOVER server at AI-CHAOS-11" CONN))
	    (CHAOS:STREAM CONN)))
      (OPEN HOST-ADDRESS '(:WRITE :FIXNUM :BYTE-SIZE 8))))

;;;; Finish Press File

;Output font directory, part directory, document directory
(DEFUN PRESS-END-FILE (FILE-NAME CREATION-DATE
		       &OPTIONAL (N-COPIES 1) (USER-NAME USER-ID))
  ;; The font directory part
  (STORE-ARRAY-LEADER 0 PRESS-PAGE-ENTITY-BUFFER 0)
  (DO ((L PRESS-FONT-LIST (CDR L))		; *** crock
       (FONT-NUMBER 0 (1+ FONT-NUMBER))
       (FONT))
      ((NULL L))
    (SETQ FONT (CAR L))
    (PRESS-ENTITY-WORD 16.)			;Length in words
    (PRESS-ENTITY-BYTE 0)			;Font set 0 **** crock
    (PRESS-ENTITY-BYTE FONT-NUMBER)
    (PRESS-ENTITY-BYTE 0)			;First char
    (PRESS-ENTITY-BYTE 177)			;Last char
    (PRESS-ENTITY-BCPL-STRING (STRING-UPCASE (FIRST FONT)) 20.)	;Family
    (PRESS-ENTITY-BYTE (ENCODE-PRESS-FACE (SECOND FONT)))	;Face code
    (PRESS-ENTITY-BYTE 0)			;Source (same as first char)
    (PRESS-ENTITY-WORD (THIRD FONT))		;Positive is points, negative is micas
    (PRESS-ENTITY-WORD (FOURTH FONT)))		;Rotation in minutes of arc anticlockwise
  (PRESS-ENTITY-WORD 0)				;End mark
  (FUNCALL PRESS-EFTP-STREAM ':STRING-OUT PRESS-PAGE-ENTITY-BUFFER)
  (PRESS-FINISH-PART (ARRAY-LEADER PRESS-PAGE-ENTITY-BUFFER 0) 1)
  ;; That took care of the font directory, now the part directory
  (STORE-ARRAY-LEADER 0 PRESS-PAGE-ENTITY-BUFFER 0)
  (DOLIST (X (REVERSE PRESS-PART-LIST))		;NOT nreverse!
    (PRESS-ENTITY-WORD (FIRST X))		;Part type
    (PRESS-ENTITY-WORD (SECOND X))		;Starting record number
    (PRESS-ENTITY-WORD (THIRD X))		;Number of records
    (PRESS-ENTITY-WORD (FOURTH X)))		;Amount of padding
  (FUNCALL PRESS-EFTP-STREAM ':STRING-OUT PRESS-PAGE-ENTITY-BUFFER)
  (PRESS-FINISH-PART (ARRAY-LEADER PRESS-PAGE-ENTITY-BUFFER 0) 'FOO)
  ;; The document directory
  (STORE-ARRAY-LEADER 0 PRESS-PAGE-ENTITY-BUFFER 0)
  (PRESS-ENTITY-WORD 27183.)			;Password
  (PRESS-ENTITY-WORD (1+ PRESS-CURRENT-RECORD-NUMBER))	;File size
  (PRESS-ENTITY-WORD (1- (LENGTH PRESS-PART-LIST)))	;Number of parts
  (PRESS-ENTITY-WORD (SECOND (CAR PRESS-PART-LIST)))	;Record number of part directory
  (PRESS-ENTITY-WORD (THIRD (CAR PRESS-PART-LIST)))	;Number of records in part dir
  (PRESS-ENTITY-WORD 0)				;Back-pointer
  (PRESS-ENTITY-32WORD 0)			;[Date]
  (PRESS-ENTITY-WORD 1)				;First copy to print
  (PRESS-ENTITY-WORD N-COPIES)			;Last copy to print
  (PRESS-ENTITY-WORD -1)			;Print all pages
  (PRESS-ENTITY-WORD -1)			;..
  (PRESS-ENTITY-WORD -1)			;Default printing mode
  (DOTIMES (I (- 200 13.))			;Padding
    (PRESS-ENTITY-WORD -1))
  (PRESS-ENTITY-BCPL-STRING FILE-NAME 52.)
  (PRESS-ENTITY-BCPL-STRING USER-NAME 32.)
  (PRESS-ENTITY-BCPL-STRING CREATION-DATE 40.)
  (FUNCALL PRESS-EFTP-STREAM ':STRING-OUT PRESS-PAGE-ENTITY-BUFFER)
  (PRESS-FINISH-PART (ARRAY-LEADER PRESS-PAGE-ENTITY-BUFFER 0) 1)
  (FUNCALL PRESS-EFTP-STREAM ':CLOSE)
  (FUNCALL PRESS-EFTP-STREAM ':SEND-IF-HANDLES ':TRUENAME))

;;;; Pages

;Start a page

(DEFUN PRESS-OPEN-PAGE ()
  (STORE-ARRAY-LEADER 0 PRESS-PAGE-ENTITY-BUFFER 0)
  (SETQ PRESS-N-CHARS 0))


;;; Finish a page.

(DEFUN PRESS-CLOSE-PAGE ()
  (IF PRESS-END-PAGE-HOOK
      (FUNCALL PRESS-END-PAGE-HOOK))		; User must open his own entity
  ;; Make the length of the data buffer a multiple of a word
  (COND ((ODDP PRESS-N-CHARS)
	 (FUNCALL PRESS-EFTP-STREAM ':TYO 0)
	 (SETQ PRESS-N-CHARS (1+ PRESS-N-CHARS))))
  ;; Output a zero word between the data list and the entity list
  (FUNCALL PRESS-EFTP-STREAM ':TYO 0)
  (FUNCALL PRESS-EFTP-STREAM ':TYO 0)
  ;; Output the entity buffer
  (FUNCALL PRESS-EFTP-STREAM ':STRING-OUT PRESS-PAGE-ENTITY-BUFFER)
  ;; Pad to a record (512-byte) boundary, and advance PRESS-CURRENT-RECORD-NUMBER
  (PRESS-FINISH-PART (+ PRESS-N-CHARS 2 (ARRAY-ACTIVE-LENGTH PRESS-PAGE-ENTITY-BUFFER)) 0)
  (SETQ PRESS-PAGE-NUMBER (1+ PRESS-PAGE-NUMBER))
  )

;Hair shared between page parts and other parts
(DEFUN PRESS-FINISH-PART (NBYTES PART-TYPE &AUX NWORDS NRECORDS PADDING)
  (CHECK-ARG NBYTES EVENP "an even number of bytes")
  (SETQ NWORDS (// NBYTES 2))
  (SETQ PADDING (\ (- 256. (\ NWORDS 256.)) 256.))
  (SETQ NWORDS (+ NWORDS PADDING))
  (SETQ NRECORDS (// NWORDS 256.))
  (DOTIMES (I (* PADDING 2))
    (FUNCALL PRESS-EFTP-STREAM ':TYO 0))
  (PUSH (LIST PART-TYPE PRESS-CURRENT-RECORD-NUMBER NRECORDS PADDING)
	PRESS-PART-LIST)
  (SETQ PRESS-CURRENT-RECORD-NUMBER (+ PRESS-CURRENT-RECORD-NUMBER NRECORDS)))


;;; press-start-page is an ungodly crock that is here just for existing programs
;;; using press-open-page and explicitly opening entities is cleaner
(DEFUN PRESS-START-PAGE ()
  (PRESS-OPEN-PAGE)
  (PRESS-START-ENTITY)
  (PRESS-SET-CURSOR 0 DOVER-Y1))		;Put cursor at top of page

; This is also here for existing programs
(DEFUN PRESS-END-PAGE ()
  (AND PRESS-END-PAGE-HOOK (FUNCALL PRESS-END-PAGE-HOOK))	;Let user put titles etc.
  (PRESS-END-ENTITY)
  (LET ((PRESS-END-PAGE-HOOK NIL))
    (PRESS-CLOSE-PAGE)))


;;;; Entities

;;;Start an entity

(DEFUN PRESS-OPEN-ENTITY ()
  (SETQ PRESS-DATA-LIST-START   PRESS-N-CHARS
	PRESS-ENTITY-LIST-START (ARRAY-ACTIVE-LENGTH PRESS-PAGE-ENTITY-BUFFER)
	PRESS-PENDING-CHARS     0))

;Finish the current entity.  You can start another if you like.
(DEFUN PRESS-CLOSE-ENTITY (&OPTIONAL (X-OFF DOVER-X0) (Y-OFF DOVER-Y2)
				     (WIDTH (*  85. 254.)) (HEIGHT (* 11. 2540.)))
  (PRESS-PUT-PENDING-CHARS)
  ;; Pad entity to word boundary with NOP
  (AND (ODDP (ARRAY-LEADER PRESS-PAGE-ENTITY-BUFFER 0))
       (PRESS-ENTITY-BYTE 377))
  ;; Entity trailer
  (PRESS-ENTITY-BYTE 0)				;Type     **** crocks
  (PRESS-ENTITY-BYTE 0)				;Font set ****
  (PRESS-ENTITY-32WORD PRESS-DATA-LIST-START)	;Begin-byte
  (PRESS-ENTITY-32WORD (- PRESS-N-CHARS PRESS-DATA-LIST-START))	;Byte-length
  (PRESS-ENTITY-WORD X-OFF)			;X offset (left margin)
  (PRESS-ENTITY-WORD Y-OFF)			;Y offset (bottom margin)
  (PRESS-ENTITY-WORD 0)				;Left     ****
  (PRESS-ENTITY-WORD 0)				;Bottom   ****
  (PRESS-ENTITY-WORD WIDTH)			;Width
  (PRESS-ENTITY-WORD HEIGHT)			;Height
  (PRESS-ENTITY-WORD				;Entity length
    (// (- (+ (ARRAY-ACTIVE-LENGTH PRESS-PAGE-ENTITY-BUFFER) 2)
	   PRESS-ENTITY-LIST-START)
	2)))

;Finish the current entity if the entity buffer is getting full.
;This will cause you to lose your cursor position and selected font.
;The problem is that if you have more than 32768 bytes in an entity,
;the Alto suffers from 16-bit brain-rot.
(DEFUN PRESS-MAYBE-NEW-ENTITY ()
  (COND ((> (ARRAY-ACTIVE-LENGTH PRESS-PAGE-ENTITY-BUFFER) 25000.)
	 (PRESS-END-ENTITY)
	 (PRESS-START-ENTITY))))

;;; grandfather version of PRESS-OPEN-ENTITY
(DEFUN PRESS-START-ENTITY (&AUX TEM)
  (PRESS-OPEN-ENTITY)
  (AND PRESS-CURRENT-FONT			;Restore font
       (SETQ TEM (FIND-POSITION-IN-LIST PRESS-CURRENT-FONT PRESS-FONT-LIST))
       (PRESS-SELECT-FONT TEM)))

(DEFUN PRESS-END-ENTITY ()
  (PRESS-CLOSE-ENTITY))

;;;; Random Functions

;Set (X,Y) position on the page
(DEFUN PRESS-SET-CURSOR (X Y)
  (PRESS-PUT-PENDING-CHARS)
  (PRESS-ENTITY-BYTE 356)	;Set-X
  (PRESS-ENTITY-WORD X)
  (PRESS-ENTITY-BYTE 357)	;Set-Y
  (PRESS-ENTITY-WORD Y)
  (SETQ PRESS-X X PRESS-Y Y))

;Put show-chars command for any pending characters
(DEFUN PRESS-PUT-PENDING-CHARS ()
  (COND ((ZEROP PRESS-PENDING-CHARS) NIL)
	(( PRESS-PENDING-CHARS 40) (PRESS-ENTITY-BYTE (1- PRESS-PENDING-CHARS)))
	(T (DO () ((< PRESS-PENDING-CHARS 400))
	     (PRESS-ENTITY-BYTE 360)
	     (PRESS-ENTITY-BYTE 377)
	     (SETQ PRESS-PENDING-CHARS (- PRESS-PENDING-CHARS 377)))
	   (PRESS-ENTITY-BYTE 360)
	   (PRESS-ENTITY-BYTE PRESS-PENDING-CHARS)))
  (SETQ PRESS-PENDING-CHARS 0))

;Output a character.  May even be a format effector.
(DEFUN PRESS-CHAR (CHAR)
  (COND ((< CHAR 200)				;Printing
	 (FUNCALL PRESS-EFTP-STREAM ':TYO CHAR)
	 (SETQ PRESS-N-CHARS (1+ PRESS-N-CHARS))
	 (SETQ PRESS-PENDING-CHARS (1+ PRESS-PENDING-CHARS))
	 (LET ((WIDTH (AREF (SEVENTH PRESS-CURRENT-FONT) CHAR)))
	   (IF (MINUSP WIDTH) (FORMAT ERROR-OUTPUT
				      "~&~C (~O) undefined character in ~A~D~A~%"
				      CHAR CHAR
				      (FIRST PRESS-CURRENT-FONT)
				      (THIRD PRESS-CURRENT-FONT)
				      (SECOND PRESS-CURRENT-FONT))
	       (SETQ PRESS-X (+ WIDTH PRESS-X))))
	 (AND PRESS-INTERCHAR-SPACING
	      (PRESS-SET-CURSOR (+ PRESS-X PRESS-INTERCHAR-SPACING) PRESS-Y)))
	((= CHAR #\TAB)
	 ;; The bounding box seems to be wedged, it's not the same as the character
	 ;; width in fixed-width fonts.  So use the width of space.
	 (LET ((TAB-WIDTH (* 8 (AREF (SEVENTH PRESS-CURRENT-FONT) #\SP))))
	   (PRESS-SET-CURSOR (* (1+ (// PRESS-X TAB-WIDTH)) TAB-WIDTH) PRESS-Y)))
	((= CHAR #\CR)
	 (LET ((Y (- PRESS-Y (OR PRESS-INTERLINE-SPACING (SIXTH PRESS-CURRENT-FONT)))))
	   (IF (MINUSP Y) (PRESS-CHAR #\FORM)
	       (PRESS-SET-CURSOR 0 Y)))
	 (SETQ PRESS-BASELINE-Y PRESS-Y
	       PRESS-INTERCHAR-SPACING NIL))
	((= CHAR #\FORM)
	 (PRESS-END-PAGE)
	 (PRESS-START-PAGE)
	 (SETQ PRESS-INTERCHAR-SPACING NIL)))
  NIL)

;Output a string.  May contain format effectors.
(DEFUN PRESS-STRING (STRING &OPTIONAL (FROM 0) TO)
  (SETQ STRING (STRING STRING))
  (OR TO (SETQ TO (ARRAY-ACTIVE-LENGTH STRING)))
  (DO I FROM (1+ I) ( I TO)
      (PRESS-CHAR (AREF STRING I))))

;;;; Font Stuff

;;; These should be rewritten to consider font-set ****
;;; Also, want to define font numbers randomly instead of sequentially

;Add a font to the font set and return its font number
(DEFUN PRESS-DEFINE-FONT (FAMILY-NAME FACE-NAME POINT-SIZE ROTATION)
  (OR (PRESS-LOOKUP-FONT FAMILY-NAME FACE-NAME POINT-SIZE ROTATION)
      (LET ((WIDTH (GET-FONT-WIDTH-AND-HEIGHT FAMILY-NAME FACE-NAME POINT-SIZE))
	    HEIGHT WIDTH-ARRAY FONT-DESC FONT-NUMBER)
	(SETQ HEIGHT (CADR WIDTH) WIDTH (CAR WIDTH))	;Bounding box for font
	(SETQ WIDTH-ARRAY (GET-FONT-WIDTH-DATA FAMILY-NAME FACE-NAME POINT-SIZE))
	(SETQ FONT-DESC (LIST FAMILY-NAME FACE-NAME POINT-SIZE ROTATION
			      WIDTH HEIGHT WIDTH-ARRAY))
	(SETQ PRESS-FONT-LIST (NCONC PRESS-FONT-LIST (NCONS FONT-DESC)))
	(SETQ FONT-NUMBER (1- (LENGTH PRESS-FONT-LIST)))
	(AND ( FONT-NUMBER 16.) (FERROR NIL "Maximum of 16 fonts allowed."))
	FONT-NUMBER)))

;Similar to above, but works when there is no Fonts Widths data.  The
;assumed size is completely bogus, don't format lines depending on it.
;Actually, I use the size data from TIMESROMAN18.
;Second value is T if font not found in Fonts Widths.
(DEFUN PRESS-DEFINE-FONT-FAKE (FAMILY-NAME FACE-NAME POINT-SIZE ROTATION)
  (OR (PRESS-LOOKUP-FONT FAMILY-NAME FACE-NAME POINT-SIZE ROTATION)
      (IF (ERRSET (FIND-FONT-DATA FAMILY-NAME FACE-NAME POINT-SIZE) NIL)
	  (PRESS-DEFINE-FONT FAMILY-NAME FACE-NAME POINT-SIZE ROTATION)
	  (LET ((WIDTH 633.) (HEIGHT 698.) WIDTH-ARRAY FONT-DESC FONT-NUMBER)
	    (SETQ WIDTH-ARRAY (MAKE-ARRAY NIL 'ART-16B 400))
	    (FILLARRAY WIDTH-ARRAY '(633.))
	    (SETQ FONT-DESC (LIST FAMILY-NAME FACE-NAME POINT-SIZE ROTATION
				  WIDTH HEIGHT WIDTH-ARRAY))
	    (SETQ PRESS-FONT-LIST (NCONC PRESS-FONT-LIST (NCONS FONT-DESC)))
	    (SETQ FONT-NUMBER (1- (LENGTH PRESS-FONT-LIST)))
	    (AND ( FONT-NUMBER 16.) (FERROR NIL "Maximum of 16 fonts allowed."))
	    (PROG () (RETURN FONT-NUMBER T))))))

;Find position of font in PRESS-FONT-LIST
(DEFUN PRESS-LOOKUP-FONT (FAMILY FACE POINT-SIZE ROTATION)
  (DO ((L PRESS-FONT-LIST (CDR L))
       (I 0 (1+ I)))
      ((NULL L))
    (AND (EQUAL FAMILY (CAAR L))
	 (EQUAL FACE (SECOND (CAR L)))
	 (EQUAL POINT-SIZE (THIRD (CAR L)))
	 (EQUAL ROTATION (FOURTH (CAR L)))
	 (RETURN I))))

;Select a font, by number
(DEFUN PRESS-SELECT-FONT (FONT-NUMBER)
  (PRESS-PUT-PENDING-CHARS)
  (OR (SETQ PRESS-CURRENT-FONT (NTH FONT-NUMBER PRESS-FONT-LIST))
      (FERROR NIL "Font number ~D not defined" FONT-NUMBER))
  (PRESS-ENTITY-BYTE (+ 160 FONT-NUMBER)))

;Single-letters in the string select features as follows:
; B bold, L light
; I italic
; C condensed
; E expanded
(DEFUN ENCODE-PRESS-FACE (STR)
  (SETQ STR (STRING STR))
  (DO ((FACE-CODE 0)
       (I 0 (1+ I))
       (N (STRING-LENGTH STR))
       (CH))
      ((= I N) FACE-CODE)
    (SETQ CH (CHAR-UPCASE (AREF STR I)))
    (SETQ FACE-CODE (+ FACE-CODE
		       (SELECTQ CH
			 (#/B 2)
			 (#/L 4)
			 (#/I 1)
			 (#/C 6)
			 (#/E 12.)
			 (OTHERWISE (FERROR NIL "~C illegal character in face name /"~A/""
					    CH STR)))))))


(DEFUN PRESS-ENTITY-BCPL-STRING (STRING NBYTES &AUX REAL-LENGTH)
  (SETQ STRING (STRING STRING))
  (PRESS-ENTITY-BYTE (SETQ REAL-LENGTH (MIN (STRING-LENGTH STRING) (1- NBYTES))))
  (DOTIMES (I REAL-LENGTH)
    (PRESS-ENTITY-BYTE (AREF STRING I)))
  (DOTIMES (I (- NBYTES (1+ REAL-LENGTH)))
    (PRESS-ENTITY-BYTE 0)))


(DEFVAR PRESS-LINE-USE-SPECIAL-OPCODE NIL)
(DEFVAR NEWVEC-SLOPE-TABLE)
(DEFVAR NEWVEC-DX-TABLE)
(DEFVAR NEWVEC-DY-TABLE)

(DEFUN MAKE-NEWVEC-TABLES ()
  (DO ((TBL (MAKE-ARRAY NIL 'ART-Q 101))
       (XTBL (MAKE-ARRAY NIL 'ART-Q 101))
       (YTBL (MAKE-ARRAY NIL 'ART-Q 101))
       (BITS-TO-MICAS (// 2540.0s0 384.))
       (I 0 (1+ I))
       (DX 0)
       (DY 16.))
      ((= I 101)
       (SETQ NEWVEC-SLOPE-TABLE TBL
	     NEWVEC-DX-TABLE XTBL
	     NEWVEC-DY-TABLE YTBL))
    (ASET (COND ((= I 0) 1s18)
		((= I 100) -1s18)
		(T (// (SMALL-FLOAT DY) DX))) TBL I)
    (ASET (* DX BITS-TO-MICAS) XTBL I)
    (ASET (* DY BITS-TO-MICAS) YTBL I)
    (COND ((< I 20) (SETQ DX (1+ DX)))
	  ((< I 60) (SETQ DY (1- DY)))
	  (T (SETQ DX (1- DX))))))

(MAKE-NEWVEC-TABLES)

;;;;Draw a line, using rectangles for straight lines and font for diagonal lines.
;;;    Coordinates in micas of course.

(DEFUN PRESS-LINE (X0 Y0 X1 Y1 &AUX (DX (ABS (- X0 X1))) (DY (ABS (- Y0 Y1))) FONT-NUMBER)
  (PRESS-PUT-PENDING-CHARS)
  (PRESS-MAYBE-NEW-ENTITY)			;This should make DPLT work better
  (COND (PRESS-LINE-USE-SPECIAL-OPCODE
	 (PRESS-SET-CURSOR X0 Y0)
	 (PRESS-ENTITY-BYTE 201)
	 (PRESS-ENTITY-WORD X1)
	 (PRESS-ENTITY-WORD Y1))	 
	((= X0 X1)				;Vertical line
	 (PRESS-SET-CURSOR (- X0 (// LINE-WIDTH 2)) (MIN Y0 Y1))	;Lower left corner
	 (PRESS-SHOW-RECT LINE-WIDTH DY))
	((= Y0 Y1)				;Horizontal line
	 (PRESS-SET-CURSOR (MIN X0 X1) (- Y0 (// LINE-WIDTH 2)))	;Lower left corner
	 (PRESS-SHOW-RECT DX LINE-WIDTH))
	(T					;Diagonal line, use the font
	 (OR (MEMQ PRESS-LINE-FONT PRESS-FONT-LIST)
	     (SETQ PRESS-FONT-LIST (NCONC PRESS-FONT-LIST (NCONS PRESS-LINE-FONT))))
	 (SETQ FONT-NUMBER (FIND-POSITION-IN-LIST PRESS-LINE-FONT PRESS-FONT-LIST))
	 (AND ( FONT-NUMBER 16.) (FERROR NIL "Maximum of 16 fonts allowed."))
	 (OR (EQ PRESS-CURRENT-FONT PRESS-LINE-FONT)
	     (PRESS-SELECT-FONT FONT-NUMBER))
	 (IF (< X1 X0) (PSETQ X0 X1 Y0 Y1 X1 X0 Y1 Y0))	;(X0,Y0) are left end
	 (PRESS-SET-CURSOR X0 Y0)		;Proceed inevitably toward the right
	 (AND (< Y1 Y0) (SETQ DY (- DY)))
	 ;; Always use 2 characters of the largest size except for finishing up
	 (DO ((CH2 1 (1+ CH2))
	      (CH1 0 CH2)
	      (SLOPE (// (SMALL-FLOAT DY) DX)))
	     ((OR (= CH2 100)
		  (< (AREF NEWVEC-SLOPE-TABLE CH2) SLOPE))
	      (DO ((X X0 (+ X XINC))
		   (Y Y0 (+ Y YINC))
		   (CH) (XINC) (YINC) (STOP NIL)
		   (CDX1 (AREF NEWVEC-DX-TABLE CH1))
		   (CDY1 (AREF NEWVEC-DY-TABLE CH1))
		   (CDX2 (AREF NEWVEC-DX-TABLE CH2))
		   (CDY2 (AREF NEWVEC-DY-TABLE CH2)))
		  ((OR ( X X1) STOP))
		;; If Y would be below the line, use CH1 else use CH2
		(IF (< (// (SMALL-FLOAT (- (+ Y CDY2) Y0)) (- (+ X CDX2) X0)) SLOPE)
		    (SETQ CH CH1 XINC CDX1 YINC CDY1)
		    (SETQ CH CH2 XINC CDX2 YINC CDY2))
		;; If getting too close to the endpoint, use a shorter line
		(DO ((STRTL '(0 120 170 214 226) (CDR STRTL))
		     (I CH)
		     (D 2 (* D 2)))
		    ((OR ( (+ X XINC) X1) (SETQ STOP (NULL (CDR STRTL)))))
		  (SETQ CH (+ (// (- CH (CAR STRTL)) 2) (CADR STRTL))
			I (* (// I 2) 2)
			XINC (// (AREF NEWVEC-DX-TABLE I) D)
			YINC (// (AREF NEWVEC-DY-TABLE I) D)))
		(FUNCALL PRESS-EFTP-STREAM ':TYO CH)
		(SETQ PRESS-N-CHARS (1+ PRESS-N-CHARS))
		(SETQ PRESS-PENDING-CHARS (1+ PRESS-PENDING-CHARS))))))))

;Subroutine for the above
(DEFUN PRESS-SHOW-RECT (WIDTH HEIGHT)
  (PRESS-ENTITY-BYTE 376)
  (PRESS-ENTITY-WORD WIDTH)
  (PRESS-ENTITY-WORD HEIGHT))

;;;; Output a BITMAP off a window

;;; Output bitmap as an entity on the current page
;;;    assumes page is open but not an entity
;;; This uses pixel array because the halfword array requires a bitreverse
;;;      due to the DOVERs inflexibility
;;; U, V define the lower left edge of bitmap on page                [micas]
;;; SX0, SY0, SX1, SY1 define the left, top, right, bottom of screen [pixels]

(DEFUN PRESS-TV-BITMAP (U V &OPTIONAL (WINDOW TV:DEFAULT-SCREEN)
				      (SX0 0) (SY0 0) (SX1 (TV:SHEET-WIDTH WINDOW))
				      (SY1 (TV:SHEET-HEIGHT WINDOW)))
  (IF (> SX0 SX1) (PSETQ SX0 SX1 SX1 SX0))
  (IF (> SY0 SY1) (PSETQ SY0 SY1 SY1 SY0))
  (LET ((ARRAY  (TV:SHEET-SCREEN-ARRAY WINDOW))
	(START  0)
	(LINES  (LOGAND (+ 15. (- SY1 SY0)) 1760))
	(DOTS   (LOGAND (+ 15. (- SX1 SX0)) 1760))
	(SIZE   32.)				; a dot is 32 x 32 micas
	(WIDTH  0)
	(HEIGHT 0))
    (SETQ WIDTH  (* DOTS  SIZE)
	  HEIGHT (* LINES SIZE))
    (PRESS-OPEN-ENTITY)
    (PRESS-PUT-PENDING-CHARS)
    (PRESS-SET-CURSOR U V)
    (IF (ODDP PRESS-N-CHARS)
	(PROGN (PRESS-ENTITY-BYTE <SKIP-CHARACTERS-SHORT>)
	       (PRESS-DATA-BYTE 0)))
    (SETQ START PRESS-N-CHARS)			; remember where we are in DL
    (PROGN (PRESS-DATA-BYTE <<SET-CODING>>)
	   (PRESS-DATA-BYTE 0)
	   (PRESS-DATA-WORD DOTS)
	   (PRESS-DATA-WORD LINES))
    (PROGN (PRESS-DATA-BYTE <<SET-MODE>>)
	   (PRESS-DATA-BYTE 3.))		; Dover Requires this direction
    (PROGN (PRESS-DATA-WORD <<SET-SIZE>>)
	   (PRESS-DATA-WORD WIDTH)
	   (PRESS-DATA-WORD HEIGHT))
    (PROGN (PRESS-DATA-WORD <<DOTS-FOLLOW>>)
	   (DO ((Y      SY0 (1+ Y))
		(LAST-Y (+ LINES SY0)))
	       ((>= Y LAST-Y))
	     (DO ((X      SX0 (+ X 16.))
		  (LAST-X (+ DOTS SX0)))
		 ((>= X LAST-X))
	       (PRESS-DATA-WORD
		 (DO ((I 0 (1+ I))
		      (R 0))
		     ((>= I 16.) R)
		   (SETQ R (+ (LSH R 1) (AREF ARRAY (+ (MIN X SX1) I) (MIN Y SY1)))))))))
    (PROGN (PRESS-ENTITY-BYTE   <SHOW-DOTS>)
	   (PRESS-ENTITY-32WORD (// (- PRESS-N-CHARS START) 2)))
    (PRESS-CLOSE-ENTITY U V WIDTH HEIGHT)
    ))


;;;; Print a file

(DEFUN PRINT-PRESS-FILE (FILE-NAME &REST OPTIONS)
  (WITH-OPEN-FILE (INPUT-STREAM FILE-NAME)
    (WITH-OPEN-STREAM (OUTPUT-STREAM (BIND-PRESS-VARIABLES
				       (MULTIPLE-VALUE-BIND (NIL NIL NIL NIL NIL
							     HOST-ADDRESS)
					   (PRESS-DECODE-OPTIONS OPTIONS)
					 (PRESS-OPEN-EFTP-STREAM HOST-ADDRESS))))
      (STREAM-COPY-UNTIL-EOF INPUT-STREAM OUTPUT-STREAM)
      (CLOSE OUTPUT-STREAM)
      (FUNCALL OUTPUT-STREAM ':SEND-IF-HANDLES ':TRUENAME))))

(DEFUN PRINT-FILE (FILE-NAME &REST OPTIONS)
  (WITH-OPEN-FILE (STREAM FILE-NAME '(:READ))
    (LEXPR-FUNCALL #'PRINT-FROM-STREAM
		   STREAM (FUNCALL STREAM ':TRUENAME) OPTIONS)))

(DEFUN SPOOL-FILE (FILE-NAME &REST OPTIONS)
  (WITH-OPEN-FILE (STREAM FILE-NAME '(:READ))
    (LEXPR-FUNCALL #'PRINT-FROM-STREAM
		   STREAM (FUNCALL STREAM ':TRUENAME) ':SPOOL T OPTIONS)))

(DEFUN PRINT-FROM-STREAM (INPUT-STREAM FILE-NAME &REST OPTIONS
			  &AUX CREATION-DATE FONT-NAME FACE-NAME FONT-SIZE PAGE-HEADINGS
			       N-COPIES HOST-ADDRESS)
  (DECLARE (SPECIAL FILE-NAME CREATION-DATE))
  (BIND-PRESS-VARIABLES
    (MULTIPLE-VALUE (FONT-NAME FACE-NAME FONT-SIZE PAGE-HEADINGS N-COPIES HOST-ADDRESS)
      (PRESS-DECODE-OPTIONS OPTIONS))
    (IF (MEMQ ':CREATION-DATE (FUNCALL INPUT-STREAM ':WHICH-OPERATIONS))
	(SETQ CREATION-DATE (FUNCALL INPUT-STREAM ':CREATION-DATE))
	(SETQ CREATION-DATE (TIME:GET-UNIVERSAL-TIME)))
    (SETQ CREATION-DATE (TIME:PRINT-UNIVERSAL-TIME CREATION-DATE NIL))
    (IF PAGE-HEADINGS
	(SETQ PRESS-END-PAGE-HOOK
	      #'(LAMBDA ()
		  (FORMAT T "~D " PRESS-PAGE-NUMBER)
		  (PRESS-SET-CURSOR 0 DOVER-Y0)
		  (PRESS-STRING (FORMAT NIL "~A~10X~A" FILE-NAME CREATION-DATE))
		  (PRESS-SET-CURSOR 15000. DOVER-Y0)
		  (PRESS-STRING (FORMAT NIL "Page ~D" PRESS-PAGE-NUMBER))))
	(SETQ PRESS-END-PAGE-HOOK
	      #'(LAMBDA () (FORMAT T "~D " PRESS-PAGE-NUMBER))))
    (FORMAT T "~&~A:  " FILE-NAME)
    (UNWIND-PROTECT
      (PROGN (PRESS-START-FILE HOST-ADDRESS)
	     (AND PRESS-INTERPRET-XGP-ESCAPE
		 (PRESS-XGP-HEADER-PAGE INPUT-STREAM))
	     (PRESS-START-PAGE)
	     (PRESS-SELECT-FONT (IF PRESS-INTERPRET-XGP-ESCAPE 0
				    (PRESS-DEFINE-FONT FONT-NAME FACE-NAME FONT-SIZE 0)))
	     (DO ((CH))
		 ((NULL (SETQ CH (FUNCALL INPUT-STREAM ':TYI))))
	       (IF (AND PRESS-INTERPRET-XGP-ESCAPE (= CH 177))
		   (PRESS-XGP-ESCAPE INPUT-STREAM)
		   (PRESS-CHAR CH)))
	     (PRESS-END-PAGE)
	     (PRESS-END-FILE FILE-NAME CREATION-DATE N-COPIES
			     (COND ((AND FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST
					 (NOT (EQUAL FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST
						     "")))
				    (FORMAT NIL "~A (~A)" USER-ID
					    FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST))
				   (T USER-ID))))
      (AND PRESS-EFTP-STREAM
	   (NOT (STRINGP PRESS-EFTP-STREAM))
	   (FUNCALL PRESS-EFTP-STREAM ':CLOSE ':ABORT)))))

(DEFUN PRESS-DECODE-OPTIONS (OPTIONS &AUX (FONT-NAME "LPT")
			     (FACE-NAME "")
			     (FONT-SIZE 8)
			     (PAGE-HEADINGS T)
			     (N-COPIES 1)
			     (HOST-ADDRESS DOVER-ADDRESS))
  ;; Special variables are just set rather than returned
  (DECLARE (RETURN-LIST FONT-NAME FACE-NAME FONT-SIZE PAGE-HEADINGS N-COPIES HOST-ADDRESS))
  (DO ((O OPTIONS (CDDR O)))
      ((NULL O))
    (SELECTQ (CAR O)
      (:FONT-NAME (SETQ FONT-NAME (CADR O)))
      (:FACE-NAME (SETQ FACE-NAME (CADR O)))
      (:FONT-SIZE (SETQ FONT-SIZE (CADR O)))
      (:FONT (MULTIPLE-VALUE (FONT-NAME FACE-NAME FONT-SIZE)
	       (DECODE-FONT-NAME (CADR O))))
      (:PAGE-HEADINGS (SETQ PAGE-HEADINGS (CADR O)))
      (:COPIES (SETQ N-COPIES (CADR O)))
      (:HOST-ADDRESS (SETQ PRESS-USE-EFTP T
			   HOST-ADDRESS (CADR O)))
      (:FILE (SETQ HOST-ADDRESS (CADR O)
		   PRESS-USE-EFTP NIL))
      (:SPOOL (SETQ HOST-ADDRESS (FORMAT NIL "MC: .DOVR.; ~A >" USER-ID)
		    PRESS-USE-EFTP NIL))
      (:EFTP (SETQ HOST-ADDRESS DOVER-ADDRESS
		   PRESS-USE-EFTP T))
      (:XGP (SETQ PRESS-INTERPRET-XGP-ESCAPE T
		  PAGE-HEADINGS NIL))
      (OTHERWISE (FERROR NIL "~S is an unknown keyword" (CAR O)))))
  (VALUES FONT-NAME FACE-NAME FONT-SIZE PAGE-HEADINGS N-COPIES HOST-ADDRESS))

(DEFUN DECODE-FONT-NAME (STRING &AUX IDX1 IDX2 (IBASE 10.))
  (DECLARE (RETURN-LIST FAMILY FACE SIZE))
  (OR (SETQ IDX1 (STRING-REVERSE-SEARCH-SET '(#/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9)
					    STRING))
      (FERROR NIL "No point size in ~A" STRING))
  (SETQ IDX2 (1+ (STRING-REVERSE-SEARCH-NOT-SET '(#/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9)
						STRING IDX1)))
  (VALUES (SUBSTRING STRING 0 IDX2)
	  (SUBSTRING STRING (1+ IDX1))
	  (READ-FROM-STRING (SUBSTRING STRING IDX2 (1+ IDX1)))))

;;; XGP support
(DEFUN PRINT-XGP-FILE (FILE-NAME &REST OPTIONS)
  (WITH-OPEN-FILE (STREAM FILE-NAME '(:READ :RAW :SUPER-IMAGE))
    (LEXPR-FUNCALL #'PRINT-FROM-STREAM
		   (LET-CLOSED ((FILE-STREAM STREAM))
		     #'XGP-FILE-STREAM)
		   (FUNCALL STREAM ':TRUENAME) ':XGP T OPTIONS)))

(DEFVAR XGP-STREAM-RAW-P NIL)

;;; This extra level of stream is necessary, since sometimes we want character set conversion,
;;; as when reading text, and other times not, as when reading arguments.
(DEFUN XGP-FILE-STREAM (OP &REST ARGS)
  (DECLARE (SPECIAL FILE-STREAM))
  (SELECTQ OP
    (:WHICH-OPERATIONS '(:TYI :TRUENAME :CREATION-DATE))
    (:TYI
     (IF XGP-STREAM-RAW-P (FUNCALL FILE-STREAM ':TYI)
	 (DO ((CH)) (NIL)
	   (SETQ CH (FUNCALL FILE-STREAM ':TYI))
	   (SELECTQ CH
	     (11 (RETURN #\TAB))
	     (12 )
	     (14 (RETURN #\FF))
	     (15 (RETURN #\CR))
	     (OTHERWISE (RETURN CH))))))
    (:LINE-IN (STREAM-DEFAULT-HANDLER #'XGP-FILE-STREAM OP (CAR ARGS) (CDR ARGS)))
    (OTHERWISE (LEXPR-FUNCALL FILE-STREAM OP ARGS))))

(DEFCONST XGP-DOTS-PER-INCH 200.)

(DEFMACRO XGP-TO-MICAS (X)
  `(// (* ,X 2540.) XGP-DOTS-PER-INCH))

(DEFUN PRESS-XGP-HEADER-PAGE (INPUT-STREAM &AUX LEFT-MARGIN TOP-MARGIN BOTTOM-MARGIN)
  (SETQ LEFT-MARGIN 2540.			;Closer to the xgp's values
	TOP-MARGIN (// (* 2540. 2) 3)
	BOTTOM-MARGIN TOP-MARGIN)		       
  (DO ((CH)) (NIL)
    (SELECTQ (SETQ CH (FUNCALL INPUT-STREAM ':TYI))
      (#\FORM (RETURN NIL))
      (#\CR)
      (#/;
       (LET* ((LINE (FUNCALL INPUT-STREAM ':LINE-IN))
	      (IDX (STRING-SEARCH-CHAR #\SP LINE))
	      (IBASE 10.))
	 (SELECTOR (SUBSTRING LINE 0 (PROG1 IDX (AND IDX (INCF IDX)))) STRING-EQUAL
;	   ("autcut")
	   ("botmar"
	    (SETQ BOTTOM-MARGIN (XGP-TO-MICAS (READ-FROM-STRING LINE NIL IDX))))
;	   ("delete")
	   ("dfont"
	    (SETQ PRESS-XGP-FONT-LIST
		  (LOOP FOR I = IDX THEN (1+ J)
			FOR J = (STRING-SEARCH-CHAR #/, LINE I)
			COLLECT (MULTIPLE-VALUE-BIND (FAMILY FACE SIZE)
				    (DECODE-FONT-NAME (SUBSTRING LINE I J))
				  (PRESS-DEFINE-FONT FAMILY FACE SIZE 0))
			WHILE J)))
	   ("ffcut")
	   ("lftmar"
	    (SETQ LEFT-MARGIN (XGP-TO-MICAS (READ-FROM-STRING LINE NIL IDX))))
;	   ("list")
	   ("lsp"
	    (SETQ PRESS-INTERLINE-SPACING (XGP-TO-MICAS (READ-FROM-STRING LINE NIL IDX))))
	   ("rgtmar")
	   ("skip")
	   ("squish")
	   ("topmar"
	    (SETQ TOP-MARGIN (XGP-TO-MICAS (READ-FROM-STRING LINE NIL IDX))))
	   ("vsp")
	   (OTHERWISE (FERROR NIL "Unknown line ~A in XGP preamble" LINE)))))
      (OTHERWISE
       (FERROR NIL "Unknown character in XGP preamble ~C" CH))))
  (SETQ DOVER-X0 LEFT-MARGIN
	DOVER-Y1 (- (* 11. 2540.) TOP-MARGIN BOTTOM-MARGIN PRESS-INTERLINE-SPACING)
	DOVER-Y2 BOTTOM-MARGIN))

(DEFUN PRESS-XGP-ESCAPE (INPUT-STREAM &AUX (XGP-STREAM-RAW-P T) CH)
  (SELECTQ (SETQ CH (FUNCALL INPUT-STREAM ':TYI))
    (1 (PRESS-XGP-ESCAPE-1 INPUT-STREAM))
    (2 (PRESS-XGP-ESCAPE-2 INPUT-STREAM))
    (3 (PRESS-XGP-ESCAPE-3 INPUT-STREAM))
    (4 (PRESS-XGP-ESCAPE-4 INPUT-STREAM))
    (OTHERWISE (PRESS-CHAR CH))))

(DEFUN PRESS-XGP-ESCAPE-1 (INPUT-STREAM &AUX CH)
  (SETQ CH (FUNCALL INPUT-STREAM ':TYI))
  (IF (< CH 20)
      (PRESS-SELECT-FONT (NTH CH PRESS-XGP-FONT-LIST))
      (SELECTQ CH
	(40 (PRESS-XGP-SET-COLUMN INPUT-STREAM))
	(41 (PRESS-XGP-UNDERSCORE INPUT-STREAM))
	(42 (PRESS-XGP-LINE-SPACE INPUT-STREAM))
	(43 (PRESS-XGP-BASELINE-ADJUST INPUT-STREAM))
	(44 (PRESS-XGP-PRINT-PAGE-NUMBER INPUT-STREAM))
	(45 (PRESS-XGP-SPECIFY-HEADING INPUT-STREAM))
	(46 (PRESS-XGP-START-UNDERSCORE INPUT-STREAM))
	(47 (PRESS-XGP-END-UNDERSCORE INPUT-STREAM))
	(50 (PRESS-XGP-SET-INTERCHAR-SPACING INPUT-STREAM))
	(51 (PRESS-XGP-END-SPECIFIED-WIDTH-UNDERSCORE INPUT-STREAM))
	(52 (PRESS-XGP-RELATIVE-BASELINE-ADJUST INPUT-STREAM))
	(53 (PRESS-XGP-RELATIVE-UNDERSCORE INPUT-STREAM))
	(OTHERWISE (FERROR NIL "Unknown XGP escape ~O" CH)))))

;;; Sign extended version of above
(DEFUN PRESS-XGP-ONE-BYTE-ARG (INPUT-STREAM)
  (LET ((CH (FUNCALL INPUT-STREAM ':TYI)))
    (IF (BIT-TEST 100 CH) (- 200 CH) CH)))

(DEFUN PRESS-XGP-TWO-BYTE-ARG (INPUT-STREAM)
  (DPB (FUNCALL INPUT-STREAM ':TYI) 0707 (FUNCALL INPUT-STREAM ':TYI)))

(DEFUN PRESS-XGP-THREE-BYTE-ARG (INPUT-STREAM)
  (DPB (FUNCALL INPUT-STREAM ':TYI) 1607
       (DPB (FUNCALL INPUT-STREAM ':TYI) 0707 (FUNCALL INPUT-STREAM ':TYI))))

(DEFUN PRESS-XGP-SET-COLUMN (INPUT-STREAM)
  (PRESS-SET-CURSOR (XGP-TO-MICAS (PRESS-XGP-TWO-BYTE-ARG INPUT-STREAM)) PRESS-Y))

(DEFUN PRESS-XGP-UNDERSCORE (INPUT-STREAM)
  (PRESS-XGP-DO-UNDERSCORE (- PRESS-Y (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM)))
			   PRESS-X (PRESS-XGP-TWO-BYTE-ARG INPUT-STREAM) 2.))

(DEFUN PRESS-XGP-LINE-SPACE (INPUT-STREAM)
  (SETQ PRESS-INTERCHAR-SPACING NIL)
  (PRESS-SET-CURSOR PRESS-X (- PRESS-Y (XGP-TO-MICAS (FUNCALL INPUT-STREAM ':TYI)))))

(DEFUN PRESS-XGP-BASELINE-ADJUST (INPUT-STREAM)
  (SETQ PRESS-INTERCHAR-SPACING NIL)
  (PRESS-SET-CURSOR
    (SETQ PRESS-BASELINE-Y (+ PRESS-Y (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM))))
    PRESS-X))

(DEFUN PRESS-XGP-PRINT-PAGE-NUMBER (IGNORE)
  (PRESS-STRING (FORMAT NIL "~D" PRESS-PAGE-NUMBER)))

(DEFUN PRESS-XGP-SPECIFY-HEADING (INPUT-STREAM)
  (LET* ((LENGTH (FUNCALL INPUT-STREAM ':TYI))
	 (STRING (MAKE-ARRAY LENGTH ':TYPE 'ART-STRING)))
    (LOOP FOR I FROM 0 BELOW LENGTH
	  DO (ASET (FUNCALL INPUT-STREAM ':TYI) STRING I))
    (SETQ PRESS-END-PAGE-HOOK (LET-CLOSED ((STRING STRING))
				#'(LAMBDA ()
				    (FORMAT T "~D " PRESS-PAGE-NUMBER)
				    (WITH-INPUT-FROM-STRING (INPUT-STREAM STRING)
				      (DO ((CH))
					  ((NULL (SETQ CH (FUNCALL INPUT-STREAM ':TYI))))
					(IF (AND PRESS-INTERPRET-XGP-ESCAPE (= CH 177))
					    (PRESS-XGP-ESCAPE INPUT-STREAM)
					    (PRESS-CHAR CH)))))))))

(DEFUN PRESS-XGP-START-UNDERSCORE (IGNORE)
  (SETQ PRESS-XGP-UNDERLINE-START-X PRESS-X))

(DEFUN PRESS-XGP-END-UNDERSCORE (INPUT-STREAM)
  (PRESS-XGP-DO-UNDERSCORE (- PRESS-BASELINE-Y
			      (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM)))
			   PRESS-XGP-UNDERLINE-START-X
			   PRESS-X 2.))

(DEFUN PRESS-XGP-SET-INTERCHAR-SPACING (INPUT-STREAM)
  (SETQ PRESS-INTERCHAR-SPACING (XGP-TO-MICAS (FUNCALL INPUT-STREAM ':TYI))))

(DEFUN PRESS-XGP-END-SPECIFIED-WIDTH-UNDERSCORE (INPUT-STREAM)
  (LET ((WIDTH (FUNCALL INPUT-STREAM ':TYI)))
    (PRESS-XGP-DO-UNDERSCORE (- PRESS-BASELINE-Y
				(XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM)))
			     PRESS-XGP-UNDERLINE-START-X
			     PRESS-X WIDTH)))

(DEFUN PRESS-XGP-RELATIVE-BASELINE-ADJUST (INPUT-STREAM)
  (PRESS-SET-CURSOR
    (SETQ PRESS-BASELINE-Y (+ PRESS-BASELINE-Y
			      (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM))))
    PRESS-X))

(DEFUN PRESS-XGP-RELATIVE-UNDERSCORE (INPUT-STREAM)
  (PRESS-XGP-DO-UNDERSCORE (- PRESS-BASELINE-Y
			      (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM)))
			   PRESS-X (PRESS-XGP-TWO-BYTE-ARG INPUT-STREAM) 2.))

(DEFUN PRESS-XGP-DO-UNDERSCORE (TOP-Y X-START X-END THICKNESS &AUX (OX PRESS-X) (OY PRESS-Y))
  (PRESS-SET-CURSOR X-START (- TOP-Y THICKNESS))
  (PRESS-ENTITY-BYTE 376)	;Show-rectangle
  (PRESS-ENTITY-WORD (- X-END X-START))		;Width
  (PRESS-ENTITY-WORD (XGP-TO-MICAS THICKNESS))	;Thickness
  (PRESS-SET-CURSOR OX OY))

(DEFUN PRESS-XGP-ESCAPE-2 (INPUT-STREAM)
  (PRESS-SET-CURSOR (+ PRESS-X (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM)))
		    PRESS-Y))

(DEFUN PRESS-XGP-ESCAPE-3 (IGNORE)
  (FERROR NIL "XGP escape 3 not implemented"))

(DEFUN PRESS-XGP-ESCAPE-4 (IGNORE)
  (FERROR NIL "XGP escape 4 not implemented"))

;;;;Font sampling

;Each element in font-list is (family-name face-name point-size rotation)
; rotation is optional and defaults to 0
(DEFUN SAMPLE-FONTS (FONT-LIST &OPTIONAL (UPPER-HALF NIL)
					 (HOST-ADDRESS DOVER-ADDRESS)
			       &AUX FOO CH)
 (BIND-PRESS-VARIABLES
  (PRESS-START-FILE HOST-ADDRESS)
  (LET ((LABEL-FONT (PRESS-DEFINE-FONT "TIMESROMAN" "" 10. 0)) THIS-FONT NOT-IN-FONTS-WIDTHS)
    (DO ((L FONT-LIST (CDR L))
	 (FONT) (ROTATION)
	 (I 1 (1+ I)))
	((NULL L)
	 (PRESS-END-FILE "Font samples" ""))
      (SETQ FONT (CAR L))
      (COND ((= I 16.)				;Got to make a new file
	     (PRESS-END-FILE "Font samples" "")
	     (RETURN (SAMPLE-FONTS L UPPER-HALF))))
      (PRESS-START-PAGE)
      (MULTIPLE-VALUE (THIS-FONT NOT-IN-FONTS-WIDTHS)
	  (PRESS-DEFINE-FONT-FAKE (CAR FONT) (CADR FONT) (CADDR FONT)
				  (SETQ ROTATION (OR (CADDDR FONT) 0))))
      (PRESS-SET-CURSOR 6500. 25400.)
      (PRESS-SELECT-FONT LABEL-FONT)
      (PRESS-STRING
	(FORMAT NIL "Font ~A, ~:[Face ~A, ~;~*~]Point size ~D~:[, rotated ~D degrees~;~*~]~:[~; (not in Fonts.Widths)~]"
		    (CAR FONT) (STRING-EQUAL (CADR FONT) "") (CADR FONT)
		    (CADDR FONT) (ZEROP ROTATION) (// ROTATION 60.)
		    NOT-IN-FONTS-WIDTHS))
      (DOTIMES (COL 10)
	(DOTIMES (ROW 20)
	  (PRESS-SET-CURSOR (+ (* COL 2200.) 300.) (- (* 10. 2540.) 1250. (* ROW 1000.)))
	  (PRESS-SELECT-FONT LABEL-FONT)
	  (SETQ CH (+ (IF UPPER-HALF 200 0) (* COL 20) ROW))
	  (DO PPSS 0603 (- PPSS 0300) (MINUSP PPSS)
	      (PRESS-CHAR (+ (LDB PPSS CH) #/0)))
	  (PRESS-STRING "   ")
	  (PRESS-SELECT-FONT THIS-FONT)
	  ;; See if char defined in font
	  (COND ((MINUSP (AREF (SEVENTH PRESS-CURRENT-FONT) CH))
		 (PRESS-SELECT-FONT LABEL-FONT)
		 (PRESS-STRING "und"))
		(T (FUNCALL PRESS-EFTP-STREAM ':TYO CH)
		   (SETQ PRESS-N-CHARS (1+ PRESS-N-CHARS))
		   (SETQ PRESS-PENDING-CHARS (1+ PRESS-PENDING-CHARS))))))
      ;8150. next
      (PRESS-SELECT-FONT THIS-FONT)
      (PRESS-SET-CURSOR 0 8000.)
      (PRESS-CHAR-SEQ #/A #/Z #\CR)
      (PRESS-CHAR-SEQ #/a #/z #\CR)
      (PRESS-CHAR-SEQ #/0 #/9 #\CR)
      (PRESS-CHAR-SEQ #/! #/?)
      (PRESS-CHAR-SEQ #/[ #/_)
      (PRESS-CHAR-SEQ #/{ #/ #\CR)
      (PRESS-CHAR-SEQ #/ #/)
      (PRESS-SET-CURSOR 0 4150.)
      (PRESS-STRING "/"The time has come,/" the Walrus said,
   /"To talk of many things;
Of shoes, and ships, and sealing wax,
")
      (SETQ FOO PRESS-Y)
      (PRESS-STRING "   Of cabbages and kings,
And why the sea is boiling hot,
   And whether pigs have wings./"")
      (PRESS-SET-CURSOR 8750. FOO)
      (PRESS-STRING "(DEFUN APPEND (X Y)
")
      (PRESS-SET-CURSOR 8750. PRESS-Y)
      (PRESS-STRING "       (COND ((NULL X) Y)
")
      (PRESS-SET-CURSOR 8750. PRESS-Y)
      (PRESS-STRING "             (T (CONS (CAR X) (APPEND (CDR X) Y)))))")
      (PRESS-END-PAGE)))))

(DEFUN PRESS-CHAR-SEQ (FIRST LAST &OPTIONAL EXTRA)
  (DO CH FIRST (1+ CH) (> CH LAST)
    (OR (MINUSP (AREF (SEVENTH PRESS-CURRENT-FONT) CH)) (PRESS-CHAR CH)))
  (AND EXTRA (PRESS-CHAR EXTRA)))

;This one is driven off of the widths file, assumed to be already loaded
(DEFUN SAMPLE-ALL-FONTS (&AUX FONT-LIST NAME FACE POINTS ROT)
  (DOLIST (F FONT-WIDTH-DATA)
    (SETQ NAME (CAR F) FACE (CADR F) POINTS (CADDR F) ROT (CADDDR F))
    (COND ((PLUSP POINTS) (PUSH (LIST NAME FACE (// (* 10. POINTS) 352.) ROT) FONT-LIST))
	  (T (FORMAT T "~&Type list of point sizes for ~A~Arot~D: "
		     NAME FACE (// ROT 60.))
	     (DOLIST (POINTS (READ))
	       (PUSH (LIST NAME FACE POINTS ROT) FONT-LIST)))))
  (SAMPLE-FONTS FONT-LIST))

;;;; List of all fonts on MIT Dover as 12/21/79 [also there are rotated fonts]

(SETQ ALL-DOVER-FONTS '(
  (TIMESROMAN || 6.) (TIMESROMAN || 7.) (TIMESROMAN || 8.)
  (TIMESROMAN || 10.) (TIMESROMAN || 12.) (TIMESROMAN || 18.)

  (TIMESROMAN B 6.) (TIMESROMAN B 7.) (TIMESROMAN B 8.)
  (TIMESROMAN B 10.) (TIMESROMAN B 12.) (TIMESROMAN B 18.)

  (TIMESROMAN I 6.) (TIMESROMAN I 7.) (TIMESROMAN I 8.)
  (TIMESROMAN I 10.) (TIMESROMAN I 12.)

  (TIMESROMAN BI 6.) (TIMESROMAN BI 7.) (TIMESROMAN BI 8.)
  (TIMESROMAN BI 10.) (TIMESROMAN BI 12.)

  (HELVETICA || 6.) (HELVETICA || 7.) (HELVETICA || 8.)
  (HELVETICA || 10.)  (HELVETICA || 12.) (HELVETICA || 18.)

  (HELVETICA B 6.) (HELVETICA B 7.) (HELVETICA B 8.)
  (HELVETICA B 10.) (HELVETICA B 12.) (HELVETICA B 18.)

  (HELVETICA BI 6.) (HELVETICA BI 7.) (HELVETICA BI 8.)
  (HELVETICA BI 10.) (HELVETICA BI 12.)

  (HELVETICA I 6.) (HELVETICA I 7.) (HELVETICA I 8.)
  (HELVETICA I 10.) (HELVETICA I 12.)

  (MATH || 6) (MATH || 8.) (MATH || 10.)

  (CREAM || 10.)
  (CREAM I 10.)
  (CREAM B 10.)

  (GACHA || 8.)
  (GACHA || 10.)

  (HIPPO || 8.)
  (HIPPO || 10.)

  (ELITE || 10.)

  (ARROWS || 10.)

  (DOTS || 7.)

  (GATES || 32.)

  (TEMPLATE || 64.) ))

;; Read in all fonts from FONTS;DOVER FONTS
(DEFUN COMPUTE-DOVER-FONTS (&AUX NAME FACE POINT ROT TEM ANSWER (IBASE 10.))
  (WITH-OPEN-FILE (I "AI: FONTS; DOVER FONTS")
    (DO ((LINE) (EOF)) (NIL)
      (MULTIPLE-VALUE (LINE EOF)
	(FUNCALL I ':LINE-IN))
      (AND EOF
	   (OR (NULL LINE) (EQUAL LINE ""))
	   (RETURN (NREVERSE ANSWER)))
      (SETQ TEM (STRING-SEARCH-CHAR #/, LINE)
	    NAME (INTERN (SUBSTRING LINE 7 TEM) "PRESS")
	    TEM (+ TEM 2)
	    FACE (COND ((STRING-EQUAL LINE "MR" TEM 0 (+ TEM 2) 2) '||)
		       ((STRING-EQUAL LINE "MI" TEM 0 (+ TEM 2) 2) 'I)
		       ((STRING-EQUAL LINE "BR" TEM 0 (+ TEM 2) 2) 'B)
		       ((STRING-EQUAL LINE "BI" TEM 0 (+ TEM 2) 2) 'BI)
		       (T (FERROR NIL "Parsing error in fonts file.")))
	    TEM (1+ (STRING-SEARCH-CHAR #/( LINE TEM))
	    POINT (READ-FROM-STRING LINE 'SI:NO-EOF-OPTION TEM)
	    TEM (+ (STRING-SEARCH-CHAR #/: LINE TEM) 2)
	    ROT (READ-FROM-STRING LINE 'SI:NO-EOF-OPTION TEM))
      (PUSH (LIST NAME FACE POINT ROT) ANSWER))))


(COMMENT ;hacks

(DEFUN SPIRAL-HACK ()
  (PRESS-START-FILE DOVER-ADDRESS)
  (PRESS-START-PAGE)
  (PRESS-SELECT-FONT (PRESS-DEFINE-FONT "timesroman" "" 10. 0))
  (DO ((X 8000.) (Y 8000.) (ANG 0 (+ ANG ANGINC)) (ANGINC 0.3)
       (LEN 200. (+ LEN LENINC)) (LENINC 50.) (MAXLEN 1000.))
      ((> LEN MAXLEN))
    (PRESS-LINE X Y (SETQ X (+ X (FIX (* (SIN ANG) LEN))))
		    (SETQ Y (+ Y (FIX (* (COS ANG) LEN))))))
  (PRESS-END-PAGE)
  (PRESS-END-FILE "Spiral" ""))

(DEFUN FOO (POLY ADDRESS)
  (PRESS-START-FILE ADDRESS)
  (PRESS-START-PAGE)
  (PRESS-SELECT-FONT (PRESS-DEFINE-FONT "timesroman" "" 10. 0))
  (DO ((X (CAAR POLY))
       (Y (CADAR POLY))
       (L (CDR POLY) (CDR L)))
      ((NULL L))
    (PRESS-LINE X Y (SETQ X (CAAR L)) (SETQ Y (CADAR L))))
  (PRESS-END-PAGE)
  (PRESS-END-FILE "Lines" ""))
);comment

;;; ZWEI interface
;;; should have a way of setting this stuff
(DEFVAR DIRED-PRINT-OPTIONS NIL)

(DEFUN (:DOVER :DIRED-PRINT-FUNCTION) (PATHNAME TYPE)
  (SELECTQ TYPE
    (:SUDS-PLOT
     (AND (NOT (FBOUNDP ':DPLT-PRINT-FILE))
	  (LOAD "SYS: IO1; DPLT PKG >")
	  (PKG-LOAD 'DPLT '(:NOCONFIRM)))
     (:DPLT-PRINT-FILE PATHNAME)
     T)
    (:XGP
     (LEXPR-FUNCALL #'PRINT-XGP-FILE PATHNAME DIRED-PRINT-OPTIONS))
    (:TEXT (LEXPR-FUNCALL #'PRINT-FILE PATHNAME DIRED-PRINT-OPTIONS))
    (:PRESS (LEXPR-FUNCALL #'PRINT-PRESS-FILE PATHNAME DIRED-PRINT-OPTIONS))
    (OTHERWISE (FORMAT NIL "I don't know how to print files of type ~A" TYPE))))