;*; Updated on 08-Nov-91 at 8:03 AM by Michele Tonti; edit time: 0:00:25
;*************************** AMUS Program Label ******************************
; Filename: PSUPC.PDV                                       Date: 11/07/91
; Category: UTIL         Hash Code: 100-222-575-603      Version: 2.1(150)-3
; Initials: ULTR/US      Name: DAVID PALLMANN
; Company: ULTRASOFT CORPORATION                   Telephone #: 5163484848
; Related Files: 
; Min. Op. Sys.: AMOSL 1.3B/AMOS32 1.0         Expertise Level: INT
; Special: Select font U for Universal Price Code.  For PostScript printers.
; Description: LASWRT.PDV modified to print UPC (bar codes).
;*****************************************************************************
;****************************************************************************
;*									    *
;*				    PSUPC				    *
;*    PostScript Printer Driver with Universal Price Code (UPC) support	    *
;*									    *
;****************************************************************************
;Select font U to select UPC font.
;
;[CUS]	Customized from released software to support UPC as font U. /DFP
;
;								ASL-     -
;                                 NOTICE
;
;All  rights  reserved.  This software is the property of Alpha Microsystems
;and the material contained herein is the  proprietary  property  and  trade
;secrets  of  Alpha Microsystems, embodying substantial creative efforts and
;confidential information, ideas and expressions, no part of  which  may  be
;reproduced  or  transmitted  in  any  form  or  by  any  means, electronic,
;mechanical,  or  otherwise,  including  photocopying  or  input  into   any
;information  storage  or  retrieval  system  without  the  express  written
;permission of Alpha Microsystems.
;
;CAUTION: Unauthorized distribution or reproduction  of  this  material  may
;subject you to legal action.
;
;Copyright (C) 1982, 1988 - Alpha Microsystems
;
;This driver is AlphaWRITE 2.1 compatible and supports the ISO Latin I
;character set.
;
;Version 2.0 or later of M68 is required to assembler this driver.  The
;code will deliberately generate an error if you are using an earlier
;version of the assembler.
;
;This driver contains some assembly options.  Search for '<-' to find them.
;The features that can be customized are (default values are 0):
;
;	bullet type   BULLET = 0  graphically drawn circles
;		      BULLET = 1  bullet as defined in typeface
;		      BULLET = 2  graphically drawn squares
;
;	landscape     LANDOR = 0  rotate 90 degrees to the right
;		      LANDOR = 1  rotate 90 degrees to the left
;
;	spec. chars.  SPECHR = 0  selected from Symbol typeface
;		      SPECHR = 1  selected from current typeface
;
;The font table at the end of this driver defines the 35 fonts that are
;standard with the Apple LaserWriter Plus and most PostScript printers.
;It is easily modified to accommodate other fonts.  To achieve proper
;line fill and justification, accompanying Font Width Table (.FWT) files
;must be created.
;
;This driver's Edit History is contained in the AlphaWRITE source.
;
;Assembly options:
;
;    .M68 LASWRT ....... generates LASWRT.PDV (certified PostScript printers)
;    .M68 LASWRT/V:1 ... generates PSCART.PDV (HP PostScript cartridge)

	LASWRT	=0
	PSCART	=1

	NVALU	PRTTYP

	OBJNAM	PSUPC.PDV
	ASMMSG	"== PSUPC.PDV PostScript UPC (bar code) printer driver =="

	SEARCH	SYS
	SEARCH	SYSSYM
	COPY	PDVSYM

	VMAJOR	=2
	VMINOR	=1
	VSUB	=0
 	VEDIT	=150.
	VWHO	=1			; [164] Patch #1, SPR 30042 (AMIGOS import)
	VWHO	=2			; [155] Patch #2, SPR 30092 (PS cart. timeout)
	VWHO	=3			; [165] Patch #3, SPR 30036 (PS cart. envelope adaptor)

;paper size definitions - see next screen for tray assignments

	NONE	=0			; don't set paper size
	LETTER	=1			; letter size paper
	LEGAL	=2			; legal size paper
	COM10	=3			; commerical 10 size envelope
	MONARCH	=4			; monarch size envelope
	A4	=5			; A4 size paper
	C5ENV	=6			; C5 size envelope
	D1ENV	=7			; D1 size envelope

;**********************
;*  Assembly Options  *
;**********************
;Alpha Micro defaults are zero
					; ---- Bullet Options ----
	BULLET	=0			; 0: graphically drawn circles
					; 1: bullet character from currently
					;    selected typeface
					; 2: graphically drawn squares

					; ---- Landscape Orientation ----
	LANDOR	=0			; 0: 90 degrees right rotation
					; 1: 90 degrees left rotation

	SPECHR	=0			; ---- Special Character Option ----
					; 0: special characters TM, (c), (r)
					;    selected from Symbol typeface
					; 1: special characters TM, (c), (r)
					;    selected from current typeface

;*************************
;*  PAPER TRAY SETTINGS  *
;*************************
;paper tray settings for general PostScript driver (LASWRT.PDV) only

	IF	EQ,PRTTYP-LASWRT

	BIN1	=NONE			; bin 1 - use default size
	BIN2	=NONE			; bin 2 - use default size
	BIN3	=NONE			; bin 3 - use default size
	BIN4	=NONE			; bin 4 - use default size

;paper tray settings for PostScript cartridge driver (PSCART.PDV) only

	IFF

	BIN1	=LETTER			; paper size of bin 1 (upper tray)
	BIN2	=LETTER			; paper size of bin 2 (lower tray)
	BIN3	=COM10			; paper size of bin 3 (envelope tray)
	BIN4	=LETTER			; paper size of bin 4 (manual feed)

	ENDC

;**********************
;*  ASCII Characters  *
;**********************

	$LF	=12			; line feed
	$FF	=14			; form feed
	$CR	=15			; carriage return

;***************************************
;*  AlphaWRITE 2.1 special characters  *
;***************************************

	C$NXB	=^H012			; non-exandable space
	C$DEG	=^H015			; degree symbol
	C$PAR	=^H016			; paragraph symbol
	C$DAG	=^H017			; dagger
	C$SEC	=^H018			; section symbol
	C$CNT	=^H019			; cent sign
	C$QTR	=^H01A			; 1/4
	C$HAF	=^H01B			; 1/2
	C$TM 	=^H01C			; trademark symbol
	C$CPY	=^H01D			; copyright symbol
	C$REG	=^H01E			; registered symbol
	C$STR	=^H088			; star
	C$BLT	=^H089			; bullet
	C$EMD	=^H08A			; em dash
	C$END	=^H08B			; en dash
	C$RTN	=^H08D			; RETURN keycap

;**********************************************************
;*  Make sure we have a compatible version of PDVSYM.M68  *
;**********************************************************

	IF NDF,PDVEXT,ASMERP "?Your PDVSYM.M68 file pre-dates AlphaWRITE 2.0"
	IF NDF,PD$W21,ASMERP "?Your PDVSYM.M68 file pre-dates AlphaWRITE 2.1"

;********************************************
;*  Refuse to assemble under 1.X assembler  *
;********************************************

	SYMBOL1	=1
	SYMBOL2	=2
	IF EQ,SYMBOL1-SYMBOL2,ASMERP "?The 2.X assembler is required"

;******************
;*  $SPLFL FLAGS  *
;******************

	PF$CPY=1			; number of copies specified
	PF$DEL=2			; delete file after printing
	PF$BAN=4			; print leading banner page
	PF$HDR=10			; print header at top of each page
	PF$FF=20			; print form feeds
	PF$INF=100000			; inform user when printing done

;********************************
;*  Printer Driver Impure Area  *
;********************************
;Impure area used by printer driver, indexed by A3

	.OFINI	RESVUS
	.OFDEF	TYPSIZ,	4		; current font size
	.OFDEF	CHROUT,	2		; chars output thus far on current line
	.OFDEF	CURFNT,	2		; current font name
	.OFDEF	ENVCNT,	2		; envelope count		[165]
	.OFDEF	WIDSAV,	4		; temporary
	.OFDEF	FLAGS,	4		; flags
		PF$BLD	=1		;  bold selected
		PF$UND	=2		;  underscore selected
		PF$ITA	=4		;  italic selected
		PF$SCR	=10		;  screened selected
		PF$REV	=20		;  reverse selected
		PF$DBL	=40		;  double underscore selected
		PF$BAR	=100		;  overbar selected
		PF$GRY	=200		;  in gray text
		PF$CHR	=400		;  we have started a char sequence
		PF$PRO	=1000		;  proportional spacing enabled
		PF$FNT	=2000		;  font must be selected
		PF$SUS	=4000		;  .sus has been issued
		PF$LND	=10000		;  landscape
		PF$KEY	=20000		;  in keycap
		PF$DEF	=40000		;  attributes have been deferred
		PF$SL	=100000		;  last PS output was <sl>
		PF$CH8	=200000		;  8-bit characters have been encountered
		PF$NAT	=400000		;  we are using natural character set
		PF$ENV	=1000000	;  using HP envelope adaptor (bin 3) [165]
		PF$ENP	=2000000	;  envelope needs positioning	[165]
	.OFDEF	CHRWID,	2		; width of a character in points
	.OFDEF	BUFFER,	20.		; conversion buffer
	.OFDEF	LEADING,2		; leading
	.OFDEF	GRYVAL,	2		; gray shading value
	.OFDEF	IMGSIZ,	4		; size of image (points)
	.OFDEF	FLTBUF,	6		; floating point work buffer
	.OFDEF	KERNING,2		; kerning setting
	.OFDEF	LSTCHR,	1		; 
	.OFDEF	PAGNUM,	1		; 
	.OFDEF	ENCFLG,	36.		; table of font encoding flags	[CUS]
	.OFDEF	XXXXXX,	1		; unused (even up address)	[CUS]
	.OFDEF	ENCNUM,	1		; current encoding number
	.OFDEF	NUMBUF,	19.		; numeric conversion buffer
	.OFDEF	DECCHR,	1		; decimal point char in curr. language
	.OFDEF	MOVHRZ,	4		; last position moved to (horz)
	.OFDEF	MOVVRT,	4		; last position moved to (vert)
	.OFSIZ	PDVMEM
	IF	LT,PDVEXT-PDVMEM,ASMERP "?PDV impure size is too large"

;************
;*  Macros  *
;************

;Generate a line of ASCII text

DEFINE	ASCIL	TEXT
	ASCII	|TEXT|
	BYTE	15,12
	ENDM

DEFINE	ASCIL2	TEXT
	ASCII	~TEXT~
	BYTE	15,12
	ENDM

;Test a bit in a longword of flags
;
;   General usage:
;
;	BIT #PF$xxx,FLAGS(A3)
;
;   For economical usage, specify optional third argument which provides a
;   hint to the macro about which word (1=high order, 2=low order) of the
;   longword contains the flag in question.  With hints, word instructions
;   are generated instead of longword instructions.
;
;	BIT #PF$xxx,FLAGS(A3),1
;	BIT #PF$xxx,FLAGS(A3),2

DEFINE	BIT	SRC,DST,HINT

	IF	NB,HINT,$HINT=HINT
	IF	B,HINT,$HINT=0

	IF	EQ,$HINT-0
	MOV	DST,D7
	AND	SRC,D7
	ENDC

	IF	EQ,$HINT-1
	MOVW	2+DST,D7
	ANDW	SRC&177777,D7
	ENDC

	IF	EQ,$HINT-2
	MOVW	DST,D7
	ANDW	SRC_-16.,D7
	ENDC

	ENDM

;Output a null-terminated string

DEFINE	OUTSTR	ADDR
	LEA	A6,ADDR
	CALL	STROUT
	ENDM

;Generate a string of fixed length in a table

DEFINE	STR	TEXT,SIZE
1$$:	ASCIZ	/TEXT/
	BLKB	SIZE-<.-1$$>
	ENDM

DEFINE	ENDATT	FLAG,ADDR,FLAG2
	BIT	#FLAG,FLAGS(A3)
	BEQ	1$$
	OUTSTR	ADDR
	IF	NB,FLAG2,AND #^C<FLAG2>,FLAGS(A3)
1$$:
	ENDM

;Output byte in D1 to output file PTDDB(A3)

DEFINE PUTBYT=CALL PUT.BYTE

PAGE
;***************
;*  PDV Entry  *
;***************
;Define the entry points of the .PDV
;
;  CAUTION: Do Not Change the order or size of the entry points.
;	    If any of the functions are not implemented replace the entry
;	    point with 'JMP IGNORE'.
;
;A3 indexes the impure area defined above on entry to the driver.

	PDVFLG=PD$EXT!PD$PTS!PD$PRO!PD$VAR!PD$GRY!PD$GRF!PD$LED!PD$IMG
	PDVFLG=PDVFLG!PD$KRN!PD$KEY!PD$SCR!PD$REV!PD$W21!PD$ISO!PD$ROT
	PDVFLG=PDVFLG!PD$FED

PDV:	PHDR	-1,0,PH$REE!PH$REU	; define version/characteristics
	LWORD	PDVFLG			; extended, pts-device, proportional,
					; variable, gray scale, graphics,
					; leading, image support, kerning,
					; keycaps, screened, reverse,
					; supports ISO Latin I,
					; AlphaWRITE 2.X compatible
	JMP	PDINI			; PDINI,  initialize printer
	JMP	PDCLS			; PDCLS,  shut down printer
	JMP	PDCHR			; PDCHR,  output a character in D1
	JMP	PDCTL			; PDCTL,  output control string indexed by D1
	JMP	PDSPL         		; PDSPL,  output special string & character
	JMP	PDMNLN			; PDMNLN, move to next line & start new line
	JMP	PDMTOF			; PDMTOF, move to Top of Form & setup for new page
	JMP	PDPSON			; PDPSON, enable proportional
	JMP	PDPSOF			; PDSOF,  disable proportional
	JMP	PDUNDR			; PDUNDR, toggle underscore
	JMP	PDBOLD			; PDBOLD, toggle bold
	JMP	PDSTRK			; PDSTRK, toggle strikeout
	JMP	PDBAR			; PDBAR,  toggle over-bar
	JMP	IGNORE			; PDSLPI, set Lines Per Inch
	JMP	IGNORE			; PDSHMI, set Horizontal Motion Index
	JMP	PDSCPI			; PDSCPI, set Characters Per Inch
	JMP	PDSTM			; PDSTM,  set Top Margin
	JMP	PDMTM			; PDMTM,  move to Top Margin
	JMP	PDSLPO			; PDSLPO, set Left Paper Offset
	JMP	PDMLPO			; PDMLPO, move to Left Paper Offset
	JMP	PDSLPP			; PDSLPP, set Lines per Page
	JMP	PDSLSP			; PDSLSP, set line spacing (in 1/2 lines)
	JMP	PDOVRP			; PDOVRP, setup to overprint last char.
	JMP	PDLF			; PDLF,   output LFs per count in D2
	JMP	PDDBL			; PDDBL,  toggle double-underscore
	JMP	PDFONT			; PDFONT, select font D1
	JMP	IGNORE			; PDECHR, output extended character
	JMP	IGNORE			;   ENTRY RESERVED FOR ALPHA MICRO
	JMP	IGNORE			;   ENTRY RESERVED FOR ALPHA MICRO
	JMP	IGNORE			;   ENTRY RESERVED FOR ALPHA MICRO
	JMP	IGNORE			;   ENTRY RESERVED FOR ALPHA MICRO
	JMP	IGNORE			;   ENTRY RESERVED FOR ALPHA MICRO
	JMP	IGNORE			;   ENTRY RESERVED FOR USER DEFINITION
	JMP	IGNORE			;   ENTRY RESERVED FOR USER DEFINITION
	JMP	IGNORE			;   ENTRY RESERVED FOR USER DEFINITION
	JMP	IGNORE			;   ENTRY RESERVED FOR USER DEFINITION
	JMP	IGNORE			;   ENTRY RESERVED FOR USER DEFINITION
	JMP	IGNORE			;   ENTRY RESERVED FOR USER DEFINITION
	JMP	IGNORE			;   ENTRY RESERVED FOR USER DEFINITION
	JMP	IGNORE			;   ENTRY RESERVED FOR USER DEFINITION
	JMP	PDPSIZ			; PDPSIZ, set page size to points in D2
	JMP	PDTMAR			; PDTMAR, set top margin to points in D2
	JMP	IGNORE			;   ENTRY RESERVED FOR ALPHA MICRO
	JMP	IGNORE			;   ENTRY RESERVED FOR ALPHA MICRO
	JMP	IGNORE			;   ENTRY RESERVED FOR ALPHA MICRO
	JMP	PDLEFT			; PDLEFT, set left paper offset to points in D2
	JMP	PDLEAD			; PDLEAD, set leading to points in D2
	JMP	PDFNAM			; PDFNAM, set font by name (ASCIZ string @A6)
	JMP	PDFSIZ			; PDFSIZ, set font size to points in D2
	JMP	PDITAL			; PDITAL, toggle italic
	JMP	PDSCRN			; PDSCRN, toggle screened
	JMP	PDREV			; PDREV,  toggle reverse
	JMP	PDFATR			; PDFATR, set font attributes directly
	JMP	PDMCHR			; PDMCHR, move to char position in D2
	JMP	PDMLIN			; PDMLIN, move to line position in D2
	JMP	PDMOVE			; PDMOVE, move to points (D1,D2) coordinates
	JMP	PDSAVE			; PDSAVE, save print state
	JMP	PDREST			; PDREST, restore print state
	JMP	PDFTBL			; PDFTBL, return index to font table in A6
	JMP	PDOUT			; PDOUT,  directly output byte in D1
	JMP	PDSPOR			; PDSPOR, set page orientation (D1 = "P" or "L")
	JMP	PDGRAY			; PDGRAY, set gray scale (D2 = % blk)
	JMP	PDGRAF			; PDGRAF, perform graphics. func (D2)
	JMP	PDFSUB			; PDFSUB, perform font substitution (font code in D1)
	JMP	PDTRSC			; PDTRSC, translate special character D1
	JMP	PDTREC			; PDTREC, translate extended character D1
	JMP	PDOTSC			; PDOTSC, output special character D1
	JMP	PDOTEC			; PDOTEC, output extended character D1
	JMP	PDSETL			; PDSETL, set line weight to points in D2
	JMP	PDPOVR			; PDPOVR, print page overlay (D2 indexes text)
	JMP	PDIMON			; PDIMON, begin image/icon
	JMP	PDIMOF			; PDIMOF, end image/icon
	JMP	PDKEY			; PDKEY,  toggle keycap
	JMP	IGNORE			; PDCART, set cartridge as per D2
	JMP	PDKERN			; PDKERN, set kerning as per D2
	JMP	IGNORE			; reserved
	JMP	IGNORE			; reserved
	JMP	IGNORE			; reserved

