(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich.
Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *)

MODULE PSPrinter IN Oberon; (** portable *)	(*UNIX version: JT 11.5.90, RC 2.7.93, JS 29.4.9, Windows version: jm 20.12.95 *)

	(*
		wdm 2000-02-21 duplex printing: uses option "x"
		jm 20.12.95 EPS support added
		ps 4.8.96 added border to page (left, right: 2cm / top, bottom: 1.5 cm)
	*)

	IMPORT Files, Modules, Printer, Objects, Fonts, Texts, Strings, Oberon, Pictures;

	CONST
		N = 20;	(* max spline points *)
		maxFonts = 64;
		headerFileName = "PSHeader.Text";
		bold = 0; italics = 1; medium = 2;
		oneup = 0; twoup = 1; fourup = 2; rotated = 3;

	TYPE
		Name* = ARRAY 32 OF CHAR;

		PSPrinter* = POINTER TO PSPrinterDesc;
		PSPrinterDesc* = RECORD (Printer.PrinterDesc)
			Escape*: PROCEDURE (P: Printer.Printer; s: ARRAY OF CHAR);
			printF*: Files.File;
			eps*: BOOLEAN; (** Is EPS output being written? *)
			pno*: INTEGER; (** Current page being printer on (starts with 1) *)

			l, t, r, b: LONGINT;
			sx, sy: INTEGER; (* current string pos *)
			mode, location: SHORTINT;
			duplex: BOOLEAN; (* Print duplex pages *)
			anonymous: BOOLEAN
		END;

		FontDesc = RECORD
			name: Name;
			used: ARRAY 8 OF SET;
		END;
		RealVector = ARRAY N OF REAL;
		Poly = RECORD a, b, c, d, t: REAL END ;
		PolyVector = ARRAY N OF Poly;

	TYPE
		FontDef = POINTER TO FontDefDesc;
		FontDefDesc = RECORD
			name: ARRAY 64 OF CHAR;
			family: ARRAY 32 OF CHAR;
			size: INTEGER;
			attr: CHAR;
			next: FontDef
		END;

	VAR
		fontTable: ARRAY maxFonts OF FontDesc;
		fontIndex, curFont: INTEGER;
		listFont: Name;
		headerT: Texts.Text;
		bodyF: Files.File;
		bodyR: Files.Rider;
		ppos: LONGINT;
		hexArray: ARRAY 17 OF CHAR;
		curR, curG, curB, setR, setG, setB: INTEGER;

		metric: Objects.Library;
		fontMapDict: FontDef;
		fontMapDictN: INTEGER;
		default: Objects.Name;

	(* -- Output procedures -- *)

	PROCEDURE Ch (VAR R: Files.Rider; ch: CHAR);
	BEGIN
		Files.Write(R, ch)
	END Ch;

	PROCEDURE Str (VAR R: Files.Rider; s: ARRAY OF CHAR);
		VAR i: INTEGER;
	BEGIN
		i := 0;
		WHILE s[i] # 0X DO Ch(R, s[i]); INC(i) END;
	END Str;

	PROCEDURE Int (VAR R: Files.Rider; i: LONGINT);
		VAR j: LONGINT;
	BEGIN
		IF i = 0 THEN Ch(R, "0") ELSIF i < 0 THEN i := -i; Ch(R, "-") END;
		j := 1;
		WHILE (i DIV j) # 0 DO j := j * 10 END;
		WHILE j >= 10 DO j := j DIV 10; Ch(R, CHR(30H + (i DIV j) MOD 10)) END;
	END Int;

	PROCEDURE Hex2(VAR R: Files.Rider; ch: CHAR);
	BEGIN
		Ch(R, hexArray[ORD(ch) DIV 16]);
		Ch(R, hexArray[ORD(ch) MOD 16]);
	END Hex2;

	PROCEDURE Real(VAR R: Files.Rider; x: REAL);
	VAR
		n, i, xi: INTEGER;
		d: ARRAY 4 OF CHAR;
	BEGIN
		xi := SHORT(ENTIER(x));
		IF x = xi THEN Int(R, xi); RETURN END;
		IF x < 0 THEN Files.Write(R, "-"); x := -x; xi := -xi END;
		Int(R, xi); Files.Write(R, "."); x := x-xi;
		n := SHORT(ENTIER(x*1000));
		i := 0;
		REPEAT
			d[i] := CHR(n MOD 10+30H); n := n DIV 10; INC(i)
		UNTIL i = 3;
		WHILE i > 0 DO DEC(i); Files.Write(R, d[i]) END
	END Real;

	PROCEDURE Ln(VAR R: Files.Rider);
	BEGIN
		Ch(R, 0DX);
		Ch(R, 0AX);
	END Ln;

	(* -- Error handling -- *)

	PROCEDURE Error(s0, s1: ARRAY OF CHAR);
		VAR error, f: ARRAY 32 OF CHAR;
	BEGIN COPY(s0, error); COPY(s1, f); HALT(99)
	END Error;

	(* -- Bounding Box -- *)

	PROCEDURE Min(x, y: LONGINT): LONGINT;
	BEGIN IF x < y THEN RETURN x ELSE RETURN y END
	END Min;

	(* Increase the size of the bounding box. *)
	PROCEDURE Box*(P: PSPrinter; x, y, w, h: LONGINT);
	BEGIN
		IF x < P.l THEN P.l := x END;
		IF x + w - 1 > P.r THEN P.r := x + w - 1 END;
		IF y < P.b THEN P.b := y END;
		IF y + h - 1 > P.t THEN P.t := y + h - 1 END;
	END Box;

	(* -- Font Mapping -- *)

	PROCEDURE SetMappedFont(VAR fontR: Files.Rider; fname: ARRAY OF CHAR);
		VAR family: ARRAY 7 OF CHAR;
	BEGIN
		COPY(fname, family);
		Ch(fontR, "/"); Str(fontR, fname);
		IF (family = "Syntax") OR (family = "Oberon") OR (family = "Default") THEN Str(fontR, " DefineSMapFont")
		ELSE Str(fontR, " DefineMapFont") END;
		Ln(fontR); Ln(fontR);
	END SetMappedFont;

	PROCEDURE SetBitmapFont(VAR fontR, R: Files.Rider; fd: FontDesc; pRes: INTEGER);
		TYPE
			RunRec = RECORD beg, end: INTEGER END;
			Metrics = RECORD dx, x, y, w, h: INTEGER END;

		VAR
			ch: CHAR;
			pixmapDX, n, b: LONGINT;
			k, m: INTEGER;
			height, minX, maxX, minY, maxY: INTEGER;
			nOfBoxes, nOfRuns: INTEGER;
			run: ARRAY 16 OF RunRec;
			metrics: ARRAY 256 OF Metrics;

		PROCEDURE Flip(ch: CHAR): CHAR;
			VAR i, s, d: INTEGER;
		BEGIN
			i := 0; s := ORD(ch); d := 0;
			WHILE i < 8 DO
				IF s MOD 2 = 1 THEN d := d * 2 + 1 ELSE d := d * 2 END;
				s := s DIV 2;
				INC(i)
			END;
			RETURN CHR(d);
		END Flip;

		PROCEDURE Name(m: INTEGER);
		BEGIN
			CASE m OF
			| 9: Str(fontR, "tab")
			| 32: Str(fontR, "space")
			| 33: Str(fontR, "exclam")
			| 34: Str(fontR, "quotedbl")
			| 35: Str(fontR, "numbersign")
			| 36: Str(fontR, "dollar")
			| 37: Str(fontR, "percent")
			| 38: Str(fontR, "ampersand")
			| 39: Str(fontR, "quotesingle")
			| 40: Str(fontR, "parenleft")
			| 41: Str(fontR, "parenright")
			| 42: Str(fontR, "asterisk")
			| 43: Str(fontR, "plus")
			| 44: Str(fontR, "comma")
			| 45: Str(fontR, "minus")
			| 46: Str(fontR, "period")
			| 47: Str(fontR, "slash")
			| 48: Str(fontR, "zero")
			| 49: Str(fontR, "one")
			| 50: Str(fontR, "two")
			| 51: Str(fontR, "three")
			| 52: Str(fontR, "four")
			| 53: Str(fontR, "five")
			| 54: Str(fontR, "six")
			| 55: Str(fontR, "seven")
			| 56: Str(fontR, "eight")
			| 57: Str(fontR, "nine")
			| 58: Str(fontR, "colon")
			| 59: Str(fontR, "semicolon")
			| 60: Str(fontR, "less")
			| 61: Str(fontR, "equal")
			| 62: Str(fontR, "greater")
			| 63: Str(fontR, "question")
			| 64: Str(fontR, "at")
			| 65..90: Ch(fontR, CHR(m))
			| 91: Str(fontR, "bracketleft")
			| 92: Str(fontR, "backslash")
			| 93: Str(fontR, "bracketright")
			| 94: Str(fontR, "arrowup")
			| 95: Str(fontR, "underscore")
			| 96: Str(fontR, "grave")
			| 97..122: Ch(fontR, CHR(m))
			| 123: Str(fontR, "braceleft")
			| 124: Str(fontR, "bar")
			| 125: Str(fontR, "braceright")
			| 126: Str(fontR, "tilde")
			| 128: Str(fontR, "Adieresis")
			| 129: Str(fontR, "Odieresis")
			| 130: Str(fontR, "Udieresis")
			| 131: Str(fontR, "adieresis")
			| 132: Str(fontR, "odieresis")
			| 133: Str(fontR, "udieresis")
			| 134: Str(fontR, "acircumflex")
			| 135: Str(fontR, "ecircumflex")
			| 136: Str(fontR, "icircumflex")
			| 137: Str(fontR, "oicircumflex")
			| 138: Str(fontR, "uicircumflex")
			| 139: Str(fontR, "agrave")
			| 140: Str(fontR, "egrave")
			| 141: Str(fontR, "igrave")
			| 142: Str(fontR, "ograve")
			| 143: Str(fontR, "ugrave")
			| 144: Str(fontR, "eacute")
			| 145: Str(fontR, "edieresis")
			| 146: Str(fontR, "idieresis")
			| 147: Str(fontR, "ccedilla")
			| 148: Str(fontR, "aacute")
			| 149: Str(fontR, "ntilde")
			| 150: Str(fontR, "germandbls")
			| 155: Str(fontR, "endash")
			| 159: Str(fontR, "hyphen")
			ELSE
				Str(fontR, "ascii");
				Ch(fontR, CHR(30H + (m DIV 100) MOD 10));
				Ch(fontR, CHR(30H + (m DIV 10) MOD 10));
				Ch(fontR, CHR(30H + m MOD 10))
			END
		END Name;

	BEGIN
		Str(fontR, "% Conversion of the Oberon font "); Str(fontR, fd.name); Ln(fontR);
		Files.Read(R, ch);
		IF ch = Fonts.FontId THEN
			Files.Read(R, ch); Str(fontR, "% abstraction: "); Int(fontR, ORD(ch));
			Files.Read(R, ch); Str(fontR, ", family: "); Ch(fontR, ch);
			Files.Read(R, ch); Str(fontR, ", variant: "); Int(fontR, ORD(ch)); Ln(fontR);
			Files.ReadInt(R, height); Str(fontR, "% height: "); Int(fontR, height); Ln(fontR); Ln(fontR);
			Files.ReadInt(R, minX); Files.ReadInt(R, maxX);
			Files.ReadInt(R, minY); Files.ReadInt(R, maxY);
			Files.ReadInt(R, nOfRuns);
			nOfBoxes := 0; k := 0;
			WHILE k # nOfRuns DO
				Files.ReadInt(R, run[k].beg); Files.ReadInt(R, run[k].end);
				INC(nOfBoxes, run[k].end - run[k].beg);
				INC(k)
			END;
			Str(fontR, "9 dict begin"); Ln(fontR); Ln(fontR);
			Str(fontR, "/FontType 3 def"); Ln(fontR);
			Str(fontR, "/FontMatrix [ 72 "); Int(fontR, pRes); Str(fontR, " div "); Str(fontR, " factor1 div 0 0 ");
			Str(fontR, "72 "); Int(fontR, pRes); Str(fontR, " div "); Str(fontR, " factor2 div 0 0");
			Str(fontR, "] def"); Ln(fontR);
			Str(fontR, "/FontBBox [");
			Int(fontR, minX); Ch(fontR, " ");
			Int(fontR, minY); Ch(fontR, " ");
			Int(fontR, maxX); Ch(fontR, " ");
			Int(fontR, maxY);
			Str(fontR, "] def"); Ln(fontR); Ln(fontR);
			Str(fontR, "/Encoding 256 array def"); Ln(fontR);
			Str(fontR, "0 1 255 {Encoding exch /.notdef put} for"); Ln(fontR);
			Str(fontR, "Encoding OberonEncoding /Encoding exch def"); Ln(fontR);
			Ln(fontR);
			Str(fontR, "/CharData "); Int(fontR, nOfBoxes+1);
			Str(fontR, " dict def"); Ln(fontR);
			Str(fontR, "CharData begin"); Ln(fontR);
			k := 0; m := 0;
			WHILE k < nOfRuns DO
				m := run[k].beg;
				WHILE m < run[k].end DO
					Files.ReadInt(R, metrics[m].dx);
					Files.ReadInt(R, metrics[m].x); Files.ReadInt(R, metrics[m].y);
					Files.ReadInt(R, metrics[m].w); Files.ReadInt(R, metrics[m].h);
					INC(m);
				END;
				INC(k)
			END;
			Str(fontR, "/.notdef"); Str(fontR, " [");
			Int(fontR, metrics[32].w); Str(fontR, " 0 0 0 0 1 1 0 0"); Ln(fontR);
			Str(fontR, "<>] bdef"); Ln(fontR);
			k := 0; m := 0;
			WHILE k < nOfRuns DO
				m := run[k].beg;
				WHILE m < run[k].end DO
					IF m MOD 32 IN fd.used[m DIV 32] THEN
						Str(fontR, "/"); Name(m); Str(fontR, " [");
						Int(fontR, metrics[m].dx); Str(fontR, " ");
						Int(fontR, metrics[m].x); Str(fontR, " "); Int(fontR, metrics[m].y); Str(fontR, " ");
						Int(fontR, metrics[m].x + metrics[m].w); Str(fontR, " ");
						Int(fontR, metrics[m].y + metrics[m].h); Str(fontR, " ");
						IF metrics[m].w > 0 THEN Int(fontR, metrics[m].w); ELSE Int(fontR, 1) END; Str(fontR, " ");
						IF metrics[m].h > 0 THEN Int(fontR, metrics[m].h); ELSE Int(fontR, 1) END; Str(fontR, " ");
						Int(fontR, -metrics[m].x); Str(fontR, " "); Int(fontR, -metrics[m].y); Ln(fontR);
						Str(fontR, "<");
						pixmapDX := (metrics[m].w + 7) DIV 8;
						n := pixmapDX * metrics[m].h;
						b := 0;
						WHILE b < n DO
							Files.Read(R, ch); Hex2(fontR, Flip(ch));
							INC(b);
							IF b MOD 32 = 0 THEN Ln(fontR); Str(fontR, " ") END
						END;
						Str(fontR, ">] bdef"); Ln(fontR);
					ELSE
						n := (metrics[m].w + 7) DIV 8 * metrics[m].h;
						b := 0; WHILE b < n DO Files.Read(R, ch); INC(b) END;
					END;
					INC(m);
				END;
				INC(k)
			END;
			Str(fontR, "  end"); Ln(fontR); Ln(fontR);
			Str(fontR, "/BuildGlyph {GlobalBuildGlyph} bdef"); Ln(fontR);
			Str(fontR, "/BuildChar {GlobalBuildChar} bdef"); Ln(fontR); Ln(fontR);
			Str(fontR, "/imageMaskMatrix [1 0 0 1 0 0] bdef"); Ln(fontR); Ln(fontR);
			Str(fontR, "currentdict"); Ln(fontR); Ln(fontR);
			Str(fontR, "end"); Ln(fontR); Ln(fontR);
			Ch(fontR, "/"); Str(fontR, fd.name);
			Str(fontR, " exch definefont pop"); Ln(fontR); Ln(fontR);
		END;
	END SetBitmapFont;

	PROCEDURE DefineFont(VAR fontR: Files.Rider; fd: FontDesc; echo: BOOLEAN);
		VAR
			family, name: ARRAY 32 OF CHAR;
			i, size, dpi: INTEGER;
			f: Files.File; R: Files.Rider;
			fontDef: FontDef;
			attr: CHAR;
	BEGIN
		dpi := SHORT(914400 DIV Printer.current.Unit);
		COPY(fd.name, name); i := 0; size := 0;
		WHILE (name[i] # 0X) & (name[i] # ".") & ((name[i] < "0") OR (name[i] > "9")) DO
			family[i] := name[i]; INC(i)
		END;
		family[i] := 0X;
		size := 0;
		WHILE (name[i] >= "0") & (name[i] <= "9") DO size := size * 10 + ORD(name[i]) - 30H; INC(i) END;
		attr := 0X;
		WHILE (name[i] # 0X) & (name[i] # ".") DO attr := CAP(name[i]); INC(i) END;
		fontDef := fontMapDict;
		WHILE (fontDef # NIL) & ~((fontDef.size = size) & (fontDef.attr = attr) & (fontDef.family = family)) DO
			fontDef := fontDef.next
		END;
		IF fontDef = NIL THEN
			NEW(fontDef); fontDef.next := fontMapDict; fontMapDict := fontDef; INC(fontMapDictN);
			COPY(name, fontDef.name); COPY(family, fontDef.family);
			fontDef.size := size; fontDef.attr := attr
		END;
		IF ~echo THEN RETURN END;
		IF (name[i] # ".") OR (name[i+1] # "S") OR (name[i+2] # "c") OR (name[i+3] # "n") THEN
			SetMappedFont (fontR, fd.name);
		ELSE
			name[i+1] := "P"; name[i+2] := "r"; name[i+3] := CHR((dpi DIV 100)+ORD("0"));
			f := Files.Old(name);
			IF f = NIL THEN
				SetMappedFont (fontR, fd.name);
			ELSE
				Files.Set(R, f, 0); SetBitmapFont(fontR, R, fd, dpi)
			END;
		END;
	END DefineFont;

	(* -- Metric Font loading -- *)

	PROCEDURE ParseName (VAR name, family: ARRAY OF CHAR; VAR size: LONGINT; VAR style: SET; VAR class: ARRAY OF CHAR);
	VAR i, j: INTEGER;
	BEGIN
		size := 0; style := {}; i := 0;
		WHILE (name[i] > "9") OR (name[i] = " ") DO family[i] := name[i]; INC(i) END;
		family[i] := 0X;
		WHILE ("0" <= name[i]) & (name[i] <= "9") DO size := 10*size + (ORD(name[i]) - 30H); INC(i) END;
		WHILE (name[i] # 0X) & (name[i] # ".") DO
			CASE CAP(name[i]) OF
				| "I": INCL(style, italics); name[i] := "i"
				| "B": INCL(style, bold); name[i] := "b"
				| "M": INCL(style, medium); name[i] := "m"
			ELSE
			END;
			INC(i)
		END;
		j := 0;
		INC(i); WHILE (name[i] # 0X) & (name[i] # ".") DO class[j] := name[i]; INC(i); INC(j) END;
		class[j] := 0X;
	END ParseName;

	(* -- Exported Procedures -- *)

	PROCEDURE GetDim(P: Printer.Printer; label: ARRAY OF CHAR; def: INTEGER; VAR val: INTEGER);
	VAR v: REAL; S: Texts.Scanner;
	BEGIN
		Oberon.OpenScanner(S, label);
		IF S.class IN {Texts.Int, Texts.Real} THEN
			IF S.class = Texts.Int THEN v := S.i
			ELSE v := S.x
			END;
			Texts.Scan(S);
			IF S.class IN {Texts.Name, Texts.String} THEN
				IF S.s = "cm" THEN v := v*360000.0
				ELSIF S.s = "mm" THEN v := v*36000.0
				ELSIF S.s = "in" THEN v := v*36000.0*25.4
				ELSE v := v*36000.0	(* default mm *)
				END
			ELSE v := v*36000.0	(* default mm *)
			END;
			val := SHORT(ENTIER(v/P.Unit + 0.5))
		ELSE
			val := SHORT(ENTIER(def*36000.0/P.Unit + 0.5))
		END
	END GetDim;

	PROCEDURE Swap(VAR x, y: INTEGER);
	VAR t: INTEGER;
	BEGIN
		t := x; x := y; y := t
	END Swap;

	PROCEDURE InitMetrics*(P: Printer.Printer);
		VAR S: Texts.Scanner;
	BEGIN
		Oberon.OpenScanner(S, "Printer.PSPrinter.Resolution");
		IF S.class # Texts.Int THEN S.i := 300 END;	(* default *)

		P.Unit := 914400 DIV S.i; P.Depth := 24;

		GetDim(P, "Printer.PSPrinter.Width", 210, P.Width);
		GetDim(P, "Printer.PSPrinter.Height", 297, P.Height);
		GetDim(P, "Printer.PSPrinter.LeftMargin", 20, P.FrameX);
		GetDim(P, "Printer.PSPrinter.RightMargin", 20, P.FrameW);
		P.FrameW := P.Width-P.FrameX-P.FrameW;
		GetDim(P, "Printer.PSPrinter.BottomMargin", 15, P.FrameY);
		GetDim(P, "Printer.PSPrinter.TopMargin", 15, P.FrameH);
		P.FrameH := P.Height-P.FrameY-P.FrameH;
		IF P(PSPrinter).mode = rotated THEN
			Swap(P.Width, P.Height); Swap(P.FrameX, P.FrameY); Swap(P.FrameW, P.FrameH)
		END
	END InitMetrics;

	PROCEDURE GetSuffix(VAR str(** in *), suf(** out *): ARRAY OF CHAR);
		VAR i, j, dot: LONGINT;
	BEGIN
		dot := -1; i := 0;
		WHILE str[i] # 0X DO
			IF str[i] = "." THEN dot := i END;
			INC(i)
		END;
		j := 0;
		IF dot > 0 THEN
			i := dot+1;
			WHILE str[i] # 0X DO
				suf[j] := str[i]; INC(j); INC(i)
			END
		END;
		suf[j] := 0X
	END GetSuffix;

	PROCEDURE SetColor;
	BEGIN
		IF (setR # curR) OR (setG # curG) OR (setB # curB) THEN
			setR := curR; setG := curG; setB := curB;
			Real(bodyR, setR/255); Ch(bodyR, " ");
			Real(bodyR, setG/255); Ch(bodyR, " ");
			Real(bodyR, setB/255); Ch(bodyR, " ");
			Str(bodyR, "u ");
			Ln(bodyR)
		END
	END SetColor;

	PROCEDURE ResetColor;
	BEGIN
		curR := 0; curG := 0; curB := 0;
		setR := 0; setG := 0; setB := 0
	END ResetColor;

	PROCEDURE Open*(P: Printer.Printer; printer, options: ARRAY OF CHAR);
	VAR suffix: ARRAY 32 OF CHAR; i: LONGINT;
	BEGIN
		WITH P: PSPrinter DO
			ResetColor;
			P.res := 1;	(* no such printer *)
			P.printF := Files.New(printer);
			IF P.printF = NIL THEN
				P.printF := Files.New(""); P.anonymous := TRUE
			ELSE
				P.anonymous := FALSE
			END;
			GetSuffix(printer, suffix);
			P.eps := (suffix = "EPS") OR (suffix = "eps");
			i := 0; P.mode := oneup; P.location := 0;
			WHILE (options[i] # 0X) & (options[i] # Oberon.OptionChar) DO
				IF options[i] = "l" THEN P.mode := twoup
				ELSIF options[i] = "d" THEN P.mode := fourup
				ELSIF options[i] = "e" THEN P.eps := TRUE
				ELSIF options[i] = "r" THEN P.mode := rotated
				ELSIF options[i] = "x" THEN P.duplex := TRUE
				END;
				INC(i)
			END;
			InitMetrics(P);
			fontMapDict := NIL; fontMapDictN := 0;
			P.l := MAX(LONGINT); P.r := MIN(LONGINT); P.t := MIN(LONGINT); P.b := MAX(LONGINT);

			NEW(headerT); Texts.Open(headerT, headerFileName);
			IF headerT.len > 0 THEN
				bodyF := Files.New(""); Files.Set(bodyR, bodyF, 0);
				fontIndex := -1; curFont := -1; listFont := ""; ppos := 0; P.pno := 1;
				P.res := 0
			ELSE
				Error("file not found", headerFileName)
			END
		END
	END Open;

	PROCEDURE UseListFont*(P: Printer.Printer; name: ARRAY OF CHAR);
	BEGIN
		COPY(name, listFont); curFont := -1
	END UseListFont;

	(** Don't forget to update the bounding box of eps files by calling procedure Box. *)
	PROCEDURE Escape*(P: Printer.Printer; s: ARRAY OF CHAR);
	BEGIN
		WITH P: PSPrinter DO
			(* Don't make more that one page when making eps *)
			IF P.eps & (P.pno > 1) THEN RETURN END;
			SetColor;
			Str(bodyR, s)
		END
	END Escape;

	PROCEDURE ReplConst*(P: Printer.Printer; x, y, w, h: INTEGER);
	BEGIN
		WITH P: PSPrinter DO
			(* Don't make more that one page when making eps *)
			IF P.eps & (P.pno > 1) THEN RETURN END;
			IF (w > 0) & (h > 0) THEN
				SetColor;
				Box(P, x, y, w, h);
				Int(bodyR, x+1); Ch(bodyR, " ");
				Int(bodyR, y); Ch(bodyR, " ");
				Int(bodyR, w-1); Ch(bodyR, " ");
				Int(bodyR, h-1); Str(bodyR, " l"); Ln(bodyR);
			END
		END
	END ReplConst;

	PROCEDURE StringSize(VAR s: ARRAY OF CHAR; fnt: Fonts.Font; VAR w, h, dsr: INTEGER);
	VAR p: INTEGER; obj: Objects.Object;
	BEGIN
		w := 0; h := 0; dsr := 0;
		p := 0;
		IF (metric = NIL) OR (fnt.name # metric.name) THEN metric := Printer.GetMetric(fnt) END;
		IF (metric # NIL) & (metric(Fonts.Font).type = Fonts.metric) THEN
			WHILE s[p] # 0X DO
				metric.GetObj(metric, ORD(s[p]), obj);
				INC(w, obj(Fonts.Char).dx);
				INC(p)
			END;
			h := metric(Fonts.Font).height;
			dsr := ABS(metric(Fonts.Font).minY);
		END
	END StringSize;

	PROCEDURE ContString*(P: Printer.Printer; s: ARRAY OF CHAR; fnt: Fonts.Font);
		VAR fNo, i, n, w, h, dsr: INTEGER; ch: CHAR; family: ARRAY 7 OF CHAR;

		PROCEDURE Use(ch: CHAR);
		BEGIN
			INCL(fontTable[curFont].used[ORD(ch) DIV 32], ORD(ch) MOD 32);
		END Use;

	BEGIN
		WITH P: PSPrinter DO
			(* Don't make more that one page when making eps *)
			IF P.eps & (P.pno > 1) THEN RETURN END;
			SetColor;
			StringSize(s, fnt, w, h, dsr);
			Box(P, P.sx - dsr, P.sy, w, h);
			INC(P.sx, w);

			IF (curFont < 0) OR (fontTable[curFont].name # fnt.name) THEN
				COPY(fnt.name, fontTable[fontIndex+1].name);
				i := 0; WHILE i < 8 DO fontTable[fontIndex+1].used[i] := {}; INC(i) END;
				fNo := 0;
				WHILE fontTable[fNo].name # fnt.name DO INC(fNo) END;
				IF fNo > fontIndex THEN (* DefineFont(fname); *) fontIndex := fNo END;
				curFont := fNo; Ch(bodyR, "(");
				IF fontTable[curFont].name = listFont THEN
					Str(bodyR, "Courier8.Scn.Fnt")
				ELSE
					Str(bodyR, fontTable[curFont].name)
				END;
				Str(bodyR, ") f ")
			END;
			Ch(bodyR, "(");
			i := 0; ch := s[0];
			WHILE ch # 0X DO
				CASE ch OF
				| "(", ")", "\": Ch(bodyR, "\"); Ch(bodyR, ch); Use(ch);
				| 9X: Str(bodyR, "  "); Use(" ")	(* or Str("\tab") *)
				| 80X..95X, 0ABX:
					Str(bodyR, "\2"); n := ORD(ch)-128;
					Ch(bodyR, CHR(n DIV 8 + 48)); Ch(bodyR, CHR(n MOD 8 + 48)); Use(ch)
				| 9FX: COPY(fontTable[curFont].name, family);
					IF family = "Courie" THEN Ch(bodyR, " ") ELSE Str(bodyR, "  ") END; Use(" ");
				ELSE
					Ch(bodyR, ch); Use(ch);
				END ;
				INC(i); ch := s[i];
			END;
			Str(bodyR, ") s"); Ln(bodyR)
		END
	END ContString;

	PROCEDURE String*(P: Printer.Printer; x, y: INTEGER; s: ARRAY OF CHAR; fnt: Fonts.Font);
	VAR w, h, dsr: INTEGER;
	BEGIN
		WITH P: PSPrinter DO
			(* Don't make more that one page when making eps *)
			IF P.eps & (P.pno > 1) THEN RETURN END;
			SetColor;
			StringSize(s, fnt, w, h, dsr);
			Box(P, x - dsr, y, w, h);
			P.sx := x + w; P.sy := y;

			Int(bodyR, x); Ch(bodyR, " ");
			Int(bodyR, y); Str(bodyR, " m "); ContString(P, s, fnt)
		END
	END String;

	PROCEDURE ReplPattern*(P: Printer.Printer; x, y, w, h, col: INTEGER);
	BEGIN
		WITH P: PSPrinter DO
			(* Don't make more that one page when making eps *)
			IF P.eps & (P.pno > 1) THEN RETURN END;
			SetColor;
			Box(P, x, y, w, h);
			Int(bodyR, x+1); Ch(bodyR, " ");
			Int(bodyR, y); Ch(bodyR, " ");
			Int(bodyR, w-1); Ch(bodyR, " ");
			Int(bodyR, h-1); Ch(bodyR, " ");
			Int(bodyR, col); Str(bodyR, " b"); Ln(bodyR)
		END
	END ReplPattern;

	(* mode is not used *)
	PROCEDURE Picture*(P: Printer.Printer; pict: Pictures.Picture; sx, sy, sw, sh, dx, dy, dw, dh, mode: INTEGER);
	VAR
		x, y: INTEGER;
		n, h0, h1, k, i: INTEGER;
		h: ARRAY 128 OF INTEGER;

		PROCEDURE WColTab(n: INTEGER);
		VAR i, r, g, b: INTEGER;
		BEGIN
			i := 0; WHILE i < n DO Pictures.GetColor(pict, i, r, g, b); Hex2(bodyR, CHR(r)); INC(i) END; Ln(bodyR);
			i := 0; WHILE i < n DO Pictures.GetColor(pict, i, r, g, b); Hex2(bodyR, CHR(g)); INC(i) END; Ln(bodyR);
			i := 0; WHILE i < n DO Pictures.GetColor(pict, i, r, g, b); Hex2(bodyR, CHR(b)); INC(i) END; Ln(bodyR);
		END WColTab;

		PROCEDURE H(n: INTEGER);
		VAR d0, d1: INTEGER;
		BEGIN
			d0 := n MOD 16; IF d0 > 9 THEN INC(d0, 7) END;
			d1 := n DIV 16; IF d1 > 9 THEN INC(d1, 7) END;
			Files.Write(bodyR, CHR(d1+30H)); Files.Write(bodyR, CHR(d0+30H))
		END H;

		PROCEDURE Out;
		BEGIN
			IF n > 0 THEN
				IF n = 1 THEN H(0); H(h[0])
				ELSIF (n = 2) & (h[0] = h[1]) THEN H(81H); H(h[0])
				ELSE H(n-1); i := 0; WHILE i < n DO H(h[i]); INC(i) END
				END;
				n := 0
			END;
			WHILE k > 128 DO H(127+128); H(h0); DEC(k, 128) END;
			H(127+k); H(h0)
		END Out;

	BEGIN
		WITH P: PSPrinter DO
			(* Don't make more that one page when making eps *)
			IF P.eps & (P.pno > 1) THEN RETURN END;
			Box(P, dx, dy, dw, dh);
			Str(bodyR, "gsave ");
			Int(bodyR, dx); Ch(bodyR, " ");
			Int(bodyR, dy);
			Str(bodyR, " translate ");
			Real(bodyR, dw/sw); Ch(bodyR, " "); Real(bodyR, dh/sh); Str(bodyR, " scale ");

			Int(bodyR, sw); Ch(bodyR, " "); Int(bodyR, sh);
			Str(bodyR, " rlepic ");
			WColTab(256);

			y := sy + sh - 1;
			WHILE y >= sy DO
				n := 0; x := sx;
				h0 := Pictures.Get(pict, x, y); INC(x); k := 1;
				WHILE x < sx + sw DO
					h1 := Pictures.Get(pict, x, y); h[n] := h1;
					IF h1 = h0 THEN INC(k)
					ELSE
						IF k < 3 THEN
							IF n + k >= 128 THEN H(127);
								i := 0; WHILE i < n DO H(h[i]); INC(i) END;
								i := 0; WHILE n + i < 128 DO H(h0); INC(i); DEC(k) END;
								n := 0
							END;
							WHILE k > 0 DO DEC(k); h[n] := h0; INC(n) END
						ELSE Out
						END;
						h0 := h1; k := 1
					END;
					INC(x)
				END;
				Out;
				DEC(y); Ln(bodyR)
			END;
			Ln(bodyR);
			Str(bodyR, "grestore "); Ln(bodyR)
		END
	END Picture;

	PROCEDURE Circle*(P: Printer.Printer; x0, y0, r: INTEGER);
	BEGIN
		WITH P: PSPrinter DO
			(* Don't make more that one page when making eps *)
			IF P.eps & (P.pno > 1) THEN RETURN END;
			SetColor;
			Box(P, x0 - r, y0 - r, r * 2, r * 2);
			Int(bodyR, x0); Ch(bodyR, " ");
			Int(bodyR, y0); Ch(bodyR, " ");
			Int(bodyR, r); Ch(bodyR, " ");
			Int(bodyR, r); Str(bodyR, " c");
			Ln(bodyR)
		END
	END Circle;

	PROCEDURE Ellipse*(P: Printer.Printer; x0, y0, a, b: INTEGER);
	BEGIN
		WITH P: PSPrinter DO
			(* Don't make more that one page when making eps *)
			IF P.eps & (P.pno > 1) THEN RETURN END;
			SetColor;
			Box(P, x0 - a, y0 - b, a * 2 , b * 2);
			Int(bodyR, x0); Ch(bodyR, " ");
			Int(bodyR, y0); Ch(bodyR, " ");
			Int(bodyR, a); Ch(bodyR, " ");
			Int(bodyR, b); Str(bodyR, " c");
			Ln(bodyR)
		END
	END Ellipse;

	PROCEDURE Line*(P: Printer.Printer; x0, y0, x1, y1: INTEGER);
	BEGIN
		WITH P: PSPrinter DO
			(* Don't make more that one page when making eps *)
			IF P.eps & (P.pno > 1) THEN RETURN END;
			SetColor;
			Box(P, Min(x0, x1), Min(y0, y1), ABS(x1 - x0), ABS(y1 - y0));
			Int(bodyR, x0); Ch(bodyR, " ");
			Int(bodyR, y0); Ch(bodyR, " ");
			Int(bodyR, x1-x0); Ch(bodyR, " ");
			Int(bodyR, y1-y0); Str(bodyR, " x");
			Ln(bodyR)
		END
	END Line;

	PROCEDURE UseColor*(P: Printer.Printer; red, green, blue: INTEGER);
	BEGIN
		curR := red; curG := green; curB := blue
	END UseColor;

	(* -- Spline computation -- *)

	PROCEDURE SolveTriDiag(VAR a, b, c, y: RealVector; n: INTEGER);
		VAR i: INTEGER; t, tt: REAL;
	BEGIN (*a, b, c of tri-diag matrix T; solve Ty' = y for y', assign y' to y*)
		i := 1;
		WHILE i < n DO t := y[i-1]; y[i] := y[i] - c[i-1]*t; INC(i) END ;
		i := n-1; y[i] := y[i]/a[i];
		WHILE i > 0 DO DEC(i); t := a[i]; tt := b[i]*y[i+1]; y[i] := (y[i] - tt)/t END
	END SolveTriDiag;

	PROCEDURE OpenSpline(VAR x, y, d: RealVector; n: INTEGER);
		VAR i: INTEGER; d1, d2: REAL;
			a, b, c: RealVector;
	BEGIN (*from x, y compute d = y'*)
		b[0] := 1.0/(x[1] - x[0]); a[0] := 2.0*b[0]; c[0] := b[0];
		d1 := (y[1] - y[0])*3.0*b[0]*b[0]; d[0] := d1; i := 1;
		WHILE i < n-1 DO
			b[i] := 1.0/(x[i+1] - x[i]);
			a[i] := 2.0*(c[i-1] + b[i]);
			c[i] := b[i];
			d2 := (y[i+1] - y[i])*3.0*b[i]*b[i];
			d[i] := d1 + d2; d1 := d2; INC(i)
		END ;
		a[i] := 2.0*b[i-1]; d[i] := d1; i := 0;
		WHILE i < n-1 DO c[i] := c[i]/a[i]; a[i+1] := a[i+1] - c[i]*b[i]; INC(i) END ;
		SolveTriDiag(a, b, c, d, n)
	END OpenSpline;

	PROCEDURE ClosedSpline(VAR x, y, d: RealVector; n: INTEGER);
		VAR i: INTEGER; d1, d2, hn, dn: REAL;
			a, b, c, w: RealVector;
	BEGIN (*from x, y compute d = y'*)
		hn := 1.0/(x[n-1] - x[n-2]);
		dn := (y[n-1] - y[n-2])*3.0*hn*hn;
		b[0] := 1.0/(x[1] - x[0]);
		a[0] := 2.0*b[0] + hn;
		c[0] := b[0];
		d1 := (y[1] - y[0])*3.0*b[0]*b[0]; d[0] := dn + d1;
		w[0] := 1.0; i := 1;
		WHILE i < n-2 DO
			b[i] := 1.0/(x[i+1] - x[i]);
			a[i] := 2.0*(c[i-1] + b[i]);
			c[i] := b[i];
			d2 := (y[i+1] - y[i])*3.0*b[i]*b[i]; d[i] := d1 + d2; d1 := d2;
			w[i] := 0; INC(i)
		END ;
		a[i] := 2.0*b[i-1] + hn; d[i] := d1 + dn;
		w[i] := 1.0; i := 0;
		WHILE i < n-2 DO c[i] := c[i]/a[i]; a[i+1] := a[i+1] - c[i]*b[i]; INC(i) END ;
		SolveTriDiag(a, b, c, d, n-1); SolveTriDiag(a, b, c, w, n-1);
		d1 := (d[0] + d[i])/(w[0] + w[i] + x[i+1] - x[i]); i := 0;
		WHILE i < n-1 DO d[i] := d[i] - d1*w[i]; INC(i) END ;
		d[i] := d[0]
	END ClosedSpline;

	PROCEDURE PrintPoly(P: PSPrinter; VAR p, q: Poly; lim: REAL);
		VAR x0, y0, x1, y1, x2, y2, x3, y3: REAL;
			xx0, yy0, xx1, yy1, xx2, yy2, xx3, yy3: LONGINT;

	BEGIN
		x0 := p.d;
		y0 := q.d;
		x1 := x0 + p.c*lim/3.0;
		y1 := y0 + q.c*lim/3.0;
		x2 := x1 + (p.c + p.b*lim)*lim/3.0;
		y2 := y1 + (q.c + q.b*lim)*lim/3.0;
		x3 := x0 + (p.c + (p.b + p.a*lim)*lim)*lim;
		y3 := y0 + (q.c + (q.b + q.a*lim)*lim)*lim;

		xx0 := ENTIER(x0); yy0 := ENTIER(y0); xx1 := ENTIER(x1); yy1 := ENTIER(y1);
		xx2 := ENTIER(x2); yy2 := ENTIER(y2); xx3 := ENTIER(x3); yy3 := ENTIER(y3);

		Int(bodyR, xx1); Ch(bodyR, " ");
		Int(bodyR, yy1); Ch(bodyR, " ");
		Int(bodyR, xx2); Ch(bodyR, " ");
		Box(P, Min(xx1, xx2), Min(yy1, yy2), ABS(xx2-xx1), ABS(yy2-yy1));

		Int(bodyR, yy2); Ch(bodyR, " ");
		Int(bodyR, xx3); Ch(bodyR, " ");
		Box(P, Min(xx2, xx3), Min(yy2, yy3), ABS(xx3-xx2), ABS(yy3-yy2));

		Int(bodyR, yy3); Ch(bodyR, " ");
		Int(bodyR, xx0); Ch(bodyR, " ");
		Int(bodyR, yy0); Str(bodyR, " z");
		Box(P, Min(xx3, xx0), Min(yy3, yy0), ABS(xx0-xx3), ABS(yy0-yy3));

		Ln(bodyR);
	END PrintPoly;

	PROCEDURE Spline*(P: Printer.Printer; x0, y0, n, open: INTEGER; VAR X, Y: ARRAY OF INTEGER);
		VAR i: INTEGER; dx, dy, ds: REAL;
			x, xd, y, yd, s: RealVector;
			p, q: PolyVector;
	BEGIN
		WITH P: PSPrinter DO
			(* Don't make more that one page when making eps *)
			IF P.eps & (P.pno > 1) THEN RETURN END;
			SetColor;
			(*from u, v compute x, y, s*)
			x[0] := X[0] + x0; y[0] := Y[0] + y0; s[0] := 0; i := 1;
			WHILE i < n DO
				x[i] := X[i] + x0; dx := x[i] - x[i-1];
				y[i] := Y[i] + y0; dy := y[i] - y[i-1];
				s[i] := ABS(dx) + ABS(dy) + s[i-1]; INC(i)
			END ;
			IF open = 1 THEN OpenSpline(s, x, xd, n); OpenSpline(s, y, yd, n)
			ELSE ClosedSpline(s, x, xd, n); ClosedSpline(s, y, yd, n)
			END ;
			(*compute coefficients from x, y, xd, yd, s*) i := 0;
			WHILE i < n-1 DO
				ds := 1.0/(s[i+1] - s[i]);
				dx := (x[i+1] - x[i])*ds;
				p[i].a := ds*ds*(xd[i] + xd[i+1] - 2.0*dx);
				p[i].b := ds*(3.0*dx - 2.0*xd[i] -xd[i+1]);
				p[i].c := xd[i];
				p[i].d := x[i];
				p[i].t := s[i];
				dy := ds*(y[i+1] - y[i]);
				q[i].a := ds*ds*(yd[i] + yd[i+1] - 2.0*dy);
				q[i].b := ds*(3.0*dy - 2.0*yd[i] - yd[i+1]);
				q[i].c := yd[i];
				q[i].d := y[i];
				q[i].t := s[i]; INC(i)
			END ;
			p[i].t := s[i]; q[i].t := s[i];
			(*print polynomials*)
			i := 0;
			WHILE i < n-1 DO PrintPoly(P, p[i], q[i], p[i+1].t - p[i].t); INC(i) END
		END
	END Spline;

	PROCEDURE Page*(P: Printer.Printer; nofcopies: INTEGER);
	VAR x, y: LONGINT;
	BEGIN
		WITH P: PSPrinter DO
			ResetColor;
			CASE P.mode OF
				oneup, rotated:
					IF ~P.eps THEN
						Int(bodyR, nofcopies); Str(bodyR, " p"); Ln(bodyR)
					END;
					curFont := -1; INC(P.pno); ppos := Files.Pos(bodyR);
					Str(bodyR, "%%Page: 0 "); Int(bodyR, P.pno); Ln(bodyR);
				|twoup:
					x := 2336 * 3048 DIV P.Unit;
					CASE P.location OF
						| 0: Int(bodyR, x); Str(bodyR, " 0 translate"); Ln(bodyR)
						| 1: Int(bodyR, -x); Str(bodyR, " 0 translate"); Ln(bodyR);
							Int(bodyR, nofcopies); Str(bodyR, " p"); Ln(bodyR);
							curFont := -1; INC(P.pno); ppos := Files.Pos(bodyR);
							Str(bodyR, "%%Page: 0 "); Int(bodyR, P.pno); Ln(bodyR)
					END; (* CASE *)
					P.location := 1-P.location
				|fourup:
					x := 2336 * 3048 DIV P.Unit; y := 3520 * 3048 DIV P.Unit;
					CASE P.location OF
						| 0: Int(bodyR, x); Str(bodyR, " 0 translate"); Ln(bodyR)
						| 1: Int(bodyR, -x); Ch(bodyR, " "); Int(bodyR, -y); Str(bodyR, " translate"); Ln(bodyR)
						| 2: Int(bodyR, x); Str(bodyR, " 0 translate"); Ln(bodyR)
						| 3: Int(bodyR, -x); Ch(bodyR, " "); Int(bodyR, y); Str(bodyR, " translate"); Ln(bodyR);
							Int(bodyR, nofcopies); Str(bodyR, " p"); Ln(bodyR);
							curFont := -1; INC(P.pno); ppos := Files.Pos(bodyR);
							Str(bodyR, "%%Page: 0 "); Int(bodyR, P.pno); Ln(bodyR)
					END; (* CASE *)
					P.location := (P.location+1) MOD 4
			END (* CASE *)
		END
	END Page;

	PROCEDURE Close*(P: Printer.Printer);
		CONST bufSize = 4*1024;
		VAR
			dpi: LONGINT;
			i: INTEGER;
			printR, srcR: Files.Rider; buffer: ARRAY bufSize OF CHAR;
			S: Texts.Scanner;
			R: Texts.Reader; ch: CHAR;
			fontDef: FontDef;
			alias: ARRAY 64 OF CHAR;
	BEGIN
		WITH P: PSPrinter DO
			dpi := 914400 DIV Printer.current.Unit;
			IF (P.mode # oneup) & (P.location # 0) THEN
				Int(bodyR, 1); Str(bodyR, " p"); Ln(bodyR);
				curFont := -1; INC(P.pno); ppos := Files.Pos(bodyR)
			END;
			Files.Set(bodyR, bodyF, ppos);	(*overwrite last %%Page line*)
			Str(bodyR, "%%Trailer         "); Ln(bodyR);
			Str(bodyR, "restore"); Ln(bodyR);	(* page save *)
			Str(bodyR, "restore"); Ln(bodyR);	(* header file save *)

			Files.Set(printR, P.printF, 0);

			IF P.eps & (P.l <= P.r) & (P.b <= P.t) THEN
				Str(printR, "%!PS-Adobe-1.0"); Ln(printR);
				Str(printR, "%%BoundingBox: ");
				Int(printR, 0); Ch(printR, " "); Int(printR, 0); Ch(printR, " ");
				Int(printR, (P.r - P.l + 1)* 72 DIV (914400 DIV P.Unit)); Ch(printR, " "); Int(printR, (P.t - P.b + 1) * 72 DIV (914400 DIV P.Unit)); Ch(printR, " ");
				Ln(printR);
				Str(printR, "%%Creator: ETH Oberon"); Ln(printR);
				Str(printR, "%%EndComments"); Ln(printR);
			END;

			Texts.OpenReader(R, headerT, 0);
			Texts.Read(R, ch);
			WHILE ~R.eot DO
				Files.Write(printR, ch);
				IF ch = 0DX THEN Files.Write(printR, 0AX) END;
				Texts.Read(R, ch)
			END;
			IF P.duplex THEN
				Str(printR, "statusdict /setduplexmode known {statusdict begin true setduplexmode end} if");
				Ln(printR); Ln(printR)
			END;
			Str(printR, "/factor1 ");
			Real(printR, P.Unit/12700.0);
			Str(printR, " def"); Ln(printR);
			Str(printR, "/factor2 ");
			Real(printR, P.Unit/12700.0);
			Str(printR, " def"); Ln(printR); Ln(printR);
			i := 0;
			WHILE i <= fontIndex DO DefineFont(printR, fontTable[i], FALSE); INC(i) END;
			IF fontMapDictN > 0 THEN
				Str(printR, "/FontMapDict "); Int(printR, fontMapDictN); Str(printR, " dict def"); Ln(printR);
				Str(printR, "FontMapDict begin"); Ln(printR);
				fontDef := fontMapDict;
				WHILE fontDef # NIL DO
					Ch(printR, "/"); Str(printR, fontDef.name); Str(printR, " [/");
					IF (fontDef.family = "Syntax") OR (fontDef.family = "Oberon") OR (fontDef.family = "Default") THEN
						Str(printR, "Helvetica");
						CASE fontDef.attr OF
							"I": Str(printR, "-Oblique")
							|"M", "B": Str(printR, "-Bold")
						ELSE
						END;
						Ch(printR, " ");
						Int(printR, fontDef.size*(4*dpi) DIV 300)
						(*Int(printR, (fontDef.size*11+2)*dpi DIV 100)*)
					ELSIF (fontDef.family = "Helvetica") OR (fontDef.family = "Courier") THEN
						Str(printR, fontDef.family);
						CASE fontDef.attr OF
							"I": Str(printR, "-Oblique")
							|"M", "B": Str(printR, "-Bold")
						ELSE
						END;
						Ch(printR, " ");
						Int(printR, fontDef.size*(4*dpi) DIV 300)
					ELSIF fontDef.family = "Times" THEN
						Str(printR, "Times");
						CASE fontDef.attr OF
							"I": Str(printR, "-Italic")
							|"M", "B": Str(printR, "-Bold")
						ELSE
							Str(printR, "-Roman")
						END;
						Ch(printR, " ");
						Int(printR, fontDef.size*(4*dpi) DIV 300)
					ELSE
						buffer := "Printer.PSPrinter."; Strings.Append(buffer, fontDef.family);
						Oberon.OpenScanner (S, buffer);
						IF S.class IN {Texts.Name, Texts.String} THEN
							COPY(S.s, alias); Str(printR, alias)
						ELSE
							Str(printR, fontDef.family)
						END;
						CASE fontDef.attr OF
							"I": Str(printR, "-Italic")
							|"M", "B": Str(printR, "-Bold")
						ELSE
						END;
						Ch(printR, " ");
						Int(printR, fontDef.size*(4*dpi) DIV 300)
					END;
					Str(printR, "] def"); Ln(printR);
					fontDef := fontDef.next
				END;
				Str(printR, "end"); Ln(printR);
				fontMapDict := NIL; fontMapDictN := 0
			END;
			Ln(printR);
			i := 0;
			WHILE i <= fontIndex DO DefineFont(printR, fontTable[i], TRUE); INC(i) END;
			Ln(printR);
			Str(printR, "OberonInit"); Ln(printR); Ln(printR);
			CASE P.mode OF
				oneup:
					(* skip *)
				|twoup:
					Str(printR, "90 rotate"); Ln(printR);
					Str(printR, "0.7071 0.7071 scale"); Ln(printR);
					Str(printR, "0 "); Int(printR, -3520 * 3048 DIV P.Unit); Str(printR, " translate"); Ln(printR)
				|fourup:
					Str(printR, "0.5 0.5 scale"); Ln(printR);
					Str(printR, "0 "); Int(printR, 3520 * 3048 DIV P.Unit); Str(printR, " translate"); Ln(printR)
				|rotated:
					Str(printR, "90 rotate"); Ln(printR);
					Str(printR, "0 "); Int(printR, -2489 * 3048 DIV P.Unit); Str(printR, " translate"); Ln(printR)
			END;
			Str(printR, "save"); Ln(printR); Ln(printR);
			Str(printR, "%%EndProlog"); Ln(printR);
			Str(printR, "%%Page: 0 1"); Ln(printR);

			Ln(printR);

			IF P.eps THEN
				Int(printR, -P.l); Ch(printR, " "); Int(printR, -P.b);
				Str(printR, " translate"); Ln(printR);
			END;

			Files.Set(srcR, bodyF, 0);
			REPEAT Files.ReadBytes(srcR, buffer, bufSize); Files.WriteBytes(printR, buffer, bufSize-srcR.res) UNTIL srcR.eof;
			IF ~P.anonymous THEN Files.Register(P.printF) END;
			P.res := Printer.res;

			Files.Set(bodyR, NIL, 0);
			headerT := NIL; bodyF := NIL
		END
	END Close;

	PROCEDURE GetMetric* (P: Printer.Printer; fnt: Fonts.Font): Fonts.Font;
	VAR name: ARRAY 32 OF CHAR; i: INTEGER; metric: Fonts.Font;
	BEGIN
		COPY(fnt.name, name);
		i := 0; WHILE (name[i] # ".") & (name[i] # 0X) DO INC(i) END;
		(* look for Mdx *)
		name[i] := "."; name[i+1] := "M"; name[i+2] := "d";
		name[i+3] := CHR(30H + 914400 DIV (100 * P.Unit));
		name[i+4] := "."; name[i+5] := "F"; name[i+6] := "n"; name[i+7] := "t";
		name[i+8] := 0X;
		metric := Fonts.This(name);
		IF metric.type = Fonts.substitute THEN metric := NIL END;
		RETURN metric
	END GetMetric;

	PROCEDURE NewPrinter*(): Printer.Printer;
	VAR P: PSPrinter;
	BEGIN
		NEW(P);
		P.gen := "PSPrinter.Install";
		P.InitMetrics := InitMetrics;
		P.Escape := Escape;
		P.Open := Open;
		P.Close := Close;
		P.Page := Page;
		P.ReplConst := ReplConst;
		P.ReplPattern := ReplPattern;
		P.Line := Line;
		P.Circle := Circle;
		P.Ellipse := Ellipse;
		P.Spline := Spline;
		P.Picture := Picture;
		P.UseListFont := UseListFont;
		P.String := String;
		P.ContString := ContString;
		P.UseColor := UseColor;
		P.GetMetric := GetMetric;
		RETURN P
	END NewPrinter;

	PROCEDURE Install*;
	BEGIN
		Printer.Install(NewPrinter());
	END Install;

	PROCEDURE Init;
		VAR class: Objects.Name; size: LONGINT; style: SET;
	BEGIN
		ParseName(Fonts.Default.name, default, size, style, class)
	END Init;

	PROCEDURE Cleanup;
	BEGIN
		IF (Printer.current # NIL) & (Printer.current IS PSPrinter) THEN
			Printer.current := NIL
		END
	END Cleanup;

BEGIN
	hexArray := "0123456789ABCDEF";
	metric := NIL; Init();
	Modules.InstallTermHandler(Cleanup)
END PSPrinter.