IGNORE:	RTN

PAGE
;***********
;*  PDINI  *
;***********
;Initialize the printer

PDINI:	MOV	JOBCUR,A6		; 
	MOV	JOBLNG(A6),A6		; 
	MOVB	LD.DEC(A6),DECCHR(A3)	; get and save dec. point character

	MOVW	#-1,HMISAV(A3)		; no HMI yet
	MOVW	#-1,LPISAV(A3)		; no LPI yet
	MOVW	#-1,CPISAV(A3)		; no CPI yet
	MOVW	#-1,TPMSAV(A3)		; no top margin yet
	MOVW	#-1,LPOSAV(A3)		; no left paper offset yet
	CLRW	CURCOL(A3)		; at column 0
	CLRW	CHROUT(A3)		; no characters output yet
	CLR	CURLIN(A3)		; at start of page
	MOVW	#7,CHRWID(A3)		; set default character width
	OUTSTR	PRTINI			; output PostScript preamble
	MOVW	#2,CURFNT(A3)		; select Courier as default font
	MOV	#PF$FNT,FLAGS(A3)	; set font selection flag
	MOVB	#1,PAGNUM(A3)		; init page number
	RTN				; 

;***********
;*  PDCLS  *
;***********
;Shut down the printer
;
;Inform calling application that we don't want a trailing form feed (this
;confuses most PostScript cartridges).

PDCLS:	MOV	#PF$DEL!PF$CPY,SPLPOS(A3) ; /DELETE/COPIES:n		[155]
	MOV	#PF$FF!PF$INF,SPLNEG(A3); /NOFF/NOINFORM		[155]

;	BIT	#PF$REV,FLAGS(A3)	; did we leave reverse on?
;	BEQ	10$			;   no
;	OUTSTR	REVOFF			;   yes - turn it off
;
;10$:	BIT	#PF$SCR,FLAGS(A3)	; did we leave screened on?
;	BEQ	20$			;   no
;	OUTSTR	SCROFF			;   yes - turn it off
;
20$:	OUTSTR	PRTCLS
	RTN

;***********
;*  PDCHR  *
;***********
;Output the character in D1

PDCHR:

;check special character table
;some ISO Latin I characters don't exist in the PostScript character set,
;but can be output by switching to the Symbol font

	LEA	A6,SCTBL		; index special character table
10$:	MOVB	(A6)+,D6		; get byte of table entry
	BEQ	20$			;   end of table
	MOVB	(A6)+,D7		; get second byte of table entry
	CMPB	D6,D1			; match?
	BNE	10$			;   no
	MOVB	D7,D1			; make replacement
	JMP	PDOTSC			; go handle as a special character
20$:

;special handling for fraction characters

	CMPB	D1,#188.		; 1/2?
	JEQ	SC.HAF			;   yes
	CMPB	D1,#189.		; 1/4?
	JEQ	SC.QTR			;   yes
	CMPB	D1,#190.		; 3/4?
	JEQ	SC.34			;   yes

;we are going to output character in D1 as is

PDCH2:	CALL	ENVPOS			; handle any pending envelope positioning [165]

;check for re-encoding; we only both doing this if we come across a
;character code that requires it

	BIT	#PF$NAT,FLAGS(A3),2	; using natural character set?	[147]
	BNE	3$			;   yes				[147]
	CMPB	D1,#127.		; 8-bit text character?
	BLOS	3$			;   no
	BIT	#PF$CH8,FLAGS(A3),2	; flag set already?
	BNE	3$			;   yes

	CMPW	CURFNT(A5),#'D-'A	; in dingbats?
	BEQ	3$			;   yes - don't reencode
	CMPW	CURFNT(A5),#'S-'A	; in symbol?
	BEQ	3$			;   yes - don't reencode

	OR	#PF$CH8!PF$FNT,FLAGS(A3);   no - set it & font sel. flag

3$:	MOVB	D1,LSTCHR(A3)		; 
	CALL	PDCFNT			; handle font selection
	BIT	#PF$DEF,FLAGS(A3),1	; do we have deferred attributes?
	BEQ	5$			;   no
	TSTW	CHROUT(A3)		; is this 1st char of line?
	BNE	5$			;   no
	CALL	PDCUND			; handle underscoring
	CALL	PDCDBL			; handle double underscore
	CALL	PDCBAR			; handle overbar
	CALL	PDCREV			; handle reversed text
	CALL	PDCSCR			; handle screened text
	AND	#^C<PF$DEF>,FLAGS(A3)	; 
5$:	BIT	#PF$CHR,FLAGS(A3),1	; have we started a char sequence?
	BNE	10$			;   yes
7$:	CALL	PDCKRN			; handle kerning
	OUTSTR	100$			; begin character sequence
	OR	#PF$CHR,FLAGS(A3)	; flag that we are in a sequence
10$:	CALL	PDCOUT			; output character in D1
	CALL	PDCTRK			; perform track kerning
	RTN				; return to application

100$:	ASCIZ	"("			; start of text sequence
	EVEN

;************
;*  PDCTRK  *
;************
;perform track kerning
;Width to back-up is stored in PDVARG(A3)

PDCTRK:	TSTW	KERNING(A3)		; 
	BEQ	10$			; 

	SAVE	A2,D1			; 
	CALL	ENDSTR			; 
	LEA	A2,PTDDB(A3)		; 

	TSTW	PDVARG(A3)		; 
	BMI	5$			; 

	MOVB	#'-,D1			; 
	PUTBYT				; 

5$:	LEA	A2,NUMBUF(A3)		; 
	FCVT	PDVARG(A3),0,OT$MEM!OT$NSP,2,0	; 
	CLRB	@A2			; 
	CALL	AMENUM			; make number in NUMBUF American
	CALL	OUTNUM			; output number in NUMBUF
	OUTSTR	100$			; 
	REST	A2,D1			; 

10$:	RTN				; 

100$:	ASCIZ	" .op "			; 
	EVEN				; 

;table of ISO Latin I characters that should be handled as special
;characters

SCTBL:
;[104]	BYTE	169.,C$CPY		; copyright symbol
;[104]	BYTE	174.,C$REG		; registered symbol
	BYTE	0			; ** end of table **
	EVEN

;************
;*  PDCFNT  *
;************
;Select font if deferred font selection flag is set.  Called by PDCHR.

PDCFNT:	BIT	#PF$FNT,FLAGS(A3),1	; do we need to select a font?
	BEQ	10$			;  no
	CALL	SET.FONT		;  yes - select it
	AND	#^C<PF$FNT>,FLAGS(A3)	; clear flag
10$:	RTN				; return

;************
;*  PDCUND  *
;************
;Turn on underscoring if enabled and first character of a text sequence.
;Called by PDCHR.

PDCUND:	BIT	#PF$UND,FLAGS(A3),1	; is underscore on?
	BEQ	10$			;   no
	BIT	#PF$SUS,FLAGS(A3),1	; has .sus already been issued?
	BNE	10$			;   yes - do nothing
	OUTSTR	UNDON			; start underscore
	OR	#PF$SUS,FLAGS(A3)	; remember that .sus has been sent
10$:	RTN				; return to application

;************
;*  PDCDBL  *
;************
;Turn on underscoring if enabled and first character of a text sequence.
;Called by PDCHR.

PDCDBL:	BIT	#PF$DBL,FLAGS(A3),1	; is dbl underscore on?
	BEQ	10$			;   no
	OUTSTR	DBLON			;   yes - enable it at this time
10$:	RTN				; return to application

;************
;*  PDCBAR  *
;************
;Turn on overbar if enabled and first character of a text sequence.
;Called by PDCHR.

PDCBAR:	BIT	#PF$BAR,FLAGS(A3),1	; is overbar on?
	BEQ	10$			;   no
	OUTSTR	BARON			;   yes - enable it at this time
10$:	RTN				; return to application

;************
;*  PDCREV  *
;************
;Turn on reverse text if enabled and first character of a text sequence.
;Called by PDCHR.

PDCREV:	BIT	#PF$REV,FLAGS(A3),1
	BEQ	10$
	OUTSTR	REVON
10$:	RTN

;************
;*  PDCSCR  *
;************
;Turn on screened text if enabled and first character of a text sequence.
;Called by PDCHR.

PDCSCR:	BIT	#PF$SCR,FLAGS(A3),1	; 
	BEQ	10$			; 
	OUTSTR	SCRON			; 
10$:	RTN				; 

;************
;*  PDCKRN  *
;************
;Start kerning sequence if first character of a test sequence.  Called by
;PDCHR.

PDCKRN:	BIT	#PF$PRO,FLAGS(A3),1	; proportional spacing in effect?
	BEQ	30$			;   no
	SAVE	A2,D1			; save registers
	TST	WRDSPC(A3)		; kerning amount specified?
	BNE	10$			;   yes
	TSTW	WRDSPC+4(A3)		; kerning amount specified?
	BNE	10$			;   yes
	BR	20$
10$:	LEA	A2,NUMBUF(A3)		; convert value to printable ASCII
	FCVT	WRDSPC(A3),0,OT$MEM!OT$FIX!OT$NSP,4,0	; 
	CLRB	@A2			; 
	CALL	AMENUM			; Americanize number

	BIT	#PF$CHR,FLAGS(A3),1	; 
	BNE	12$			; 
	CMPB	LSTCHR(A3),#40		; space?
	BNE	12$			;   no
	OUTSTR	NUMBUF(A3)		; 
	OUTSTR	90$			; 
12$:
	OUTSTR	NUMBUF(A3)		; output kerning value
	OUTSTR	100$			; output justification command
20$:	REST	A2,D1			; restore registers
30$:	RTN				; return

90$:	ASCIZ	" 0 rmoveto "		; 

100$:	ASCIZ	" .j "			; justify line command
	EVEN

;************
;*  PDCOUT  *
;************
;Output character in D1 to printer.  Called by PDCHR.
;Characters "(", ")", "\", and 127-255 require special PostScript handling

PDCOUT:	CMPB	D1,#'(			; left parenthesis?
	BEQ	20$			;  yes - special handling
	CMPB	D1,#')			; right parenthesis?
	BEQ	20$			;  yes - special handling
	CMPB	D1,#40			; control character?
	BLO	22$			;   yes - special handling
	CMPB	D1,#'~			; 127-255?
	BHI	22$			;  yes - special handling
	CMPB	D1,#'\			; backslash?
	BNE	30$			;  no - just output as usual
20$:	PUSHB	D1			; save character
	MOVB	#'\,D1			; output
	PUTBYT				;  leading backslash
	POPB	D1			; restore character
	BR	30$			; and now go output it
22$:	PUSHB	D1			; save character
	MOVB	#'\,D1			; output
	PUTBYT				;  leading backslash
	POPB	D1			; restore character
	AND	#377,D1			; keep just the low byte
	SAVE	A2
	LEA	A2,PTDDB(A3)		; output printable
	OCVT	3,OT$DDB		;  octal code
	REST	A2
	BR	40$			; done with special handling
30$:	PUTBYT				; output the character
40$:	INCW	CHROUT(A3)		; update character output count
	RTN				; return

;************
;*  ENVPOS  *
;************
;check to see if we are on bin 3 (envelope adaptor) of an HP with a
;PostScript cartridge. If so, we may have to position and translate the
;coordinate system (PSCART.PDV only).

ENVPOS:
	IF	EQ,PRTTYP-PSCART	; 

	BIT	#PF$ENP,FLAGS(A3)	; are we flagged to position on envelope?
	BEQ	10$			;   no

	OUTSTR	100$			;   yes - do so
	AND	#^C<PF$ENP>,FLAGS(A3)	; clear flag
	SAVE	D1,D2			; 
	MOV	MOVHRZ(A3),D1		; get last place
	MOV	MOVVRT(A3),D2		;   we positioned to
	CALL	PDMOVE			; and reposition
	REST	D1,D2			; 

	TSTW	ENVCNT(A3)		; is this the first envelope?
	BEQ	5$			;   yes
	OUTSTR	200$			; correct horizontal position
5$:	INCW	ENVCNT(A3)		; update envelope count

10$:	RTN				; 

100$:	ASCII	"statusdict begin "
	IF EQ,BIN3-LETTER,ASCII "lettertray "
	IF EQ,BIN3-LEGAL,ASCII "legaltray "
	IF EQ,BIN3-COM10,ASCII "com10envelopetray "
	IF EQ,BIN3-MONARCH,ASCII "monarcenvelopetray "
	IF EQ,BIN3-A4,ASCII "a4tray "
	IF EQ,BIN3-C5ENV,ASCII "c5envelopetray "
	IF EQ,BIN3-D1ENV,ASCII "d1envelopetray "
	ASCII	"2 setpapertray end envelopeposition "
	BYTE	$CR,$LF			; 
	BYTE	0			; 

;after first envelope, a horizontal correction is required

200$:	IF	EQ,LANDOR,ASCIZ "108 0 translate 108 0 rmoveto "
	BYTE	0
	EVEN

	IFF

	RTN				; 

	ENDC

PAGE
;***********
;*  PDCTL  *
;***********
;Output a control string.
;D1 contains the control table index

PDCTL:	CMPB	D1,#MAXCDE		; valid special code ?
	BHIS	10$			;   no, ignore it			[108]
	CALL	ENDSTR			; end anything we're in the middle of

	IF	EQ,PRTTYP-PSCART
	CMPW	D1,#PC$FEDTR1		; bin command?
	BLO	8$			;   no
	CMPW	D1,#PC$FEDTR4		; bin command?
	BHI	8$			;   no
	CMPW	D1,#PC$FEDTR3		; bin 3 selection?
	BEQ	5$			;   yes
	AND	#^C<PF$ENV!PF$ENP>,FLAGS(A3) ; clear envelope flag
	BR	8$			; 
5$:	OR	#PF$ENV!PF$ENP,FLAGS(A3) ; set envelope flag
	CLRW	ENVCNT(A3)		; clear envelope count
8$:
	ENDC

	ADDW	D1,D1			; make index into word offset
	MOVW	CTLTBL[~D1],D1		; get string offset
	OUTSTR	CTLTBL[~D1]		; go output it
10$:	RTN

;Printer control string table
;CAUTION: Do Not Change the order of the string table.
;         If the string is not implemented put a length of zero at the label.

DEFINE STRING ADDR=WORD ADDR-CTLTBL

CTLTBL:	STRING	CHOME			; 00 return carriage home
	STRING	MOVAHT			; 01 move to absolute horizontal tab
	STRING	ROLUP			; 02 roll up a partial line
	STRING	ROLDWN			; 03 roll down a partial line
	STRING	NEGLF			; 04 output negative line feed
	STRING	SPLPT0			; 05 special print position 0
	STRING	SPLPT1			; 06 special print position 1
	STRING	RIBSC1			; 07 print in Secondary ribbon color 1
	STRING	RIBSC2			; 08 print in Secondary ribbon color 2
	STRING	RIBSC3			; 09 print in Secondary ribbon color 3
	STRING	RIBPRM			; 10 print in Primary ribbon color
	STRING	FEDTR1			; 11 select Feeder tray 1
	STRING	FEDTR2			; 12 select Feeder tray 2
	STRING	FEDTR3			; 13 select Feeder tray 3
	STRING	FEDTR4			; 14 select Feeder tray 4
	STRING	FEDTGL			; 15 select Feeder tray 1 & then tray 2
	STRING	FEDEJT			; 16 select Feeder eject
 	STRING	USR1			; 17 user function 1
	STRING	USR2			; 18 user function 2
	STRING	USR3			; 19 user function 3
	STRING	USR4			; 20 user function 4
	STRING	RIBSC4			; 21 print in Secondary ribbon color 4
	STRING	RIBSC5			; 22 print in Secondary ribbon color 5
	STRING	RIBSC6			; 23 print in Secondary ribbon color 6
	STRING	RIBSC7			; 24 print in Secondary ribbon color 7

	MAXCDE	=<.-CTLTBL>/2		; maximum special code allowed

;***********
;*  PDSPL  *
;***********
;Output a control string & then the byte in D2
;String number is in D1.

PDSPL:	CALL	PDCTL			; output the string
	PUSH	D1			; preserve D1
	MOVB	D2,D1			; put byte in D1
	PUTBYT				; output it
	POP	D1			; get D1 back
	RTN				; return to application

;************
;*  PDMNLN  *
;************
;Move to Next Line and setup for new line

PDMNLN:	SAVE	D1-D2			; save registers
	CALL	ENDSTR			; finish up if in a text sequence
	ENDATT	PF$UND,UNDOFF,PF$SUS
	ENDATT	PF$DBL,DBLOFF
	ENDATT	PF$BAR,BAROFF
	ENDATT	PF$REV,REVOFF
	ENDATT	PF$SCR,SCROFF
	OR	#PF$DEF,FLAGS(A3)	; flag deferred attributes

	CLR	D2			; 
	MOVW	LSPSAV(A3),D2		; 
	CMPW	D2,#2			; 
	BEQ	30$			; 

10$:	CMPW	D2,#1			; 
	BLT	30$			; 
	BEQ	20$			; 
	OUTSTR	100$			; nl		move to next line
	SUBW	#2,D2			; 
	BR	10$			; 

20$:	OUTSTR	120$			; .ru

30$:	BIT	#PF$UND,FLAGS(A3),1	; are we underscoring?
	BNE	90$			;   yes
	BIT	#PF$DBL,FLAGS(A3),1	; double underscore?
	BNE	90$			;   yes
	BIT	#PF$BAR,FLAGS(A3),1	; in overbar?
	BNE	90$			;   yes
	BIT	#PF$REV,FLAGS(A3),1	; are we reversing?
	BNE	90$			;   yes
	BIT	#PF$SCR,FLAGS(A3),1	; are we screening?
	BEQ	92$			;   no
90$:	CMPW	LSPSAV(A3),#2		; 
	BEQ	95$			; 
	BIT	#PF$SL,FLAGS(A3),1	; did we just output <sl>?
	BNE	99$			;   yes - no need to do it again
	OUTSTR	110$			; sl	move to left offset
	OR	#PF$SL,FLAGS(A3)	; 
	BR	99$			; 
92$:	CMPW	LSPSAV(A3),#2		; 
	BNE	99$			; 
95$:	OUTSTR	130$			; move to left offset of new line
	OR	#PF$SL,FLAGS(A3)	; set <ls> flag
99$:	CLRW	CHROUT(A3)		; clear character output count
	REST	D1-D2			; restore registers
	RTN				; return to application

100$:	ASCIZ	"nl "
110$:	ASCIZ	"sl "
120$:	ASCIZ	".ru "
130$:	ASCIZ	"ns "
	EVEN

;************
;*  PDMTOF  *
;************
;Move to Top of Form and setup for new page

PDMTOF:	SAVE	A2,D1-D2		; save registers

	INCB	PAGNUM(A3)		; update page number
	CALL	ENDST2			; finish up current text sequence

	CLEAR	ENCFLG(A3),36.		; clear all font encoding flags	[CUS]

;call AMLAS.PS new page routine and output new page comment

	OUTSTR	100$			; call new page routines in AMLAS.PS
	LEA	A2,PTDDB(A3)		; 
	CLR	D1			; 
	MOVB	PAGNUM(A3),D1		; 
	DCVT	0,OT$DDB		; 
	OUTSTR	102$			; 

;reset left paper offset

	CLR	D2
	MOVW	LPOSAV(A3),D2		; get current left margin
	CALL	PDLEFT			; reset left margin to current setting

;re-establish point size

	OUTSTR	120$			; /.ps
	LEA	A2,PTDDB(A3)		; 
	MOV	TYPSIZ(A3),D1		; point size
	BEQ	5$			;   zero somehow
	DCVT	0,OT$DDB		; {n}
	OUTSTR	130$			; def
	BR	10$			; 

5$:	OUTSTR	195$			; pop

10$:	OUTSTR	140$			; /.ld
	LEA	A2,PTDDB(A3)		; 
	CLR	D1			; 
	MOVW	LEADING(A3),D1		; leading
	DCVT	0,OT$DDB		; {n}
	OUTSTR	150$			; def

	OUTSTR	110$			; set line position

	BIT	#PF$GRY,FLAGS(A3),1	; is gray on?
	BEQ	90$			;   no
	LEA	A2,PTDDB(A3)		; 
	CLR	D1			; 
	MOVW	GRYVAL(A3),D1		; 
	DCVT	0,OT$DDB!OT$TSP		; 
	OUTSTR	200$			; 

90$:	CLR	CURLIN(A3)		; reset internal vertical position
	OR	#PF$FNT,FLAGS(A3)	; set font selection flag

;reset orientation if we're still in landscape mode

	BIT	#PF$ENV,FLAGS(A3)	; working w/envelope adaptor?	[165]
	BNE	91$			;   yes				[165]
	BIT	#PF$LND,FLAGS(A3),1	; in landscape?
	BEQ	92$			;   no
	MOVB	#'L,D1			; yes - reset
	CALL	PDSPOR			;       orientation for new page
	BR	92$			; 

91$:	OR	#PF$ENP,FLAGS(A3)	; set envelope position flag	[165]

92$:	CLRW	CHROUT(A3)		; 
	REST	A2,D1-D2		; restore registers
	RTN				; return

100$:	ASCII	"newpage"
	BYTE	15,12,15,12		; 
	ASCIZ	"%% -------- page "	; 

102$:	ASCII	" --------"		; 
	BYTE	15,12,15,12		; 
	BYTE	0			; 
110$:	ASCII	" sl"			; 
	BYTE	15,12,0			; 
120$:	ASCIZ	"/.ps "			; /.ps
130$:	ASCIZ	" def "			; 
140$:	ASCIZ	"/.ld "			; 
150$:	ASCIZ	" def "			; 
195$:	ASCIZ	" pop "			; 
200$:	ASCIZ	" 100 div setgray "	; 
	EVEN				; 

;************************
;*	PDPSON		*
;************************
; Enable proportional spacing

PDPSON:	OR	#PF$PRO,FLAGS(A3)
	CALL	ENDSTR
	RTN

;************************
;*	PDPSOF		*
;************************
; Disable proportional spacing

PDPSOF:	AND	#^C<PF$PRO>,FLAGS(A3)	; 
	CALL	ENDSTR			; 
	RTN				; 

;************************
;*	PDUNDR		*
;************************
; Toggle Underscore

PDUNDR:	XOR	#PF$UND,FLAGS(A3)	; flip underscore flag
	CALL	ENDSTR			; end text-in-progress
	BIT	#PF$UND,FLAGS(A3),1	; did we turn it on or turn it off?
	BNE	10$			; we turned it on - just leave flag
	OUTSTR	UNDOFF			; turn underscore off
	AND	#^C<PF$SUS>,FLAGS(A3)	; .us has been issued
	RTN				; 
10$:	OUTSTR	UNDON			;  yes - start underscore now
	OR	#PF$SUS,FLAGS(A3)	; remember .sus has been issued
20$:	RTN				; return

UNDON:	ASCIZ	".sus "
UNDOFF:	ASCIZ	".us "
	EVEN

;***********
;*  PDDBL  *
;***********
;Toggle double underscore

PDDBL:	XOR	#PF$DBL,FLAGS(A3)	; flip underscore flag
	CALL	ENDSTR			; end text-in-progress
	BIT	#PF$DBL,FLAGS(A3),1	; did we turn it on or turn it off?
	BNE	10$			; we turned it on - just leave flag
	OUTSTR	DBLOFF			; turn underscore off
	RTN
10$:	OUTSTR	DBLON			;  yes - start underscore now
20$:	RTN				; return

DBLON:	ASCIZ	".sus "
DBLOFF:	ASCIZ	".dus "
	EVEN

;***********
;*  PDBAR  *
;***********
;Toggle overbar

PDBAR:	XOR	#PF$BAR,FLAGS(A3)	; flip overbar flag
	CALL	ENDSTR			; end text-in-progress
	BIT	#PF$BAR,FLAGS(A3),1	; did we turn it on or turn it off?
	BNE	10$			; we turned it on - just leave flag
	OUTSTR	BAROFF			; turn overbar off
	RTN
10$:	OUTSTR	BARON			;  yes - start overbar now
20$:	RTN				; return

BARON:	ASCIZ	".sbar "
BAROFF:	ASCIZ	".bar "
	EVEN

PAGE
;************************
;*	PDBOLD		*
;************************
; Toggle Bold

PDBOLD:	CALL	ENDSTR			; finish up text-in-progress
	XOR	#PF$BLD,FLAGS(A3)	; flip bold flag
	OR	#PF$FNT,FLAGS(A3)	; set font selection flag
	RTN				; return

PAGE
;************************
;*	PDSTRK		*
;************************
; Toggle strikeout

PDSTRK:	BCHG	#FM%STK,FM.FLG(A3)	; toggle strikeout flag
	BNE	STKOUT			;  and go do it if end of field
	MOVW	CURCOL(A3),STKCOL(A3)	;   or set field start
	MOVB	D1,STKCHR(A3)		; save strikeout character
	RTN

; Test for strikeout and output it if true

STKTST:	BTST	#FM%STK,FM.FLG(A3)	; strikeout active ?
	BEQ	STKOTX			;   no, just return

; Output everything up to here & return the carriage home

STKOUT:	SAVE	D1,D2
	MOVB	#$CR,D1			; get a carriage return
	PUTBYT				;  and output it

; Output leading spaces until start of strikeout field
;
	MOVW	STKCOL(A3),D2		; get start of strikeout field
	MOVB	#$SPC,D1		; get a space
	BR	15$			;  and enter loop at end

10$:	PUTBYT				; output a space
15$:	DBF	D2,10$			; loop until start of strikeout field

; Output the required number of strikeout
;
	MOVW	CURCOL(A3),D2		; get field end
	SUBW	STKCOL(A3),D2		;  and calculate field length
	MOVB	STKCHR(A3),D1		; get strikeout character
	BR	25$			;  and enter loop at end

20$:	PUTBYT				; output an strikeout
25$:	DBF	D2,20$			; loop until end of strikeout field
	REST	D1,D2
STKOTX:	CLRW	STKCOL(A3)
	RTN

PAGE
;************************
;*	PDSTM		*
;************************
; Set Top Margin from value in D2
;  D2 contains the number of lines required in the Top Margin

PDSTM:	SAVE	D2
	MUL	D2,#12.			; convert lines to points
	MOVW	D2,TPMSAV(A3)		; save top margin value
	REST	D2
	RTN

;************************
;*	PDMTM		*
;************************
; Move to Top Margin

PDMTM:	SAVE	D1,D2			; save register
	CLR	D1			; 
	MOVW	LPOSAV(A3),D1		; get horizontal coordinate
	CLR	D2			; 
	MOVW	TPMSAV(A3),D2		; get vertical coordinate
	CALL	PDMOVE			; move there
	REST	D1,D2
	RTN

;************************
;*	PDLF		*
;************************
; Output Line feeds per count in D2

PDLF:	SAVE	A2,D1,D2		; save pointer
	CALL	ENDSTR			; finish up if in a text sequence
	LEA	A2,PTDDB(A3)		; index the DDB
	MOV	D2,D1			; get number of linefeeds
	DCVT	0,OT$DDB!OT$TSP		; output it
	OUTSTR	100$			; index command string
	ASL	D2			; make into 1/2 lines
	ADD	D2,CURLIN(A3)		; bump number of 1/2 lines
	REST	A2,D1,D2		; restore registers
	RTN

100$:	ASCIZ	/lf /
	EVEN

PAGE
;************
;*  PDSCPI  *
;************
; Set characters per inch (pitch)
;  D2 contains the CPI setting

PDSCPI:
	MOV	#72.,D1
	DIV	D1,D2
	AND	#177777,D1
	MOVW	D1,CHRWID(A3)		; store character width in points
	RTN

PAGE
;************************
;*	PDSLPO		*
;************************
; Set Left Paper Offset
;  D2 contains the number of 1/10 inch units required

PDSLPO:	SAVE	A2,D1
	CALL	ENDSTR			; finish up if in a text sequence
	MUL	D2,#72.			; convert to points*10
	DIV	D2,#10.			; convert to points
	AND	#177777,D2		; discard remainder
	MOVW	D2,LPOSAV(A3)		; save left paper offset
;	OUTSTR	10$			; 
	CLR	D1			; 
	MOVW	D2,D1			; 
	LEA	A2,PTDDB(A3)		; 
	DCVT	0,OT$DDB		; 
	OUTSTR	20$			; 
	REST	A2,D1
	RTN

;10$:	ASCIZ	"/.lpo "		; 
;20$:	ASCIZ	" def "			; 
20$:	ASCIZ	" lm "			; 
	EVEN				; 

;************************
;*	PDMLPO		*
;************************
; Move to Left Paper Offset

PDMLPO:	BIT	#PF$SL,FLAGS(A3),1	; did we just output <sl>?
	BNE	10$			;   yes - don't be redundant
	OUTSTR	100$			; index string to start new line
10$:	CLRW	CHROUT(A3)		; 
	RTN				; 

100$:	ASCIZ	"sl "			; 
	EVEN				; 

PAGE
;************************
;*	PDSLPP		*
;************************
; Set lines per page
;  D2 contains the form length in number of lines

PDSLPP:	MOV	D2,D7			; 
	MUL	D7,#12.			; convert to points (crude...)
	MOVW	D7,LPPSAV(A3)		; save for later
	RTN				; 

;************
;*  PDPSIZ  *
;************
;set page size in points

PDPSIZ:	MOVW	D2,LPPSAV(A3)		; 
	RTN				; 

PAGE
;************************
;*	PDSLSP		*
;************************
; Set line spacing
;  D2 contains the number of 1/2 lines

PDSLSP:	MOVW	D2,LSPSAV(A3)		; save for later
	RTN				; 

;************
;*  PDLEAD  *
;************
;Set leading to points in D2

PDLEAD:	SAVE	A2,D1			; 

	CMPW	D2,LEADING(A3)		; has leading changed?
	BEQ	10$			;   no

	CALL	ENDSTR			; 
	MOV	D2,D1			; 

	MOVW	D1,LEADING(A3)		; 
	OUTSTR	100$			; /.ld
	LEA	A2,PTDDB(A3)		; 
	DCVT	0,OT$DDB		; {n}
	OUTSTR	200$			; def

10$:	REST	A2,D1			; 
	RTN				; 

100$:	ASCIZ	"/.ld "			; 
200$:	ASCIZ	" def "			; 
	BYTE	0			; 
	EVEN				; 

PAGE
;************
;*  ENDSTR  *
;************
;End a string if we were in the middle of one

ENDSTR:	BIT	#PF$CHR,FLAGS(A3),1	; are we in the middle of a char sequence?
	BEQ	20$			;   no
	AND	#^C<PF$CHR>,FLAGS(A3)	;   yes - clear flag for next time
	LEA	A6,100$			; 
	BIT	#PF$PRO,FLAGS(A3),1	; proportional spacing in effect?
	BEQ	10$			;   no
	LEA	A6,200$			;   yes - change index
10$:	CALL	STROUT			; 
20$:	CLRW	CHROUT(A3)		; 
	BIT	#PF$DEF,FLAGS(A3),1	; 
	BEQ	25$			; 
	CALL	PDCUND			; 
	CALL	PDCDBL			; 
	CALL	PDCBAR			; 
	CALL	PDCREV			; 
	AND	#^C<PF$DEF>,FLAGS(A3)	; 
25$:	RTN				; 

100$:	ASCII	") show"		; 
	BYTE	$CR,$LF,0		; 

200$:	ASCII	") kshow"		; 
	BYTE	$CR,$LF,0		; 
	EVEN				; 

;************
;*  ENDST2  *
;************
;End a string if we were in the middle of one - do not resume attributes

ENDST2:	BIT	#PF$CHR,FLAGS(A3),1	; are we in the middle of a char sequence?
	BEQ	20$			;   no
	AND	#^C<PF$CHR>,FLAGS(A3)	;   yes - clear flag for next time
	LEA	A6,100$			; 
	BIT	#PF$PRO,FLAGS(A3),1	; proportional spacing in effect?
	BEQ	10$			;   no
	LEA	A6,200$			;   yes - change index
10$:	CALL	STROUT			; 
20$:	CLRW	CHROUT(A3)		; 
	RTN				; 

100$:	ASCII	") show"		; 
	BYTE	$CR,$LF,0		; 

200$:	ASCII	") kshow"		; 
	BYTE	$CR,$LF,0		; 
	EVEN				; 

;************************
;*	PDOVRP		*
;************************
; Setup to overprint the last character
; Width of prev. char is stored in CWIDTH(A3)

PDOVRP:	SAVE	A2,D1			; 
	CALL	ENDSTR			; 
	LEA	A2,PTDDB(A3)		; 

	TSTW	CWIDTH(A3)		; 
	BMI	10$			; 

	MOVB	#'-,D1			; 
	PUTBYT				; 

10$:	LEA	A2,NUMBUF(A3)		; 
	FCVT	CWIDTH(A3),0,OT$MEM!OT$NSP,2,0	; 
	CLRB	@A2			; 
	CALL	AMENUM			; Americanize number
	CALL	OUTNUM			; Output number
	OUTSTR	100$			; 
	REST	A2,D1			; 
	RTN				; 

100$:	ASCIZ	" .op "			; 
	EVEN				; 

;************
;*  PDFONT  *
;************
;Select font
;
;D1 contains font (ASCII A-Z) to select

PDFONT:	SAVE	D1			; 
	CALL	ENDSTR			; 
	CMPB	D1,#'A			; 
	BLO	10$			; 
	CMPB	D1,#'Z			; 
	BLOS	20$			; 
10$:	MOVB	#'C,D1			; 
20$:	AND	#377,D1			; 
	SUBB	#'A,D1			; make font 0-based
	MOVW	D1,CURFNT(A3)		; store font
	OR	#PF$FNT,FLAGS(A3)	; set font selection flag
	REST	D1			; 
	RTN				; 

;**************
;*  SET.FONT  *
;**************
;Select font in CURFNT(A3) (0..n)

SET.FONT:
	SAVE	A2,D1			; 
	CALL	ENDSTR			; finish up if in a text sequence
	LEA	A2,PTDDB(A3)		; 
	CLR	D1			; 
	MOVW	CURFNT(A3),D1		; 

	CMPB	D1,#'D-'A		; dingbats?
	BEQ	2$			;   yes - never re-encode
	CMPB	D1,#'S-'A		; symbol?
	BEQ	2$			;   yes - never re-encode

	BIT	#PF$NAT,FLAGS(A3),2	; using natural character set?	[147]
	BNE	2$			;   yes				[147]
	BIT	#PF$CH8,FLAGS(A3),2	; working w/8-bit characters?
	BNE	5$			;   yes

2$:	OUTSTR	110$			; select font w/o re-encoding
	BR	7$			; 

5$:	CALL	GET.ENCODING

	LEA	A6,ENCFLG(A3)		; 
	CLR	D7			; 
	MOVB	ENCNUM(A3),D7		; 
	ADD	D7,A6			; 
	TSTB	@A6			; has this font already been encoded?
	BEQ	6$			;   no

	OUTSTR	300$			; (NF
	CLR	D1			; 
	MOVB	ENCNUM(A3),D1		; 
	DCVT	0,OT$DDB		; 
	JMP	21$			; 

;re-encode font

6$:	OUTSTR	100$			; select font w/re-encoding
	CLR	D1			; 
	MOVB	ENCNUM(A3),D1		; 
	DCVT	0,OT$DDB		; 
	OUTSTR	102$			; 
	MOVW	CURFNT(A3),D1		; 

;mark font as encoded

	LEA	A6,ENCFLG(A3)		; 
	CLR	D7			; 
	MOVB	ENCNUM(A3),D7		; 
	ADD	D7,A6			; 
	SETB	@A6			; mark font as encoded

7$:	LEA	A6,FONTS		; 
	BIT	#PF$ITA,FLAGS(A3),1	; italic selected?
	BNE	8$			;  yes
	BIT	#PF$BLD,FLAGS(A3),1	; bold selected?
	BEQ	9$			;  no
	LEA	A6,BOLD.FONTS		; 
	BR	9$			; 
8$:	LEA	A6,ITALIC.FONTS		;  yes - use italic font table
	BIT	#PF$BLD,FLAGS(A3),1	; bold AND italic?
	BEQ	9$			;   no
	LEA	A6,BOLD.ITALIC.FONTS	;   yes
9$:	TSTB	D1			; 
	BEQ	20$			; 
10$:	TSTB	(A6)+			; 
	BNE	10$			; 
	SOB	D1,10$			; 
20$:	CALL	STROUT			; 

	CMPB	CURFNT(A3),#'D-'A	; Dingbats?
	BEQ	21$			;   yes
	CMPB	CURFNT(A3),#'S-'A	; Symbol?
	BEQ	21$			;   yes

	BIT	#PF$NAT,FLAGS(A3),2	; using natural character set?	[147]
	BNE	21$			;   yes				[147]
	BIT	#PF$CH8,FLAGS(A3),2	; working w/8-bit characters?
	BNE	22$			;   yes

21$:	OUTSTR	220$			; 
	BR	25$			; 

22$:	OUTSTR	200$			; 
	CLR	D1			; 
	MOVB	ENCNUM(A3),D1		; 
	DCVT	0,OT$DDB		; 
	OUTSTR	202$			; 
	MOVW	CURFNT(A3),D1		; 

25$:	REST	A2,D1			; 
	RTN				; 

110$:	ASCIZ	"("			; 

220$:	ASCIL	<) .font>		; 
	BYTE	0			; 
	EVEN				; 

100$:	ASCIZ	"stdencoding /NF"

102$:	ASCIZ	" /"			; 				[104]

200$:	ASCIZ	" .RE .ps /NF"

202$:	ASCIL	< .F>			; 				[104]
	BYTE	0			; 				[104]

300$:	ASCIZ	"(NF"			; 

	EVEN				; 				[104]

FONTS:	ASCIZ	/AvantGarde-Book/	; A
	ASCIZ	/Bookman-Light/		; B
	ASCIZ	/Courier/		; C
	ASCIZ	/ZapfDingbats/		; D
	ASCIZ	//			; E
	ASCIZ	//			; F
	ASCIZ	//			; G
	ASCIZ	/Helvetica/		; H
	ASCIZ	/Helvetica-Narrow/	; I
	ASCIZ	//			; J
	ASCIZ	//			; K
	ASCIZ	//			; L
	ASCIZ	//			; M
	ASCIZ	/NewCenturySchlbk-Roman/; N
	ASCIZ	//			; O
	ASCIZ	/Palatino-Roman/	; P
	ASCIZ	//			; Q
	ASCIZ	//			; R
	ASCIZ	/Symbol/		; S
	ASCIZ	/Times-Roman/		; T
	ASCIZ	/UPC/			; U
	ASCIZ	//			; V
	ASCIZ	//			; W
	ASCIZ	//			; X
	ASCIZ	//			; Y
	ASCIZ	/ZapfChancery-MediumItalic/ ; Z
	EVEN

BOLD.FONTS:
	ASCIZ	/AvantGarde-Demi/	; A
	ASCIZ	/Bookman-Demi/		; B
	ASCIZ	/Courier-Bold/		; C
	ASCIZ	/ZapfDingbats/		; D
	ASCIZ	//			; E
	ASCIZ	//			; F
	ASCIZ	//			; G
	ASCIZ	/Helvetica-Bold/	; H
	ASCIZ	/Helvetica-Narrow-Bold/	; I
	ASCIZ	//			; J
	ASCIZ	//			; K
	ASCIZ	//			; L
	ASCIZ	//			; M
	ASCIZ	/NewCenturySchlbk-Bold/	; N
	ASCIZ	//			; O
	ASCIZ	/Palatino-Bold/		; P
	ASCIZ	//			; Q
	ASCIZ	//			; R
	ASCIZ	/Symbol/		; S
	ASCIZ	/Times-Bold/		; T
	ASCIZ	/UPC/			; U
	ASCIZ	//			; V
	ASCIZ	//			; W
	ASCIZ	//			; X
	ASCIZ	//			; Y
	ASCIZ	/ZapfChancery-MediumItalic/ ; Z
	EVEN

ITALIC.FONTS:
	ASCIZ	/AvantGarde-BookOblique/	; A
	ASCIZ	/Bookman-LightItalic/		; B
	ASCIZ	/Courier-Oblique/		; C
	ASCIZ	/ZapfDingbats/			; D
	ASCIZ	//				; E
	ASCIZ	//				; F
	ASCIZ	//				; G
	ASCIZ	/Helvetica-Oblique/		; H
	ASCIZ	/Helvetica-Narrow-Oblique/	; I
	ASCIZ	//				; J
	ASCIZ	//				; K
	ASCIZ	//				; L
	ASCIZ	//				; M
	ASCIZ	/NewCenturySchlbk-Italic/	; N
	ASCIZ	//				; O
	ASCIZ	/Palatino-Italic/		; P
	ASCIZ	//				; Q
	ASCIZ	//				; R
	ASCIZ	/Symbol/			; S
	ASCIZ	/Times-Italic/			; T
	ASCIZ	/UPC/				; U
	ASCIZ	//				; V
	ASCIZ	//				; W
	ASCIZ	//				; X
	ASCIZ	//				; Y
	ASCIZ	/ZapfChancery-MediumItalic/	; Z

BOLD.ITALIC.FONTS:
	ASCIZ	/AvantGarde-DemiOblique/	; A
	ASCIZ	/Bookman-DemiItalic/		; B
	ASCIZ	/Courier-BoldOblique/		; C
	ASCIZ	/ZapfDingbats/			; D
	ASCIZ	//				; E
	ASCIZ	//				; F
	ASCIZ	//				; G
	ASCIZ	/Helvetica-BoldOblique/		; H
	ASCIZ	/Helvetica-Narrow-BoldOblique/	; I
	ASCIZ	//				; J
	ASCIZ	//				; K
	ASCIZ	//				; L
	ASCIZ	//				; M
	ASCIZ	/NewCenturySchlbk-BoldItalic/	; N
	ASCIZ	//				; O
	ASCIZ	/Palatino-BoldItalic/		; P
	ASCIZ	//				; Q
	ASCIZ	//				; R
	ASCIZ	/Symbol/			; S
	ASCIZ	/Times-BoldItalic/		; T
	ASCIZ	/UPC/				; U
	ASCIZ	//				; V
	ASCIZ	//				; W
	ASCIZ	//				; X
	ASCIZ	//				; Y
	ASCIZ	/ZapfChancery-MediumItalic/	; Z
	EVEN

;************
;*  PDTMAR  *
;************
;Set top margin to points in D2

PDTMAR:
	MOVW	D2,TPMSAV(A3)		; save top margin value
	RTN

;************
;*  PDLEFT  *
;************
;Set text length to points in D2

PDLEFT:	SAVE	A2,D1
	CALL	ENDSTR			; finish up if in a text sequence
	MOVW	D2,LPOSAV(A3)		; save left paper offset
	CLR	D1			; 
	MOVW	D2,D1			; 
	LEA	A2,PTDDB(A3)		; 
	DCVT	0,OT$DDB		; 
	OUTSTR	20$			; 
	REST	A2,D1
	RTN

20$:	ASCIZ	" lm "
	EVEN

;************
;*  PDFNAM  *
;************
;Set font by name (ASCIZ string @A6)

PDFNAM:	RTN

;************
;*  PDFSIZ  *
;************
;Set font size to points in D2

PDFSIZ:	SAVE	A2,D1			; 

	CMP	D2,#1			; legal point size?
	BLT	10$			;   no

	MOV	D2,TYPSIZ(A3)		; 
	CALL	ENDSTR			; 

	OUTSTR	100$			; /.ps
	LEA	A2,PTDDB(A3)		; 
	MOV	TYPSIZ(A3),D1		; 
	DCVT	0,OT$DDB		; {n}
	OUTSTR	200$			; def

	OR	#PF$FNT,FLAGS(A3)	; set font selection flag

10$:	REST	A2,D1			; 
	RTN				; 

100$:	ASCIZ	"/.ps "

200$:	ASCIL	< def>
	BYTE	0
	EVEN

;************
;*  PDITAL  *
;************
;Toggle italic

PDITAL:	CALL	ENDSTR			; 
	XOR	#PF$ITA,FLAGS(A3)	; 
	OR	#PF$FNT,FLAGS(A3)	; set font selection flag
	RTN				; 

;************
;*  PDSCRN  *
;************
;Toggle screened

PDSCRN:	AND	#^C<PF$DEF>,FLAGS(A3)	; 
	XOR	#PF$SCR,FLAGS(A3)	; flip screened flag
	CALL	ENDSTR			; end text-in-progress
	BIT	#PF$SCR,FLAGS(A3),1	; did we turn it on or turn it off?
	BNE	10$			; we turned it on - just leave flag
	OUTSTR	SCROFF			; turn screen off
	RTN
10$:	OUTSTR	SCRON			;  yes - start screen now
20$:	RTN				; return

SCRON:	ASCIZ	".sscr /.scrsav {"
SCROFF:	ASCIZ	"} def .scrsav .scr .scrsav "
	EVEN

;***********
;*  PDREV  *
;***********
;Toggle Reverse

PDREV:	AND	#^C<PF$DEF>,FLAGS(A3)	; 
	XOR	#PF$REV,FLAGS(A3)	; flip reverse flag
	CALL	ENDSTR			; end text-in-progress
	BIT	#PF$REV,FLAGS(A3),1	; did we turn it on or turn it off?
	BNE	10$			; we turned it on - just leave flag
	OUTSTR	REVOFF			; turn reverse off
	RTN
10$:	OUTSTR	REVON			;  yes - start reverse now
20$:	RTN				; return

REVON:	ASCIZ	".srev /.revsav {"
REVOFF:	ASCIZ	"} def .rev "
	EVEN

;************
;*  PDFATR  *
;************
;Set font attributes directly
;
;	D2 contains bit flags:
;
;		PA$BLD=1		;  bold
;		PA$UND=2		;  underscore
;		PA$ITA=4		;  italic
;		PA$SCR=10		;  screened
;		PA$REV=20		;  reverse
;		PA$DBL=40		;  double underscore
;		PA$BAR=100		;  overbar
;		PA$GRY=200		;  gray

PDFATR:	SAVE	A0,D0-D3		; save registers
	LEA	A0,FA.TBL		; index font attribute table
	CLR	D0			; clear
	CLR	D1			; clear
	CLR	D3			; clear
10$:	MOVB	(A0)+,D0		; get table bit
	BEQ	40$			;   end of table
	MOVB	(A0)+,D1		; get internal bit
	MOVW	(A0)+,D3		; get table offset
	BIT	D0,D2			; do we want bit set or cleared?
	BEQ	20$			;   we want it cleared

;make sure internal attribute bit is set

	BIT	D1,FLAGS(A3)		; is internal bit set already?
	BNE	10$			;   yes - take no action
	BR	30$			; execute routine

;make sure internal attribute bit is cleared

20$:	BIT	D1,FLAGS(A3)		; is internal bit clear already?
	BEQ	10$			;   yes - take no action

;execute D3 routine to toggle attribute

30$:	LEA	A6,PDV			; index printer driver base
	SAVE	A0-A6,D0-D7		; save everything
	CALL	0(A6)[~D3]		; call appropriate routine
	REST	A0-A6,D0-D7		; restore everything
	BR	10$			; go handle next bit

;restore & return

40$:	BIT	#PF$UND,FLAGS(A3),1	; did we turn off underscore?
	BNE	42$			;   no
	AND	#^C<PF$SUS>,FLAGS(A3)	;   yes - clear all flags

42$:	REST	A0,D0-D3		; restore registers
	RTN				; return

;table of D2 attribute bits, corresponding internal FLAGS(A3) bits, and
;routine to call

FA.TBL:	BYTE	PA$BLD,PF$BLD		; bold
	WORD	P.BOLD			; 
	BYTE	PA$UND,PF$UND		; underscore
	WORD	P.UNDR			; 
	BYTE	PA$ITA,PF$ITA		; italics
	WORD	P.ITAL			; 
	BYTE	PA$DBL,PF$DBL		; double underscore
	WORD	P.DBL			; 
	BYTE	PA$BAR,PF$BAR		; overbar
	WORD	P.BAR			; 
	BYTE	PA$GRY,PF$GRY		; gray
	WORD	P.GRAY			; 
	BYTE	0			; ** end of table **
	EVEN				; 

;************
;*  PDMCHR  *
;************
;Move to char position in D2

PDMCHR:	SAVE	A2,D1			; 
	CALL	ENDSTR			; finish out of current string
	MOV	D2,D1			; 
	CLR	D6			; get
	MUL	D1,#72.			; convert characters to points
	DIV	D1,#10.			; 
	AND	#177777,D1		; 
	LEA	A2,PTDDB(A3)		; 
	DCVT	0,OT$DDB		; 
	OUTSTR	100$			; 
	REST	A2,D1			; 
	RTN				; 

100$:	ASCIZ	" .mc "
	EVEN

;************
;*  PDMLIN  *
;************
;Move to line position in D2

PDMLIN:	RTN

;***********
;* PDMOVE  *
;***********
;Move to points (D1,D2) coordinates
;D1 contains the column in points
;D2 contains the row in points (0,0 is TOP left corner of page)

PDMOVE:	SAVE	A2,D1-D2		; save registers

	MOV	D1,MOVHRZ(A3)		; save last place
	MOV	D2,MOVVRT(A3)		;   we positioned at

	CALL	ENDSTR			; finish up any text-in-progrss
	LEA	A2,PTDDB(A3)		; index output DDB
	DCVT	0,OT$DDB!OT$TSP		; output column

	MOV	D2,D1			; get row
	MOV	D1,D6			; calculate

	CLR	D1			; get
	MOVW	LPPSAV(A3),D1		;   page size
	SUB	D6,D1			;   orientation coordinates
	DCVT	0,OT$DDB		; output row

	OUTSTR	100$			; finish command

	REST	A2,D1-D2		; restore registers
	RTN				; return

100$:	ASCIL	< .mv>
	BYTE	0
	EVEN

;************
;*  PDSAVE  *
;************
;Save print state

PDSAVE:	CALL	ENDSTR			; 
	OUTSTR	100$			; 
	RTN				; 

100$:	ASCIL				; 
	ASCIL				; 
	ASCIL	<.beginEPSF>		; 
	ASCIL				; 
	BYTE	0			; 
	EVEN

;************
;*  PDREST  *
;************
;Restore print state

PDREST:	CALL	ENDSTR			; 
	OUTSTR	100$			; 
	RTN				; 

100$:	ASCIL				; 
	ASCIL	<.endEPSF>		; 
	ASCIL				; 
	BYTE	0			; 
	EVEN

;************
;*  PDFTBL  *
;************
;Return index to font table in A6

PDFTBL:	LEA	A6,FONT.TABLE
	RTN

;***********
;*  PDOUT  *
;***********
;Directly output byte in D1

PDOUT:	CALL	ENDSTR			; get out of current string
	CALL	PDCFNT			; select font if necessary
	CMPB	D1,#'D-'@		; ^D?
	BNE	10$			;   yes - supress
	MOVB	#40,D1			; 
10$:	PUTBYT				; 
	RTN				; 

;************
;*  PDSPOR  *
;************
;Set page orientation.  Low byte in D1 contains "P" for Portrait or "L" for
;landscape orientation.

PDSPOR:	CALL	ENDSTR			; finish up if in a text sequence
	UCS				; make D1 upper case
	CMPB	D1,#'P			; P)ortrait?
	BEQ	10$			;  yes
	CMPB	D1,#'L			; L)andscape?
	BEQ	20$			;  yes
	RTN				; do nothing and return
10$:	AND	#^C<PF$LND>,FLAGS(A3)	; clear landscape flag
	OUTSTR	PORT			; select portrait
	RTN				; return
20$:	OR	#PF$LND,FLAGS(A3)	; set landscape flag
	OUTSTR	LAND			; select landscape
	RTN				; return

LAND:	ASCIZ	".land "
	BYTE	0
PORT:	ASCIZ	".port "
	BYTE	0
	EVEN

;************
;*  PDGRAY  *
;************
;Toggle gray
;
;If enabling gray, D2 must contain the gray percentage, which may range
;from 0 (white) to 100. (black).

PDGRAY:	SAVE	A2,D1-D2		; 
	MOV	D2,D1			; 
	MOV	#100.,D2		; 
	SUB	D1,D2			; 
	XOR	#PF$GRY,FLAGS(A3)	; flip underscore flag
	CALL	ENDSTR			; finish up if in a text sequence
	LEA	A2,PTDDB(A3)		; 
	BIT	#PF$GRY,FLAGS(A3),1	; did we turn gray on or off?
	BNE	PDGON			;   on

PDGOFF:	CLR	D2			; 

PDGON:	MOVW	D2,GRYVAL(A3)		; 
	MOV	D2,D1			; 
	DCVT	0,OT$DDB!OT$TSP		; 
	OUTSTR	100$			; 
	REST	A2,D1-D2		; 
	RTN				; 

100$:	ASCIZ	" 100 div setgray "	; 
	EVEN				; 

;************
;*  PDGRAF  *
;************
;Perform graphics function as per function code in D2
;D1 contains entity number (1 or greater)

PDGRAF:	SAVE	A2,D1-D2		; 
	CMP	D1,#1			; valid object number?
	BLO	5$			;   no - replace w/1
	CMP	D1,#9.			; valid object number?
	BLOS	6$			;   yes
5$:	MOV	#1,D1			; use 1
6$:	CALL	ENDSTR			; finish up if in a text sequence
	CMPB	D2,#MAXGRF		; valid special code ?
	BHIS	20$			;   no, ignore it			[108]
	CMP	D2,#7			; end gray?
	BHIS	10$			;   yes
	LEA	A2,PTDDB(A3)		; index output DDB for DCVT
	DCVT	0,OT$DDB!OT$TSP		; 
10$:	CMPB	D2,#7			; end gray box?
	JEQ	END.GRAY.BOX		;   yes
	CALL	ENDSTR			; end anything we're in the middle of
	ADDW	D2,D2			; make index into word offset
	MOVW	GRFTBL[~D2],D2		; get string offset
	OUTSTR	GRFTBL[~D2]		; go output it
20$:	REST	A2,D1-D2		; 
	RTN

;Graphics control string table
;CAUTION: Do Not Change the order of the string table.
;         If the string is not implemented put a length of zero at the label.

DEFINE STRING ADDR=WORD ADDR-GRFTBL

GRFTBL:	STRING	BEGLIN			; 00 begin line
	STRING	ENDLIN			; 01 end line
	STRING	BEGBOX			; 02 begin box
	STRING	ENDBOX			; 03 end box
	STRING	BEGRND			; 04 begin rounded box
	STRING	ENDRND			; 05 end rounded box
	STRING	BEGGRY			; 06 begin gray box
	STRING	ENDGRY			; 07 end gray box
	MAXGRF	=<.-GRFTBL>/2		; maximum special code allowed

BEGLIN:	ASCIZ	".blin "
ENDLIN:	ASCIZ	".elin "
BEGBOX:	ASCIZ	".bbox "
ENDBOX:	ASCIZ	".ebox "
BEGRND:	ASCIZ	".bround "
ENDRND:	ASCIZ	".eround "
BEGGRY:	ASCIZ	".bgray /.igray {"
ENDGRY:	ASCIZ	"} .egray .igray "
	EVEN

END.GRAY.BOX:
	PUSH	D1			; 
	CALL	ENDSTR			; 
	OUTSTR	100$			; 

	SAVE	D1-D2			; 
	CLR	D1			; 
	MOVW	HRZLOC(A3),D1		; 
	CLR	D2			; 
	MOVW	VRTLOC(A3),D2		; 
	CALL	PDMOVE			; 
	REST	D1-D2			; 

	POP	D1			; 
	LEA	A2,PTDDB(A3)		; 
	DCVT	0,OT$DDB!OT$TSP		; 
	OUTSTR	200$			; 

	REST	A2,D1-D2		; 
	RTN				; 

100$:	ASCIZ	"} def "
200$:	ASCIZ	".egray .bxc1 .bxr1 /.cb exch def .cb moveto .igray "
	EVEN				; 

;************
;*  PDFSUB  *
;************
;Perform font substitution (font code in D1) is not directly supported by
;the printer.  D1 is returned as the nearest font to the one requested.
;The Z-bit is set if font substitution actually takes place.

PDFSUB:	CMPB	D1,#'A			; 
	BLO	30$			; 
	CMPB	D1,#'Z			; 
	BHI	30$			; 
	LEA	A6,FONT.XLATE		; index font substitution table
10$:	MOVB	(A6)+,D6		; get first byte
	BEQ	20$			;   end of table
	MOVB	(A6)+,D7		; get second byte
	CMPB	D6,D1			; do we have a match?
	BNE	10$			;   no - go try next table entry
	MOVB	D7,D1			;   yes - replace font code
	LCC	#PS.Z			; set Z
	RTN				; return
20$:	LCC	#0			; clear Z
	RTN				; return
30$:	MOVB	#'C,D1			; 
	LCC	#PS.Z			; 
	RTN				; 

;************
;*  PDTRSC  *
;************
;Translate special character
;
;D1 contains the character to be translated
;D1 is returned as the character code to use for width calculations
;
;If a temporary font change to SYMBOL is required, return 1 in PDVARG(A3)

PDTRSC:	CLR	PDVARG(A3)		; 
	LEA	A6,100$			; index special character table
10$:	MOVW	(A6)+,D6		; get special character
	BEQ	30$			;   end of table
	CMPW	D6,D1			; match?
	BEQ	20$			;   yes
	TST	(A6)+			; move to next entry
	BR	10$			; loop
20$:	CLR	D1			; translate
	MOVW	(A6)+,D1		;   character
	MOVW	(A6)+,D7		; get flags word
	BEQ	30$			;   normal character replacement
	MOV	#1,PDVARG(A3)		; 
30$:	RTN				; return (translated char in D1)

;table of special character translations
;
;each entry consists of:
;
;	(1) original character code,
;	(2) replacement character code,
;	(3) flags word (0=standard replacement, 1=symbol mode replacement)

100$:	WORD	C$NXB,040,0		; required space	-> space
	WORD	C$DEG,260,0		; degree symbol		-> ring
	WORD	C$PAR,266,0		; paragraph symbol	-> paragraph
	WORD	C$DAG,230,0		; dagger		-> dagger
	WORD	C$SEC,247,0		; section symbol	-> section
	WORD	C$CNT,242,0		; cent sign		-> cent

	IF	EQ,SPECHR-0
	WORD	C$TM, 324,1		; trademark symbol	-> SYMBOL
	WORD	C$CPY,323,1		; copyright symbol	-> SYMBOL
	WORD	C$REG,322,1		; registered symbol	-> SYMBOL
	IFF
	WORD	C$TM,150.,0		; trademark symbol	-> SYMBOL
	WORD	C$CPY,251,0		; copyright symbol	-> SYMBOL
	WORD	C$REG,256,0		; registered symbol	-> SYMBOL
	ENDC

	IF EQ,BULLET-1,WORD C$BLT,267,0	; bullet (from character set)
	IF EQ,BULLET-2,WORD C$BLT,'n,1	; bullet (Symbol filled-in square)
	WORD	C$EMD,'M,0		; em dash (M is width by definition)
	WORD	C$END,'N,0		; en dash (N is width by definition)

	WORD	C$QTR,65.,0		; 1/4 assume same width as "A"
	WORD	C$HAF,65.,0		; 1/2 assume same width as "A"

	WORD	C$STR,'W,0		; star    assume same width as W
	WORD	C$BLT,'H,0		; bullet  assume same width as H
	WORD	C$EMD,'M,0		; em dash assume same width as W
	WORD	C$END,'N,0		; en dash assume same width as N

	WORD	0			; ** end of table **

$1000:	WORD	42572,0,0		; 1000.00 in AM floating point

;************
;*  PDTREC  *
;************
;Translate extended character
;
;D1 contains the character to be translated (word)
;D1 is returned as the character code to use for width calculations (word)

PDTREC:	LEA	A6,100$			; index table
10$:	MOVW	(A6)+,D6		; get extended character
	BEQ	30$			;   end of table
	CMPW	D6,D1			; match?
	BEQ	20$			;   yes
	TSTW	(A6)+			; move to next entry
	BR	10$			; loop
20$:	CLR	D1			; translate
	MOVW	(A6)+,D1		;   character
30$:	RTN				; return (translated char in D1)

;table of extended character translations

100$:	WORD	0			; ** end of table **

;************
;*  PDOTSC  *
;************
;Output special character
;D1 contains the character to output

PDOTSC:	CALL	ENDSTR			; 
	CALL	PDCFNT			; set correct font if necessary

	CMPB	D1,#324			; 
	BLO	5$			; 
	CMPB	D1,#324			; 
	BHI	5$			; 

	CMPW	CURFNT(A3),#'D-'A	; in dingbats?
	JEQ	PDCH2			;   yes - output as standard char

5$:	CMPB	D1,#C$STR		; is it a star?
	JEQ	SC.STR			;   yes - special handling
	CMPB	D1,#C$RTN		; is it a RETURN symbol?
	JEQ	SC.RTN			;   yes - special handling

IF	EQ,BULLET
	CMPB	D1,#C$BLT		; bullet?
	JEQ	SC.BLT			;   yes - special handling
ENDC

	CMPB	D1,#C$QTR		; is it one quarter?
	JEQ	SC.QTR			;   yes - special handling
	CMPB	D1,#C$HAF		; is it one half?
	JEQ	SC.HAF			;   yes - special handling

	CALL	TRANSC			; translate to PostScript character set

	CMPB	D1,#'n			; do we need to switch to DINGBATS?
	JEQ	20$			;   yes

	CMPB	D1,#40			; required space?
	JEQ	REQSPC			;   yes

	CMPB	D1,#322			; do we need to switch to SYMBOL set?
	JLO	PDCH2			;   no - output as standard char
	CMPB	D1,#324			; do we need to switch to SYMBOL set?
	JHI	PDCH2			;   no - output as standard char

;switch to symbol set, print the character, and switch back to current font

10$:	SAVE	A2,D1-D2		; save registers
	PUSHW	CURFNT(A3)		; save current font
	PUSH	D1			; save character
	MOV	#'S,D1			; set font
	CALL	PDFONT			;   to symbol
	POP	D1			; restore character
	CALL	PDCH2			; print character (in symbol font)
	CLR	D1			; restore
	POPW	D1			;   the
	ADDB	#'A,D1			;   previous
	CALL	PDFONT			;   font
	REST	A2,D1-D2		; restore registers
	RTN				; return

;switch to dingbats set, print the character, and switch back to current font

20$:	SAVE	A2,D1-D2		; save registers
	PUSHW	CURFNT(A3)		; save current font
	PUSH	D1			; save character
	MOV	#'D,D1			; set font
	CALL	PDFONT			;   to symbol
	POP	D1			; restore character
	CALL	PDCH2			; print character (in symbol font)
	CLR	D1			; restore
	POPW	D1			;   the
	ADDB	#'A,D1			;   previous
	CALL	PDFONT			;   font
	REST	A2,D1-D2		; restore registers
	RTN				; return

SC.STR:	CALL	ENDSTR			; 
	LEA	A6,100$			; 
	JMP	STROUT			; 

100$:	ASCIL	<star>			; call AMLAS.PS star routine
	BYTE	0			; 
	EVEN				; 

SC.RTN:	CALL	ENDSTR			; 
	LEA	A6,100$			; 
	JMP	STROUT			; 

100$:	ASCIL	<(RETURN) keycap>	; call AMLAS.PS keycap routine
	BYTE	0			; 
	EVEN				; 

IF	EQ,BULLET

SC.BLT:	CALL	ENDSTR			; 
	LEA	A6,100$			; 
	JMP	STROUT			; 

100$:	ASCIL	< bullet >		; call AMLAS.PS keycap routine
	BYTE	0			; 
	EVEN				; 

ENDC

SC.QTR:	CALL	ENDSTR			; 
	LEA	A6,100$			; 
	CMPW	CURFNT(A3),#2		; in Courier?
	BNE	10$			;   no
	LEA	A6,200$			; 
10$:	JMP	STROUT			; 

100$:	ASCIL	<(1) (4) .fs >		; 
	BYTE	0			; 
200$:	ASCIL	<(1/4) show >		; 
	BYTE	0			; 
	EVEN				; 

SC.HAF:	CALL	ENDSTR			; 
	LEA	A6,100$			; 
	CMPW	CURFNT(A3),#2		; in Courier?
	BNE	10$			;   no
	LEA	A6,200$			; 
10$:	JMP	STROUT			; 

100$:	ASCIL	<(1) (2) .fs >		; 
	BYTE	0			; 
200$:	ASCIL	<(1/2) show >		; 
	BYTE	0			; 
	EVEN				; 

SC.34:	CALL	ENDSTR			; 
	LEA	A6,100$			; 
	CMPW	CURFNT(A3),#2		; in Courier?
	BNE	10$			;   no
	LEA	A6,200$			; 
10$:	JMP	STROUT			; 

100$:	ASCIL	<(3) (4) .fs >		; 
	BYTE	0			; 
200$:	ASCIL	<(3/4) show >		; 
	BYTE	0			; 
	EVEN				; 

REQSPC:	CALL	ENDSTR			; 
	OUTSTR	100$			; 
	RTN				; 

100$:	ASCIZ	"( ) show "		; 
	EVEN				; 

;************
;*  PDOTEC  *
;************
;Output extended character
;D1 contains the character to output

PDOTEC:	CMPB	D1,#40			; printable character?
	JHIS	PDCH2			;   yes
	RTN				;   no - return

;************
;*  PDSETL  *
;************
;Set line weight to points in WRDSPC(A3)

PDSETL:	SAVE	A2,D1-D2		; 
	CALL	ENDSTR			; 
	LEA	A2,NUMBUF(A3)		; 
	FCVT	WRDSPC(A3),0,OT$MEM!OT$FIX!OT$NSP,4,0	; 
	CLRB	@A2			; 
	CALL	AMENUM			; Americanize number
	CALL	OUTNUM			; output number
	OUTSTR	100$			; 
	REST	A2,D1-D2		; 
	RTN				; 

100$:	ASCIL	< setlinewidth>		; 
	BYTE	0			; 
	EVEN				; 

;************
;*  PDPOVR  *
;************
;Print page overlay
;
;D2 indexes text to print

PDPOVR:	SAVE	A0,A2,D0-D2		; 
	MOV	D2,A0			; 
	CALL	ENDSTR			; 

;check for 8-bit characters

	BIT	#PF$NAT,FLAGS(A3),2	; using natural character set?	[147]
	BNE	8$			;   yes				[147]

	BIT	#PF$CH8,FLAGS(A3),2	; 8-bit characters already detected?
	BEQ	8$			;   yes
	MOV	A0,A6			; 
1$:	MOVB	(A6)+,D7		; 
	BEQ	9$			; 
	CMPB	D7,#160.		; 
	BLO	1$			; 
	OR	#PF$CH8!PF$FNT,FLAGS(A3) ; 

8$:	OUTSTR	80$			; 
	BR	91$			; 

;no 8-bit characters

9$:	OUTSTR	100$			; 

91$:	OUTSTR	120$			; 
	LEA	A2,PTDDB(A3)		; 
	MOVB	#'(,D1			; 
	PUTBYT				; 
10$:	MOVB	(A0)+,D1		; 
	BEQ	20$			; 
	CMPB	D1,#40			; 
	BLO	10$			; 
	CMPB	D1,#160.		; 				[147]
	BHIS	15$			; 				[147]
	CMPB	D1,#'~			; 
	BHI	10$			; 
	PUTBYT				; 
	BR	10$			; 

;output 8-bit character as \nnn sequence

15$:	PUSH	A2			; 				[147]
	PUSHW	D1			; 				[147]
	MOVB	#'\,D1			; 				[147]
	PUTBYT				; 				[147]
	POPW	D1			; 				[147]
	LEA	A2,PTDDB(A3)		; 				[147]
	AND	#377,D1			; 				[147]
	OCVT	3,OT$DDB		; 				[147]
	POP	A2			; 				[147]
	BR	10$			; 				[147]

20$:	MOVB	#'),D1			; 
	PUTBYT				; 
	OUTSTR	200$			; 
	REST	A0,A2,D0-D2		; 
	RTN

80$:	ASCIL				; 
	ASCIL	<gsave stdencoding /PO /Helvetica-Bold .RE /PO findfont [90 0 0 120 0 0] makefont setfont>
	BYTE	0			; 

100$:	ASCIL
	ASCIL	<gsave (Helvetica-Bold) findfont [90 0 0 120 0 0] makefont setfont>
	BYTE	0

120$:	ASCIL	<newpath 140 90 moveto   0 0 moveto    53 rotate .95 setgray>
	BYTE	0

200$:	ASCIL	< dup 990 exch stringwidth pop sub 2 div cvi -45 rmoveto show grestore>
	BYTE	0
	EVEN

;************
;*  PDIMON  *
;************
;Begin image - D2 contains height in points

PDIMON:	MOV	D2,IMGSIZ(A3)		; save image height
	CALL	ENDSTR			; 
	CALL	SET.FONT		; select font
	AND	#^C<PF$FNT>,FLAGS(A3)	;   and clear font-select flag
	OUTSTR	100$			; 
	RTN				; 

100$:	ASCIL				; 
	ASCIL				; 
	ASCIL	<%% image>		; 
	ASCIL				; 
	ASCIL	<cp mark .beginEPSF>	; 
	BYTE	0			; 
	EVEN

;************
;*  PDIMOF  *
;************
;End image

PDIMOF:	SAVE	A0-A2,D1		; 
	CALL	ENDSTR			; 
	MOV	IMGSIZ(A3),D1		; get image height
	LEA	A0,FLTBUF(A3)		; 
	FLTOF	D1,@A0			; 
	LEA	A1,$72			; 
	FDIV	A1,A0			; 
	OUTSTR	80$			; 
	LEA	A2,NUMBUF(A3)		; 
	FCVT	@A0,0,OT$MEM,0,0	; 
	CLRB	@A2			; 
	CALL	AMENUM			; 
	CALL	OUTNUM			; 
	OUTSTR	90$			; 
	LEA	A2,NUMBUF(A3)		; 
	FCVT	@A0,0,OT$MEM,0,0	; 
	CLRB	@A2			; 
	CALL	AMENUM			; 
	CALL	OUTNUM			; 
	OUTSTR	100$			; 

	CALL	SET.FONT		; select font
	AND	#^C<PF$FNT>,FLAGS(A3)	;   and clear font-select flag

	REST	A0-A2,D1		; 
	RTN				; 

80$:	ASCIZ	" cp "

90$:	ASCIZ	" -72 mul .ps add .ps .2 mul sub 0 exch rmoveto "

100$:	ASCIL	< doimage >		; 
	ASCIL	<.endEPSF cleartomark moveto>
	ASCIL				; 
	ASCIL	<%% end of image>	; 
	ASCIL				; 
	BYTE	0			; 
	EVEN

;***********
;*  PDKEY  *
;***********
;Toggle keycap

PDKEY:	CALL	ENDSTR			; 
	XOR	#PF$KEY,FLAGS(A3)	; flip keycap flag
	BIT	#PF$KEY,FLAGS(A3),1	; did we turn it on or off?
	BEQ	PDKOFF			;   off

PDKON:	OUTSTR	KEYON			; 
	RTN				; 

PDKOFF:	OUTSTR	KEYOFF			; 
	RTN				; 

KEYON:	ASCIZ	".bkeycap "
KEYOFF:	ASCIZ	".ekeycap "
	EVEN

;************
;*  PDKERN  *
;************
;Set kerning (degree of tightness) as per D2
;
;	0	- no kerning		T    H    I    S
;	2	- light kerning		T   H   I   S
;	4	- medium kerning	T  H  I  S
;	6	- heavy kerning		T H I S

PDKERN:	MOVW	D2,KERNING(A3)		; 
	RTN				; 

;************
;*  STROUT  *
;************
; Output string indexed by A6 to DDB indexed by A3

STROUT:	SAVE	A0,D1			; 
	MOV	A6,A0			; 
10$:	MOVB	(A0)+,D1		; get byte from string
	BEQ	20$			; 
	PUTBYT				; output it
	BR	10$			; 
20$:	REST	A0,D1			; restore registers
	AND	#^C<PF$SL>,FLAGS(A3)	; clear "sl" flag
	RTN				; 

;**************
;*  PUT.BYTE  *
;**************
;Function:	Write byte to PTDDB(A3)
;
;Inputs:	D1 - byte to output
;
;Outputs:	none

PUT.BYTE:
	SAVE	A3,A6			; 
	LEA	A3,PTDDB(A3)		; 
170$:	MOV	D.IDX(A3),A6		;  any room left in buffer?		[167][201]
	CMP	A6,D.SIZ(A3)		;					[167]
	BLO	180$			;    yes -				[167][201]
175$:  	OUTPUT	@A3			; output it				[167][199][201]
180$:	MOV	D.BUF(A3),A6		; calculate buffer position		[167][201]
	ADD	D.IDX(A3),A6		;					[167]
	MOVB	D1,@A6			; store character into buffer		[167]
	INC	D.IDX(A3)		; increment the index			[167]
	REST	A3,A6			; 
	RTN

PAGE
;*********************
;* Carriage Movement *
;*********************

; Move to Absolute Horizontal Tab
;
MOVAHT:	BYTE	0

; Return carriage home
;
CHOME:	BYTE	1.			; string length
	BYTE	$CR

PAGE
;******************
;* Paper Movement *
;******************

;Roll up a partial line (positive)

ROLUP:	ASCIL	<.ru >
	BYTE	0			; 

;Roll down a partial line (negative)

ROLDWN:	ASCIL	<.rd >
	BYTE	0			; 

;Output a negative line feed

NEGLF:	BYTE	0			; 

PAGE
;**************************
;* Miscellaneous Commands *
;**************************

;Print in Secondary ribbon color 1

RIBSC1:	ASCIL	<.3 setgray>		; 
	BYTE	0			; 

;Print in Secondary ribbon color 2

RIBSC2:	ASCIL	<.4 setgray>		; 
	BYTE	0			; 

;Print in Secondary ribbon color 3

RIBSC3:	ASCIL	<.5 setgray>		; 
	BYTE	0			; 

;Print in Secondary ribbon color 4

RIBSC4:	ASCIL	<.6 setgray>		; 
	BYTE	0			; 

;Print in Secondary ribbon color 5

RIBSC5:	ASCIL	<.7 setgray>		; 
	BYTE	0			; 

;Print in Secondary ribbon color 6

RIBSC6:	ASCIL	<.8 setgray>		; 
	BYTE	0			; 

;Print in Secondary ribbon color 7

RIBSC7:	ASCIL	<.9 setgray>		; 
	BYTE	0			; 

;Print in Primary ribbon color (black)

RIBPRM:	ASCIL	<0 setgray>		; 
	BYTE	0			; 

;Output character at special print position 0

SPLPT0:	BYTE	0			; 

;Output character at special print position 1

SPLPT1:	BYTE	0			; 

PAGE
;************************
;* Cut Sheet Feeder	*
;************************

	IF	EQ,PRTTYP-LASWRT

;*******************************
;*  LASWRT.PDV tray selection  *
;*******************************

;Select feeder tray 1 (default tray)

FEDTR1:	ASCIL	<statusdict begin 1 setpapertray end>
	BYTE	0

;Select feeder tray 2 (second tray)

FEDTR2:	ASCIL	<statusdict begin 2 setpapertray end>
	BYTE	0

;Select feeder tray 3 (third tray or envelope feeder)

FEDTR3:	ASCIL	<statusdict begin 3 setpapertray end>
	BYTE	0

;Select feeder tray 4 (fourth tray or manual feed)

FEDTR4:	ASCIL	<statusdict begin 4 setpapertray end>
	BYTE	0

	IFF

;**********************************
;*  tray commands for PSCART.PDV  *
;**********************************

;Select feeder tray 1 (default tray)

FEDTR1:	ASCII	"statusdict begin "
	IF EQ,BIN1-LETTER,ASCII "lettertray "
	IF EQ,BIN1-LEGAL,ASCII "legaltray "
	IF EQ,BIN1-COM10,ASCII "com10envelopetray "
	IF EQ,BIN1-MONARCH,ASCII "monarcenvelopetray "
	IF EQ,BIN1-A4,ASCII "a4tray "
	IF EQ,BIN1-C5ENV,ASCII "c5envelopetray "
	IF EQ,BIN1-D1ENV,ASCII "d1envelopetray "
	ASCIL	<0 setpapertray end>
	BYTE	0

;Select feeder tray 2 (second tray)

FEDTR2:	ASCII	"statusdict begin "
	IF EQ,BIN2-LETTER,ASCII "lettertray "
	IF EQ,BIN2-LEGAL,ASCII "legaltray "
	IF EQ,BIN2-COM10,ASCII "com10envelopetray "
	IF EQ,BIN2-MONARCH,ASCII "monarcenvelopetray "
	IF EQ,BIN2-A4,ASCII "a4tray "
	IF EQ,BIN2-C5ENV,ASCII "c5envelopetray "
	IF EQ,BIN2-D1ENV,ASCII "d1envelopetray "
	ASCIL	<1 setpapertray end>
	BYTE	0

;Select feeder tray 3 (envelope feeder or third tray)

FEDTR3:	ASCII	"statusdict begin "
	IF EQ,BIN3-LETTER,ASCII "lettertray "
	IF EQ,BIN3-LEGAL,ASCII "legaltray "
	IF EQ,BIN3-COM10,ASCII "com10envelopetray "
	IF EQ,BIN3-MONARCH,ASCII "monarcenvelopetray "
	IF EQ,BIN3-A4,ASCII "a4tray "
	IF EQ,BIN3-C5ENV,ASCII "c5envelopetray "
	IF EQ,BIN3-D1ENV,ASCII "d1envelopetray "
	ASCIL	<2 setpapertray end>
	BYTE	0

;Select feeder tray 4 (manual feed)

FEDTR4:	ASCII	"statusdict begin "
	IF EQ,BIN4-LETTER,ASCII "lettertray "
	IF EQ,BIN4-LEGAL,ASCII "legaltray "
	IF EQ,BIN4-COM10,ASCII "com10envelopetray "
	IF EQ,BIN4-MONARCH,ASCII "monarcenvelopetray "
	IF EQ,BIN4-A4,ASCII "a4tray "
	IF EQ,BIN4-C5ENV,ASCII "c5envelopetray "
	IF EQ,BIN4-D1ENV,ASCII "d1envelopetray "
	ASCIL	<end setmanual>
	BYTE	0

	ENDC

;Select feeder tray 1 & then tray 2 thereafter

FEDTGL:	BYTE	0

;Select feeder eject

FEDEJT:	ASCIZ	"showpage "		; 

PAGE
;**************************
;* Special User Functions *
;**************************

; Output user function 1 
;
USR1:	BYTE	0.			; string length

; Output user function 2 
;
USR2:	BYTE	0.			; string length

; Output user function 3 
;
USR3:	BYTE	0.			; string length

; Output user function 4 
;
USR4:	BYTE	0.			; string length

;Printer initialization text

PRTINI:	ASCIL	<%! PostScript file created by LASWRT.PDV version 2.1(148)>
	ASCIL
	ASCIL	<%% -------- prologue -------->
	ASCIL
	ASCIL	<statusdict begin 0 setjobtimeout end /.ps 10 def /.ld 12 def>
	ASCIL	</cp {currentpoint} bind def>
	ASCIL	</.plp {/.cb .cb .ld .3 mul sub def cp pop .cb moveto} def>
	ASCIL	</.pln {/.cb .cb .ld .3 mul add def cp pop .cb moveto} def>
	ASCIL	</.s {exch show 120 div 72 mul .lpo add .cb moveto} def>
	ASCIL	</.ip {dup inch 10 sub .cb exch sub cp pop exch moveto} def>
	ASCIL	</.font {findfont [.ps 0 0 .ps 0 0] makefont setfont} def>
	ASCIL	</.bs {cp /oy exch def /ox exch def stringwidth pop ox exch sub oy moveto} def>
	ASCIL	</.rp {ox oy moveto} def /.fd 5 dict def /.fs {.fd begin /.den exch def /.num exch def>
	ASCIL	</.regf currentfont def /.frcf currentfont [.65 0 0 .6 0 0] makefont def>
	ASCIL	< gsave newpath 0 0 moveto (1) true charpath flattenpath pathbbox>
	ASCIL	</height exch def pop pop pop grestore>
	ASCIL	< 0 .4 height mul rmoveto .frcf setfont .num show 0 .4 height mul neg rmoveto>
	ASCIL	< .regf setfont (\227) show .frcf setfont .den show .regf setfont end} def>

;new page

	ASCIL	</newpage {.np 8.5 11 pagesize /.cb pheight def .cg} bind def>

;[CUS]...
;define UPC bar code font

	ASCIL	<%!>
	ASCIL	
	ASCIL	<%*************************** AMUS Program Label ******************************>
	ASCIL	<% Filename: UPC.PS                                          Date: 10/14/90>
	ASCIL	<% Category: PS           Hash Code:                      Version:                >
	ASCIL	<% Initials: MCMA/AM      Name: RHETT MCMAHON>
	ASCIL	<% Company: INTERSTATE COMMUNICATIONS, INC.         Telephone #: 5043838695>
	ASCIL	<% Related Files: NONE>
	ASCIL	<% Min. Op. Sys.:                               Expertise Level: BEG>
	ASCIL	<% Special: >
	ASCIL	<% Description: Universal Product Code Font (including sample output).>
	ASCIL	<% >
	ASCIL	<% >
	ASCIL	<%*****************************************************************************>
	ASCIL	
	ASCIL	<%%  PostScript Demo program >
	ASCIL	<%%  uploaded to AMUS BB 17 Sep 1990 by MCMA/AM (Rhett McMahon) for>
	ASCIL	<%%  Universal Product Code font>
	ASCIL	<%%  Copyright (C) 1986 by Pipeline Associates, Inc.>
	ASCIL	<%%  Permission is granted to use and distribute as long as this copyright>
	ASCIL	<%%  notice remains intact and it is distributed free of charge.>
	ASCIL	<%%>
	ASCIL	</UPCFontDict 8 dict def>
	ASCIL	</workdict 25 dict def>
	ASCIL	<%% load up drawing procedures>
	ASCIL	<workdict begin>
	ASCIL	<	/gray 0 def>
	ASCIL	<	/d1 {>
	ASCIL	<		1.3 setlinewidth>
	ASCIL	<		1 0 moveto 1 100 lineto stroke>
	ASCIL	<		2 0 translate>
	ASCIL	<	} bind def>
	ASCIL	<	/d2 {>
	ASCIL	<		3.3 setlinewidth>
	ASCIL	<		2 0 moveto 2 100 lineto stroke>
	ASCIL	<		4 0 translate>
	ASCIL	<	} bind def>
	ASCIL	<	/d3 {>
	ASCIL	<		5.3 setlinewidth>
	ASCIL	<		3 0 moveto 3 100 lineto stroke>
	ASCIL	<		6 0 translate>
	ASCIL	<	} bind def>
	ASCIL	<	/d4>
	ASCIL	<{>
	ASCIL	<		7.3 setlinewidth>
	ASCIL	<		4 0 moveto 4 100 lineto stroke>
	ASCIL	<		8 0 translate>
	ASCIL	<	} bind>
	ASCIL	<def>
	ASCIL	<	/cline1 {>
	ASCIL	<		1 gray sub setgray>
	ASCIL	<		d1>
	ASCIL	<	} bind def>
	ASCIL	<	/cline2 {>
	ASCIL	<		1 gray sub setgray>
	ASCIL	<		d2>
	ASCIL	<	} bind def>
	ASCIL	<	/cline3 {>
	ASCIL	<		1 gray sub setgray>
	ASCIL	<		d3>
	ASCIL	<	} bind>
	ASCIL	<def>
	ASCIL	<	/cline4 {>
	ASCIL	<		1 gray sub setgray>
	ASCIL	<		d4>
	ASCIL	<	} bind def>
	ASCIL	<	/line1 {>
	ASCIL	<		gray>
	ASCIL	<setgray>
	ASCIL	<		d1>
	ASCIL	<	} bind def>
	ASCIL	<	/line2 {>
	ASCIL	<		gray setgray>
	ASCIL	<		d2>
	ASCIL	<	} bind def>
	ASCIL	<	/line3>
	ASCIL	<{>
	ASCIL	<		gray setgray>
	ASCIL	<		d3>
	ASCIL	<	} bind def>
	ASCIL	<	/line4 {>
	ASCIL	<		gray setgray>
	ASCIL	<		d4>
	ASCIL	<	} bind def>
	ASCIL	<end>
	ASCIL
	ASCIL	</switch {>
	ASCIL	<	workdict begin /gray 1 gray sub def end>
	ASCIL	<	} def>
	ASCIL
	ASCIL	<UPCFontDict begin>
	ASCIL	</FontType 3 def>
	ASCIL	</FontMatrix [.01 0 0 .015 0 0] def>
	ASCIL	</FontBBox [0 0 10 100] def>
	ASCIL	</Encoding 128 array def>
	ASCIL	</Widths 128 array def>
	ASCIL
	ASCIL	<%% fill the Encoding array with the procs to run for each character>
	ASCIL	<0 1 127 {Encoding exch /.notdef put} for>
	ASCIL	<Encoding (0) 0 get /zero put>
	ASCIL	<Encoding (1) 0 get /one put>
	ASCIL	<Encoding (2) 0 get /two put>
	ASCIL	<Encoding (3) 0 get /three put>
	ASCIL	<Encoding (4) 0 get /four put>
	ASCIL	<Encoding (5) 0 get /five put>
	ASCIL	<Encoding (6) 0 get /six put>
	ASCIL	<Encoding (7) 0 get /seven put>
	ASCIL	<Encoding (8) 0 get /eight put>
	ASCIL	<Encoding (9) 0 get /nine put>
	ASCIL	<Encoding ( ) 0 get /space put>
	ASCIL2	<Encoding (|) 0 get /bar put>
	ASCIL
	ASCIL	<Widths (0) 0 get 14 put>
	ASCIL	<Widths (1) 0 get 14 put>
	ASCIL	<Widths (2) 0 get 14 put>
	ASCIL	<Widths (3) 0 get 14 put>
	ASCIL	<Widths (4) 0 get 14 put>
	ASCIL	<Widths (5) 0 get 14 put>
	ASCIL	<Widths (6) 0 get 14 put>
	ASCIL	<Widths (7) 0 get 14 put>
	ASCIL	<Widths (8) 0 get 14 put>
	ASCIL	<Widths (9) 0 get 14 put>
	ASCIL	<Widths ( ) 0 get 2 put>
	ASCIL2	<Widths (|) 0 get 2 put>
	ASCIL
	ASCIL	<%% define the procs>
	ASCIL	</CharProcs 20 dict def>
	ASCIL	<CharProcs /.notdef {} put>
	ASCIL	<CharProcs /zero {>
	ASCIL
	ASCIL	<	cline3 line2 cline1 line1>
	ASCIL	<} put>
	ASCIL	<CharProcs /one {>
	ASCIL	<	cline2 line2 cline2 line1>
	ASCIL	<} put>
	ASCIL	<CharProcs /two {>
	ASCIL	<	cline2 line1 cline2 line2>
	ASCIL	<} put>
	ASCIL	<CharProcs /three {>
	ASCIL	<	cline1 line4 cline1 line1>
	ASCIL	<} put>
	ASCIL	<CharProcs /four {>
	ASCIL	<	cline1 line1 cline3 line2>
	ASCIL	<} put>
	ASCIL	<CharProcs /five {>
	ASCIL	<	cline1 line2 cline3 line1>
	ASCIL	<} put>
	ASCIL	<CharProcs /six {>
	ASCIL	<	cline1 line1 cline1 line4>
	ASCIL	<} put>
	ASCIL	<CharProcs /seven {>
	ASCIL	<	cline1 line3 cline1 line2>
	ASCIL	<} put>
	ASCIL	<CharProcs /eight {>
	ASCIL	<	cline1 line2 cline1 line3>
	ASCIL	<} put>
	ASCIL	<CharProcs /nine {>
	ASCIL	<	cline3 line1 cline1 line2>
	ASCIL	<} put>
	ASCIL	<CharProcs /space {>
	ASCIL	<} put>
	ASCIL	<CharProcs /bar {>
	ASCIL	<	line1>
	ASCIL	<} put>
	ASCIL	<%% BuildChar is called by PS whenever a character is to be imaged out>
	ASCIL	<%% of UPC>
	ASCIL	</BuildChar {>
	ASCIL
	ASCIL	< workdict begin>
	ASCIL	<  /char exch def>
	ASCIL	<  /fontdict exch def>
	ASCIL	<  /charname fontdict /Encoding get char get def>
	ASCIL	<  /charproc fontdict /CharProcs get charname get def>
	ASCIL	<  /charwidth fontdict /Widths get char get def>
	ASCIL	<  charwidth 0 setcharwidth>
	ASCIL	<  gsave>
	ASCIL	<	charproc>
	ASCIL	<  grestore>
	ASCIL	< end>
	ASCIL	<} bind def>
	ASCIL	<end>
	ASCIL	<%% register font in postscript font mach>
	ASCIL	</inch {72 mul} def>
	ASCIL	</UPC UPCFontDict definefont pop>

;...[CUS]

;set left margin

	ASCIL	</lm {/.lpo exch def} bind def /ns {nl sl} def>

;underscoring

	ASCIL	</.sus {cp /uy exch def /ux exch def} bind def>
	ASCIL	</.us {gsave .5 setlinewidth 0 -1 rmoveto ux uy 1 sub lineto stroke grestore} bind def>
	ASCIL	</.dus {cp exch pop uy eq {gsave .5 setlinewidth 0 -1 rmoveto cp ux uy 1 sub lineto stroke>
	ASCIL	< 1.5 sub moveto ux uy 2.5 sub lineto stroke grestore} if} bind def>

;overbar

	ASCIL	</.sbar {cp /by exch def /bx exch def} bind def>
	ASCIL	</.bar {cp exch pop by eq {gsave .5 setlinewidth 0 .ld .70 mul rmoveto>
	ASCIL	< cp pop bx sub neg 0 rlineto stroke grestore} if} bind def>

;screened

	ASCIL	</.sscr {cp /scy exch def /scx exch def} bind def>
	ASCIL	</.scr {gsave .97 setgray cp .ld 2.8 sub add exch 2 add exch>
	ASCIL	< 2 -2.8 rmoveto scx 2 sub scy 2.8 sub lineto>
	ASCIL	< 0 .ld rlineto lineto closepath fill grestore scx scy moveto} bind def>

;reversed

	ASCIL	</.srev {cp /rcy exch def /rcx exch def} bind def>
	ASCIL	</.rev {.revsav gsave 0 setgray>
	ASCIL	<cp .ld 2.8 sub add exch 2 add exch>
	ASCIL	< 2 -2.8 rmoveto rcx 2 sub rcy 2.8 sub lineto>
	ASCIL	< 0 .ld rlineto lineto closepath fill rcx rcy moveto 1 setgray .revsav grestore} bind def>

;line fill & justification

	ASCIL	</.rs {( ) show} bind def>
	ASCIL	</.j {/.js exch def {exch pop 32 eq {.js 0 rmoveto} if}} bind def /.orient 0 def>

;orientation

	IF	EQ,LANDOR,ASCIL </.land {.orient 0 eq {cp 90 rotate 0 -612 translate 180 sub /.cb .cb 180 sub def moveto /.orient 1 def} if} bind def>
	IF	NE,LANDOR,ASCIL </.land {.orient 0 eq {cp 270 rotate -792 0 translate 180 sub /.cb .cb 180 sub def moveto /.orient 1 def} if} bind def>
	ASCIL	</.port {.orient 1 eq {cp 0 612 translate -90 rotate 180 add moveto /.cb .cb 180 add def /.orient 0 def} if} bind def>

;miscellaneous initialization

	ASCIL	</.blx 1 def /.bly 1 def /by 1 def /bx 1 def>
	ASCIL	</.cg {/.bxc11 1 def /.bxr11 1 def /.bxc12 1 def /.bxr12 1 def /.bxc13 1 def /.bxr13 1 def /.bxc14 1 def>
	ASCIL	</.bxr14 1 def /.bxc15 1 def /.bxr15 1 def /.bxc16 1 def /.bxr16 1 def /.bxc17 1 def /.bxr17 1 def>
	ASCIL	</.bxc18 1 def /.bxr18 1 def /.bxc19 1 def /.bxr19 1 def} bind def>

;set envelope position

	ASCIL	</envelopeposition {/.orient 0 def .land} def>

;overprinting

	ASCIL	</.op {0 rmoveto} bind def>

;default values for graphics objects

	ASCIL	</.bxr1 1 def /.bxc1 1 def /.bxr2 1 def /.bxc2 1 def>
	ASCIL	</.kcr1 1 def /.kcc1 1 def /.kcr2 1 def /.kcc2 1 def>

;begin/end line

	ASCIL	</.blin {.bgraf} def>
	ASCIL	</.elin {.egraf gsave cp .bxc1 .bxr1 moveto lineto stroke grestore} bind def>

;begin/end graphics object description

	ASCIL	</.bgraf {/.gn exch def cp /.bxr1 exch def /.bxc1 exch def>
	ASCIL	<.gn 1 eq {/.bxc11} if .gn 2 eq {/.bxc12} if .gn 3 eq {/.bxc13} if .gn 4 eq {/.bxc14} if>
	ASCIL	<.gn 5 eq {/.bxc15} if .gn 6 eq {/.bxc16} if .gn 7 eq {/.bxc17} if .gn 8 eq {/.bxc18} if>
	ASCIL	<.gn 9 eq {/.bxc19} if .bxc1 def>
	ASCIL	<.gn 1 eq {/.bxr11} if .gn 2 eq {/.bxr12} if .gn 3 eq {/.bxr13} if .gn 4 eq {/.bxr14} if>
	ASCIL	<.gn 5 eq {/.bxr15} if .gn 6 eq {/.bxr16} if .gn 7 eq {/.bxr17} if .gn 8 eq {/.bxr18} if>
	ASCIL	<.gn 9 eq {/.bxr19} if .bxr1 def } bind def>

	ASCIL	</.egraf {/.gn exch def /.bxc1 .gn 1 eq {.bxc11} if .gn 2 eq {.bxc12} if>
	ASCIL	<.gn 3 eq {.bxc13} if .gn 4 eq {.bxc14} if .gn 5 eq {.bxc15} if .gn 6 eq {.bxc16} if>
	ASCIL	<.gn 7 eq {.bxc17} if .gn 8 eq {.bxc18} if .gn 9 eq {.bxc19} if def>
	ASCIL	</.bxr1 .gn 1 eq {.bxr11} if .gn 2 eq {.bxr12} if .gn 3 eq {.bxr13} if .gn 4 eq {.bxr14} if>
	ASCIL	<.gn 5 eq {.bxr15} if .gn 6 eq {.bxr16} if .gn 7 eq {.bxr17} if .gn 8 eq {.bxr18} if>
	ASCIL	<.gn 9 eq {.bxr19} if def} bind def>

;begin/end box

	ASCIL	</.bbox {.bgraf} def /.ebox {.egraf gsave cp cp>
	ASCIL	</.bxr2 exch def /.bxc2 exch def newpath .bxc1 .bxr1 moveto .bxc2 .bxr1 lineto>
	ASCIL	<.bxc2 .bxr2 lineto .bxc1 .bxr2 lineto .bxc1 .bxr1 lineto closepath stroke>
	ASCIL	<moveto grestore } bind def>

;move to character position

	ASCIL	</.mc {.lpo add .cb moveto} bind def /.mv {/.cb exch def .cb moveto} bind def>

;row up/down

	ASCIL	</.ru {/.cb .cb .ps 2 div cvi sub def .cb cp pop exch moveto} bind def>
	ASCIL	</.rd {/.cb .cb .ps 2 div cvi add def .cb cp pop exch moveto} bind def>

;begin/end gray box

	ASCIL	</.bgray {.bgraf} def>
	ASCIL	</.egray {.egraf gsave cp cp /.bxr2 exch def /.bxc2 exch def>
	ASCIL	< .bxc1 .bxr1 moveto .bxc2 .bxr1 lineto .bxc2 .bxr2 lineto .bxc1 .bxr2 lineto .bxc1 .bxr1 lineto>
	ASCIL	< 0.90 setgray fill 0 setgray moveto grestore} bind def>

;start/end rounded box

	ASCIL	</.bround {.bgraf} def>
	ASCIL	</.eround {.egraf gsave cp cp /.bxr2 exch def /.bxc2 exch def>
	ASCIL	<.bxr1 .bxr2 eq {/.bxr1 .bxr1 .ld add def} if>
	ASCIL	<.rr moveto grestore} bind def>

;keycap

	ASCIL	</.bkeycap {.kcr1 .kcc1 .kcr2 .kcc2 cp /.kcr1 exch .ps 2 add add def /.kcc1 exch def 0 2 rmoveto} bind def>
	ASCIL	</.ekeycap {0 -2 rmoveto gsave 0.5 setlinewidth cp cp /.kcr2 exch def /.kcc2 exch def>
	ASCIL	<.krr moveto grestore /.kcc2 exch def /.kcr2 exch def /.kcc1 exch def /.kcr1 exch def} bind def>

;rounded box

	ASCIL	</.ra {arcsize arcto 4 {pop} repeat} bind def /arcsize 10 def>
	ASCIL	</.rr {.bxc1 .bxr2 arcsize add moveto .bxc1 .bxr1 .bxc2 .bxr1 .ra>
	ASCIL	<.bxc2 .bxr1 .bxc2 .bxr2 .ra .bxc2 .bxr2 .bxc1 .bxr2 .ra>
	ASCIL	<.bxc1 .bxr2 .bxc1 .bxr1 .ra stroke } bind def>
	ASCIL	</.ka {.kasize arcto 4 {pop} repeat} bind def /.kasize .ps 8 div cvi def>
	ASCIL	</.krr {.kcc1 .kcr2 .kasize add moveto .kcc1 .kcr1 .kcc2 .kcr1 .ka>
	ASCIL	<.kcc2 .kcr1 .kcc2 .kcr2 .ka .kcc2 .kcr2 .kcc1 .kcr2 .ka .kcc1 .kcr2 .kcc1 .kcr1 .ka stroke } bind def>

;EPSF handling code to disable showpage and erasepage during import

	ASCIL	</.beginEPSF {cp /EPSFsave save def 0 setgray 0 setlinecap 1 setlinewidth 0 setlinejoin>
	ASCIL	<10 setmiterlimit [] 0 setdash newpath /showpage { } def /erasepage { } def moveto} bind def >
	ASCIL	</.endEPSF { EPSFsave restore } bind def>

	ASCIL	</doimage {pop} def>

;ISO Latin I encoding

	ASCIL	</.F {>
	ASCIL	<   findfont exch scalefont setfont>
	ASCIL	<   } bind def>
	ASCIL
	ASCIL	</.RE {>
	ASCIL	<	findfont begin>
	ASCIL	<	currentdict dup length dict begin>
	ASCIL	<	{>
	ASCIL	<		1 index /FID ne {def} {pop pop} ifelse>
	ASCIL	<	} forall>
	ASCIL	<	/FontName exch def dup length 0 ne {>
	ASCIL	<		/Encoding Encoding 256 array copy def>
	ASCIL	<		0 exch {>
	ASCIL	<			dup type /nametype eq {>
	ASCIL	<				Encoding 2 index 2 index put>
	ASCIL	<				pop 1 add>
	ASCIL	<			}{>
	ASCIL	<				exch pop>
	ASCIL	<			} ifelse>
	ASCIL	<		} forall>
	ASCIL	<	} if pop>
	ASCIL	<	currentdict dup end end>
	ASCIL	<	/FontName get exch definefont pop>
	ASCIL	<} bind def>
	ASCIL
	ASCIL	</stdencoding [>

	ASCIL	<145/fraction>
	ASCIL	<146/quotedblleft>
	ASCIL	<147/quotedblright>
	ASCIL	<148/emdash>
	ASCIL	<149/endash>
	ASCIL	<150/trademark>
	ASCIL	<151/fraction>
	ASCIL	<152/dagger>
	ASCIL	<153/dotlessi>
	ASCIL	<154/slash>
	ASCIL	<155/ring>
	ASCIL	<156/acute>
	ASCIL	<157/circumflex>
	ASCIL	<158/grave>
	ASCIL	<159/tilde>
	ASCIL	<160/space		% required space>
	ASCIL	<161/exclamdown>
	ASCIL	<162/cent>
	ASCIL	<163/sterling>
	ASCIL	<164/currency>
	ASCIL	<165/yen>
	ASCIL	<166/bar>
	ASCIL	<167/section>
	ASCIL	<168/dieresis>
	ASCIL	<169/copyright>
	ASCIL	<170/ordfeminine>
	ASCIL	<171/guillemotleft>
	ASCIL	<172/question>
	ASCIL	<173/hyphen>
	ASCIL	<174/registered>
	ASCIL	<175/macron>
	ASCIL	<176/ring>
	ASCIL	<177/question 		% plus/minus>
	ASCIL	<178/question 		% superscript 2>
	ASCIL	<179/question 		% superscript 3>
	ASCIL	<180/quotesingle>
	ASCIL	<181/question 		% micro>
	ASCIL	<182/paragraph>
	ASCIL	<183/bullet		% middle dot>
	ASCIL	<184/cedilla>
	ASCIL	<185/question 		% superscript 1>
	ASCIL	<186/ordmasculine>
	ASCIL	<187/guillemotright>
	ASCIL	<188/question 		% 1/4>
	ASCIL	<189/question 		% 1/2>
	ASCIL	<190/question		% 3/4>
	ASCIL	<191/questiondown>
	ASCIL	<192/Agrave>
	ASCIL	<193/Aacute>
	ASCIL	<194/Acircumflex>
	ASCIL	<195/Atilde>
	ASCIL	<196/Adieresis>
	ASCIL	<197/Aring>
	ASCIL	<198/AE>
	ASCIL	<199/Ccedilla>
	ASCIL	<200/Egrave>
	ASCIL	<201/Eacute>
	ASCIL	<202/Ecircumflex>
	ASCIL	<203/Edieresis>
	ASCIL	<204/Igrave>
	ASCIL	<205/Iacute>
	ASCIL	<206/Icircumflex>
	ASCIL	<207/Idieresis>
	ASCIL	<208/eth>
	ASCIL	<209/Ntilde>
	ASCIL	<210/Ograve>
	ASCIL	<211/Oacute>
	ASCIL	<212/Ocircumflex>
	ASCIL	<213/Otilde>
	ASCIL	<214/Odieresis>
	ASCIL	<215/question 		% multiplication symbol>
	ASCIL	<216/Oslash>
	ASCIL	<217/Ugrave>
	ASCIL	<218/Uacute>
	ASCIL	<219/Ucircumflex>
	ASCIL	<220/Udieresis>
	ASCIL	<221/question 		% Yacute>
	ASCIL	<222/Thorn>
	ASCIL	<223/germandbls>
	ASCIL	<224/agrave>
	ASCIL	<225/aacute>
	ASCIL	<226/acircumflex>
	ASCIL	<227/atilde>
	ASCIL	<228/adieresis>
	ASCIL	<229/aring>
	ASCIL	<230/ae>
	ASCIL	<231/ccedilla>
	ASCIL	<232/egrave>
	ASCIL	<233/eacute>
	ASCIL	<234/ecircumflex>
	ASCIL	<235/edieresis>
	ASCIL	<236/igrave>
	ASCIL	<237/iacute>
	ASCIL	<238/icircumflex>
	ASCIL	<239/idieresis>
	ASCIL	<240/eth>
	ASCIL	<241/ntilde>
	ASCIL	<242/ograve>
	ASCIL	<243/oacute>
	ASCIL	<244/ocircumflex>
	ASCIL	<245/otilde>
	ASCIL	<246/odieresis>
	ASCIL	<247/question		% division symbol>
	ASCIL	<248/oslash>
	ASCIL	<249/ugrave>
	ASCIL	<250/uacute>
	ASCIL	<251/ucircumflex>
	ASCIL	<252/udieresis>
	ASCIL	<253/question		% yacute>
	ASCIL	<254/thorn>
	ASCIL	<255/ydieresis>
	ASCIL	<] def>
	ASCIL

;set up for first page

	ASCIL	<initgraphics save 8.5 11 pagesize /.cb pheight def 1 1 moveto>
	ASCIL
	ASCIL	<%% -------- page 1 -------->
	ASCIL
	BYTE	0

;Printer shutdown code

PRTCLS:	ASCIL				; 
	ASCIL	<.np grestore>		; 
	BYTE	4,0			; send a ^D at the end
	EVEN				; module must end on word boundary

;************
;*  PDSROT  *
;************
;Set text rotation (relative or absolute)
;D2 contains angle in degrees for absolute
;if D2 contains -1 (word), D1 contains relative positive rotation
;if D2 contains -2 (word), D2 contains relative negative rotation

PDSROT:	SAVE	A2,D1-D3		; 
	CALL	ENDSTR			; 
	LEA	A2,PTDDB(A3)		; 
	MOV	D1,D3			; 
	CMPW	D2,#-1			; relative positive rotation?
	BEQ	RP.ROT			;   yes
	CMPW	D2,#-2			; relative negative rotation?
	BEQ	RN.ROT			;   yes

;absolute rotation

RA.ROT:	OUTSTR	ROTABS			; 
	MOV	D2,D1			; 
	BCALL	FIX.ANGLE		; 
	DCVT	0,OT$DDB		; 
	OUTSTR	ROTCLS			; 
	BR	RO.RTN			; 

;relative positive rotation

RP.ROT:	OUTSTR	ROTREL			; 
	MOV	D3,D1			; 
	CALL	FIX.ANGLE		; 
	DCVT	0,OT$DDB		; 
	OUTSTR	ROTCLS			; 
	BR	RO.RTN			; 

;relative negative rotation 

RN.ROT:	OUTSTR	ROTREL			; 
	MOVB	#'-,D1			; 
	FILOTB	@A2			; 
	MOV	D3,D1			; 
	CALL	FIX.ANGLE		; 
	DCVT	0,OT$DDB		; 
	OUTSTR	ROTCLS			; 

RO.RTN:	REST	A2,D1-D3		; 
	RTN				; 

ROTABS:	BYTE	0			; 
ROTREL:	BYTE	0			; 
ROTCLS:	ASCIZ	" rotate "		; 
	EVEN				; 

;insure angle in D2 is between 0 and 360

FIX.ANGLE:
	ANDW	#177777,D2		; 
10$:	CMPW	D2,#360.		; > 360 degrees?
	BLOS	20$			;   no
	SUBW	#360.,D2		;   yes - subtract 360
	BR	10$			;         and check again
20$:	RTN				; 

;************
;*  PDCSET  *
;************
;Set character set
;
;	D2 contains:	0 - ISO Latin I or nearest equivalent
;			2 - "natural" character set of printer

PDCSET:	TSTW	D2			; ISO Latin I?
	BEQ	10$			;   yes
	CMPW	D2,#2			; natural character set?
	BNE	10$			;   no
	OR	#PF$NAT,FLAGS(A3)	;   yes - set flag
10$:	RTN				; return

;*****************************
;*  FONT SUBSTITUTION TABLE  *
;*****************************
;This table controls the substitution of fonts.  When a non-available font
;is requested, an available one with a similar look should be selected.

FONT.XLATE:
	BYTE	'E,'C			; Prestige    -> Courier
	BYTE	'F,'H			; Broadway    -> Helvetica
	BYTE	'G,'N			; Garamond    -> NewCentury
	BYTE	'J,'H			; CooperBlack -> Helvetica
	BYTE	'K,'I			; Presentation-> HelvNarrow
	BYTE	'L,'C			; Ltr Gothic  -> Courier
	BYTE	'M,'Z			; Coronet     -> ZapfChancery
	BYTE	'O,'P			; Optima      -> Palatino
	BYTE	'Q,'C			; Font Q      -> Courier
	BYTE	'R,'N			; Bodoni      -> NewCentury
;[CUS]	BYTE	'U,'A			; University  -> AvantGarde
	BYTE	'V,'C			; Line Print  -> Courier
	BYTE	'W,'C			; Font W      -> Courier
	BYTE	'X,'C			; Font X      -> Courier
	BYTE	'Y,'C			; Font Y      -> Courier
	BYTE	0			; ** end of table **
	EVEN

;******************************
;*  FLOATING POINT CONSTANTS  *
;******************************

$72:	WORD	41620,0,0		; 72. in AM floating point format

;******************
;*  GET.ENCODING  *
;******************
;Function:	Return encoding vector font id number (0-34)
;
;Inputs:	CURFNT(A3) - current font letter number (0-25)
;
;Outputs:	ENCNUM(A3) - font id number (0-34)

GET.ENCODING:
	SAVE	A0,D0-D2		; 
	CLRB	ENCNUM(A3)		; 
	LEA	A0,ENCTBL		; 
	MOVW	CURFNT(A3),D0		; 
	CLR	D2			; 
10$:	MOVB	(A0)+,D2		; 
	CMPB	D2,#-1			; 
	BEQ	GE.RTN			; 
	CMPW	D2,D0			; right font family?
	BEQ	20$			;   yes
	ADD	#2,A0			; 
	BR	10$			; 

;we have correct font family - check style

20$:	MOVB	(A0)+,D1		; get style code
	BMI	30$			;   -1 is all styles
	BEQ	22$			; plain
	CMPB	D1,#1			; bold
	BEQ	23$			; 
	CMPB	D1,#2			; italic
	BEQ	24$			; 

;BoldItalic

	BIT	#PF$BLD,FLAGS(A3),1	; bold selected?
	BEQ	40$			;   no
	BIT	#PF$ITA,FLAGS(A3),1	; italic selected?
	BEQ	40$			;   no
	BR	30$			; right entry

;Plain

22$:	BIT	#PF$BLD,FLAGS(A3),1	; bold selected?
	BNE	40$			;   no
	BIT	#PF$ITA,FLAGS(A3),1	; italic selected?
	BNE	40$			;   no
	BR	30$			; right entry

;Bold

23$:	BIT	#PF$ITA,FLAGS(A3),1	; italic selected?
	BNE	40$			;   yes
	BIT	#PF$BLD,FLAGS(A3),1	; bold selected?
	BEQ	40$			;   no
	BR	30$			; right entry

;Italic

24$:	BIT	#PF$BLD,FLAGS(A3),1	; bold selected?
	BNE	40$			;   yes
	BIT	#PF$ITA,FLAGS(A3),1	; italic selected?
	BEQ	40$			;   no

30$:	MOVB	@A0,ENCNUM(A3)		; 
	BR	GE.RTN			; 

40$:	INC	A0			; 
	JMP	10$			; 

GE.RTN:	REST	A0,D0-D2		; 
	RTN				; 

;*******************************
;*  FONT ENCODING ASSIGNMENTS  *
;*******************************
;each entry contains font letter (0-25), attributes (0=plain, 1=Bold,
;2=Italic, 3=BoldItalic, -1=any), and the encoding font id (0-34) to be used.

ENCTBL:	BYTE	0,	0,	0	; 00: Avant-Garde
	BYTE	0,	1,	1	; 01: Avant-Garde Bold
	BYTE	0,	2,	2	; 02: Avant-Garde Italic
	BYTE	0,	3,	3	; 03: Avant-Garde BoldItalic

	BYTE	1,	0,	4	; 04: Bookman
	BYTE	1,	1,	5	; 05: Bookman Bold
	BYTE	1,	2,	6	; 06: Bookman Italic
	BYTE	1,	3,	7	; 07: Bookman BoldItalic

	BYTE	2,	0,	8.	; 08: Bookman
	BYTE	2,	1,	9.	; 09: Bookman Bold
	BYTE	2,	2,	10.	; 10: Bookman Italic
	BYTE	2,	3,	11.	; 11: Bookman BoldItalic

	BYTE	0,	-1,	12.	; 12: Courier

	BYTE	7,	0,	13.	; 13: Helvetica
	BYTE	7,	1,	14.	; 14: Helvetica Bold
	BYTE	7,	2,	15.	; 15: Helvetica Italic
	BYTE	7,	3,	16.	; 16: Helvetica BoldItalic

	BYTE	8.,	0,	17.	; 17: Helvetica-Narrow
	BYTE	8.,	1,	18.	; 18: Helvetica-Narrow Bold
	BYTE	8.,	2,	19.	; 19: Helvetica-Narrow Italic
	BYTE	8.,	3,	20.	; 20: Helvetica-Narrow BoldItalic

	BYTE	13.,	0,	21.	; 21: New Century
	BYTE	13.,	1,	22.	; 22: New Century Bold
	BYTE	13.,	2,	23.	; 23: New Century Italic
	BYTE	13.,	3,	24.	; 24: New Century BoldItalic

	BYTE	15.,	0,	25.	; 25: Palatino
	BYTE	15.,	1,	26.	; 26: Palatino Bold
	BYTE	15.,	2,	27.	; 27: Palatino Italic
	BYTE	15.,	3,	28.	; 28: Palatino BoldItalic

	BYTE	18.,	-1,	29.	; 29: Symbol

	BYTE	19.,	0,	30.	; 30. Times-Roman
	BYTE	19.,	1,	31.	; 31. Times-Bold
	BYTE	19.,	2,	32.	; 32. Times-Italic
	BYTE	19.,	3,	33.	; 33. Times-BoldItalic

	BYTE	20.,	-1,	35.	; 35: UPC			[CUS]

	BYTE	25.,	-1,	34.	; 34: Zapf-Chancery

	BYTE	-1			; ** end of table **
	EVEN

;************
;*  AMENUM  *
;************
;American printable number in NUMBUF(A3) by converting current language
;decimal point character into an American '.'.  This is necessary for
;PostScript printers.

AMENUM:	LEA	A6,NUMBUF(A3)		; 
10$:	MOVB	(A6)+,D6		; 
	BEQ	30$			; 
	CMPB	D6,DECCHR(A3)		; 
	BNE	20$			; 
	MOVB	#'.,D6			; 
20$:	MOVB	D6,-1(A6)		; 
	BR	10$			; 
30$:	RTN				; 

;************
;*  OUTNUM  *
;************
;Output ASCIZ string in NUMBUF(A3) to output file
;Also convert -.nn to -0.nn

OUTNUM:	SAVE	A0,D1			; 
	LEA	A0,NUMBUF(A3)		; 
10$:	MOVB	(A0)+,D1		; 
	BEQ	20$			; 
	PUTBYT				; 

	CMPB	D1,#'-			; 
	BNE	10$			; 
	CMPB	@A0,#'.			; 
	BNE	10$			; 
	MOVB	#'0,D1			; 
	PUTBYT				; 

	BR	10$			; 
20$:	REST	A0,D1			; 
	RTN				; 

;************
;*  TRANSC  *
;************
;Translate special character - internal
;
;D1 contains the character to be translated
;D1 is returned as the character code to use for width calculations
;
;If a temporary font change to SYMBOL is required, return 1 in PDVARG(A3)

TRANSC:	CLR	PDVARG(A3)		; 
	LEA	A6,100$			; index special character table
10$:	MOVW	(A6)+,D6		; get special character
	BEQ	30$			;   end of table
	CMPW	D6,D1			; match?
	BEQ	20$			;   yes
	TST	(A6)+			; move to next entry
	BR	10$			; loop
20$:	CLR	D1			; translate
	MOVW	(A6)+,D1		;   character
	MOVW	(A6)+,D7		; get flags word
	BEQ	30$			;   normal character replacement
	MOV	#1,PDVARG(A3)		; 
30$:	RTN				; return (translated char in D1)

;table of special character translations
;
;each entry consists of:
;
;	(1) original character code,
;	(2) replacement character code,
;	(3) flags word (0=standard replacement, 1=symbol mode replacement)

100$:	WORD	C$NXB,040,0		; required space	-> space
	WORD	C$DEG,260,0		; degree symbol		-> ring
	WORD	C$PAR,266,0		; paragraph symbol	-> paragraph
	WORD	C$DAG,230,0		; dagger		-> dagger
	WORD	C$SEC,247,0		; section symbol	-> section
	WORD	C$CNT,242,0		; cent sign		-> cent

	IF	EQ,SPECHR-0
	WORD	C$TM, 324,1		; trademark symbol	-> SYMBOL
	WORD	C$CPY,323,1		; copyright symbol	-> SYMBOL
	WORD	C$REG,322,1		; registered symbol	-> SYMBOL
	IFF
	WORD	C$TM,150.,0		; trademark symbol	-> SYMBOL
	WORD	C$CPY,251,0		; copyright symbol	-> SYMBOL
	WORD	C$REG,256,0		; registered symbol	-> SYMBOL
	ENDC

	IF EQ,BULLET-1,WORD C$BLT,267,0	; bullet (from character set)
	IF EQ,BULLET-2,WORD C$BLT,'n,1	; bullet (Symbol filled-in square)
	WORD	C$EMD,148.,0		; em dash
	WORD	C$END,149.,0		; en dash

	WORD	0			; ** end of table **

PAGE
;****************
;*  FONT.TABLE  *
;****************
;Font definition table
;
;All resident PostScript fonts are available in portrait and landscape
;orientations, and are scalable to any point size.

FONT.TABLE:

;*****************
;*  AVANT-GARDE  *
;*****************
;Font "A" - Apple LaserWriter Plus, LaserWriter II
;Proportional sans-serif font

FONT.A:	STR	A,40.					; FO.LOG
	STR	AvantGarde-Book,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$PRO		; FO.FLG
	RAD50	/PSA00 /				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	A,40.					; FO.LOG
	STR	AvantGarde-Demi,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$BLD!FO$PRO	; FO.FLG
	RAD50	/PSA00B/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	A,40.					; FO.LOG
	STR	AvantGarde-BookOblique,40.		; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$OBL!FO$PRO	; FO.FLG
	RAD50	/PSA00I/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	A,40.					; FO.LOG
	STR	AvantGarde-DemiOblique,40.		; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$BLD!FO$OBL!FO$PRO	; FO.FLG
	RAD50	/PSA00X/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

;*************
;*  BOOKMAN  *
;*************
;Font "B" - Apple LaserWriter Plus, LaserWriter II
;Proportional serif font

FONT.B:	STR	B,40.					; FO.LOG
	STR	Bookman-Light,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$PRO		; FO.FLG
	RAD50	/PSB00 /				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	B,40.					; FO.LOG
	STR	Bookman-Demi,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$BLD!FO$PRO	; FO.FLG
	RAD50	/PSB00B/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	B,40.					; FO.LOG
	STR	Bookman-LightItalic,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$OBL!FO$PRO	; FO.FLG
	RAD50	/PSB00I/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	B,40.					; FO.LOG
	STR	Bookman-DemiItalic,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$BLD!FO$OBL!FO$PRO ; FO.FLG
	RAD50	/PSB00X/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

;*************
;*  COURIER  *
;*************
;Font "C" - Apple LaserWriter, LaserWriter Plus, LaserWriter II
;Monospaced serif font

FONT.C:	STR	C,40.					; FO.LOG
	STR	Courier,40.				; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$PRO		; FO.FLG
	RAD50	/PSC00 /				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	C,40.					; FO.LOG
	STR	Courier-Bold,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$BLD!FO$PRO	; FO.FLG
	RAD50	/PSC00B/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	C,40.					; FO.LOG
	STR	Courier-Oblique,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$OBL!FO$PRO	; FO.FLG
	RAD50	/PSC00I/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	C,40.					; FO.LOG
	STR	Courier-BoldOblique,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$BLD!FO$OBL!FO$PRO ; FO.FLG
	RAD50	/PSC00X/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

;*******************
;*  ZAPF DINGBATS  *
;*******************
;Font "D" - Apple LaserWriter Plus, LaserWriter II
;Monospaced pictorial font

FONT.D:	STR	D,40.					; FO.LOG
	STR	ZapfDingbats,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$PRO		; FO.FLG
	RAD50	/PSD00 /				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	D,40.					; FO.LOG
	STR	ZapfDingbats,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$BLD!FO$KRN!FO$PRO	; FO.FLG
	RAD50	/PSD00 /				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	D,40.					; FO.LOG
	STR	ZapfDingbats,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$OBL!FO$KRN!FO$PRO	; FO.FLG
	RAD50	/PSD00 /				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	D,40.					; FO.LOG
	STR	ZapfDingbats,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$BLD!FO$OBL!FO$KRN!FO$PRO ; FO.FLG
	RAD50	/PSD00 /				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

;***************
;*  HELVETICA  *
;***************
;Font "H" - Apple LaserWriter, LaserWriter Plus, LaserWriter II
;Proportional sans-serif font

FONT.H:	STR	H,40.					; FO.LOG
	STR	Helvetica-Roman,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$PRO		; FO.FLG
	RAD50	/PSH00 /				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	H,40.					; FO.LOG
	STR	Helvetica-Bold,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$BLD!FO$PRO	; FO.FLG
	RAD50	/PSH00B/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	H,40.					; FO.LOG
	STR	Helvetica-Oblique,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$OBL!FO$PRO	; FO.FLG
	RAD50	/PSH00I/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	H,40.					; FO.LOG
	STR	Helvetica-BoldOblique,40.		; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$BLD!FO$OBL!FO$PRO ; FO.FLG
	RAD50	/PSH00X/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

;**********************
;*  HELVETICA-NARROW  *
;**********************
;Font "I" - Apple LaserWriter Plus, LaserWriter II
;Proportional sans-serif font
;Helvetica-Narrow is mechanically constructed from Helvetica

FONT.I:	STR	I,40.					; FO.LOG
	STR	HelveticaNarrow-Roman,40.		; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$PRO		; FO.FLG
	RAD50	/PSI00 /				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	I,40.					; FO.LOG
	STR	HelveticaNarrow-Bold,40.		; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$BLD!FO$PRO	; FO.FLG
	RAD50	/PSI00B/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	I,40.					; FO.LOG
	STR	HelveticaNarrow-Oblique,40.		; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$OBL!FO$PRO	; FO.FLG
	RAD50	/PSI00I/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	I,40.					; FO.LOG
	STR	HelveticaNarrow-BoldOblique,40.		; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$BLD!FO$OBL!FO$PRO ; FO.FLG
	RAD50	/PSI00X/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

;****************************
;*  NEW CENTURY SCHOOLBOOK  *
;****************************
;Font "N" - Apple LaserWriter Plus, LaserWriter II
;Proportional serif font

FONT.N:	STR	N,40.					; FO.LOG
	STR	NewCenturySchlbk,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$PRO		; FO.FLG
	RAD50	/PSN00 /				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	N,40.					; FO.LOG
	STR	NewCenturySchlbk-Bold,40.		; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$BLD!FO$PRO	; FO.FLG
	RAD50	/PSN00B/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	N,40.					; FO.LOG
	STR	NewCenturySchlbk-Italic,40.		; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$OBL!FO$PRO	; FO.FLG
	RAD50	/PSN00I/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	N,40.					; FO.LOG
	STR	NewCenturySchlbk-BoldItalic,40.		; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$BLD!FO$OBL!FO$PRO ; FO.FLG
	RAD50	/PSN00X/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

;**************
;*  PALATINO  *
;**************
;Font "P" -  Apple LaserWriter Plus, LaserWriter II
;Proportional serif font

FONT.P:	STR	P,40.					; FO.LOG
	STR	Palatino-Roman,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$PRO		; FO.FLG
	RAD50	/PSP00 /				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	P,40.					; FO.LOG
	STR	Palatino-Bold,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$BLD!FO$PRO	; FO.FLG
	RAD50	/PSP00B/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	P,40.					; FO.LOG
	STR	Palatino-Oblique,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$OBL!FO$PRO	; FO.FLG
	RAD50	/PSP00I/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	P,40.					; FO.LOG
	STR	Palatino-BoldOblique,40.		; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$BLD!FO$OBL!FO$PRO ; FO.FLG
	RAD50	/PSP00X/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

;************
;*  SYMBOL  *
;************
;Font "S" - Apple LaserWriter, LaserWriter Plus, LaserWriter II
;Monospaced sans-serif font

FONT.S:	STR	S,40.					; FO.LOG
	STR	Symbol,40.				; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$PRO		; FO.FLG
	RAD50	/PSS00 /				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	S,40.					; FO.LOG
	STR	Symbol,40.				; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$BLD!FO$KRN!FO$PRO	; FO.FLG
	RAD50	/PSS00 /				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	S,40.					; FO.LOG
	STR	Symbol,40.				; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$OBL!FO$KRN!FO$PRO	; FO.FLG
	RAD50	/PSS00 /				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	S,40.					; FO.LOG
	STR	Symbol,40.				; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$BLD!FO$OBL!FO$KRN!FO$PRO ; FO.FLG
	RAD50	/PSS00 /				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

;***********
;*  TIMES  *
;***********
;Font "T" - Apple LaserWriter, LaserWriter Plus, LaserWriter II
;Proportional serif font

FONT.T:	STR	T,40.					; FO.LOG
	STR	Times-Roman,40.				; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$PRO		; FO.FLG
	RAD50	/PST00 /				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	T,40.					; FO.LOG
	STR	Times-Bold,40.				; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$BLD!FO$PRO	; FO.FLG
	RAD50	/PST00B/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	T,40.					; FO.LOG
	STR	Times-Oblique,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$OBL!FO$PRO	; FO.FLG
	RAD50	/PST00I/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	T,40.					; FO.LOG
	STR	Times-BoldOblique,40.			; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$BLD!FO$OBL!FO$PRO ; FO.FLG
	RAD50	/PST00X/				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

;*********
;*  UPC  *
;*********
;Font "U" - Universal Price Code
;Proportional serif font

FONT.U:	STR	U,40.					; FO.LOG
	STR	UPC,40.					; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$PRO		; FO.FLG
	RAD50	/      /				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	U,40.					; FO.LOG
	STR	UPC,40.					; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$BLD!FO$PRO	; FO.FLG
	RAD50	/      /				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	U,40.					; FO.LOG
	STR	UPC,40.					; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$OBL!FO$PRO	; FO.FLG
	RAD50	/      /				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	U,40.					; FO.LOG
	STR	UPC,40.					; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$BLD!FO$OBL!FO$PRO ; FO.FLG
	RAD50	/      /				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

;*******************
;*  ZAPF CHANCERY  *
;*******************
;Font "Z" - Apple LaserWriter Plus, LaserWriter II
;Proportional serif font

FONT.Z:	STR	Z,40.					; FO.LOG
	STR	ZapfChancery-MediumItalic,40.		; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$PRO		; FO.FLG
	RAD50	/PSZ00 /				; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	Z,40.					; FO.LOG
	STR	ZapfChancery-MediumItalic,40.		; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$BLD!FO$PRO	; FO.FLG
	RAD50	/PSZ00/					; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	Z,40.					; FO.LOG
	STR	ZapfChancery-MediumItalic,40.		; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$OBL!FO$PRO	; FO.FLG
	RAD50	/PSZ00/					; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	STR	Z,40.					; FO.LOG
	STR	ZapfChancery-MediumItalic,40.		; FO.PHY
	LWORD	FO$POR!FO$LAN!FO$KRN!FO$BLD!FO$OBL!FO$PRO ; FO.FLG
	RAD50	/PSZ00/					; FO.TBL
	WORD	0					; FO.SIZ
	WORD	0					; FO.LED
	WORD	0					; FO.CPI

	WORD	0			; ** end of table **

	END

.