Syntax10.Scn.Fnt
Syntax10b.Scn.Fnt
ParcElems
Alloc
Syntax10i.Scn.Fnt
MODULE PSPrinter;
	(* JT 11.5.90, RC 2.7.93,  JS 13.10.94, SHML 12 Jul 95, Amiga RD 30 Oct 95, PSFonts RD 3 Dec  95,
		PSFonts again hG 23 Jan 94, Pictures rewritten RD 24.3.96 *)
	IMPORT SYSTEM, PrinterDriver, Files, Texts, Oberon, Kernel, Amiga, Pictures, Display;
	CONST
		N = 20;
		maxFonts = 64;
		DefaultResolution = 300;
		defaultHeaderFileName = "Oberon.Header.ps";
		CR = 0DX; LF = 0AX;
		NrPSFonts = 3;
		normal=0; bold=1; italic=2; magic=3;
	TYPE
		Name = ARRAY 32 OF CHAR;
		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;
		headerFileName, printFileName: Name;
		fontTable: ARRAY maxFonts OF FontDesc;
		fontIndex, curFont: INTEGER;
		listFont: Name;
		headerF, bodyF: Files.File;
		bodyR: Files.Rider;
		pno, ppos, plen: LONGINT;
		hexArray: ARRAY 17 OF CHAR;
		curR, curG, curB: INTEGER;
		resolution: INTEGER;
		FontsToMap: ARRAY NrPSFonts OF ARRAY 10 OF CHAR;	(* PSFonts know to Oberon.Header.ps *)
		styleNames: ARRAY 4 OF ARRAY 10 OF CHAR;
		recodedPSFonts: ARRAY NrPSFonts OF SET;
	PROCEDURE IncPrintFile(VAR name:ARRAY OF CHAR);
		i:INTEGER;
	BEGIN
		i:=0; WHILE name[i]#0X DO INC(i) END;
a	i-5
a	i-4
.	i-3
p	i-2
s	i-1
		i:=i-4;
		name[i]:=CHR(ORD(name[i])+1);
		IF (name[i]>"z") THEN
			name[i]:="a";
			name[i-1]:=CHR(ORD(name[i-1])+1);
			IF (name[i-1]>"z") THEN
				name[i-1]:="a"
			END
		END
	END IncPrintFile;
	PROCEDURE Append(VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
		VAR i, j: INTEGER; ch: CHAR;
	BEGIN i := 0; j := 0;
		WHILE s1[i] # 0X DO INC(i) END ;
		REPEAT ch := s2[j]; s1[i] := ch; INC(i); INC(j) UNTIL ch = 0X
	END Append;
	PROCEDURE ScanFirst(VAR s: Texts.Scanner);	(* Scan first parameter *)
		VAR sel: Texts.Text; beg, end, time: LONGINT;
	BEGIN
		Texts.OpenScanner(s, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(s);
		IF (s.class = Texts.Char) & (s.line = 0) & (s.c = "^") THEN
			Oberon.GetSelection(sel, beg, end, time);
			IF time >= 0 THEN Texts.OpenScanner(s, sel, beg); Texts.Scan(s) ELSE s.class := Texts.Inval END
		END
	END ScanFirst;
	(* -- 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(ORD("0") + (i DIV j) MOD 10)) END
	END Int;
	PROCEDURE Hex(VAR R: Files.Rider; i: INTEGER);
	BEGIN
		IF i < 10 THEN Ch(R, CHR(i+ORD("0")))
		ELSE Ch(R, CHR(i+(ORD("a")-10)))
		END
	END Hex;
	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 Ln(VAR R: Files.Rider);
	BEGIN
		Ch(R, 0AX)
	END Ln;
	(* -- Font Mapping -- *)
	PROCEDURE SetBitmapFont(VAR fontR, R: Files.Rider; fd: FontDesc; pRes: INTEGER);
		CONST fontFileId = 0DBX;
		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")
			| 155: Str(fontR, "endash")
			| 159: Str(fontR, "hyphen")
			| 171: Str(fontR, "germandbls")
			ELSE
				Str(fontR, "ascii");
				Ch(fontR, CHR(ORD("0") + (m DIV 100) MOD 10));
				Ch(fontR, CHR(ORD("0") + (m DIV 10) MOD 10));
				Ch(fontR, CHR(ORD("0") + 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 = fontFileId 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, " .24 div 0 0 ");
			Str(fontR, "72 "); Int(fontR, pRes); Str(fontR, " div "); Str(fontR, " .24 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);
(* hG/23-Jan-1996
			Str(fontR, "/Encoding 256 array def"); Ln(fontR);
			Str(fontR, "0 1 255 {Encoding exch /.notdef put} for"); Ln(fontR);
			Str(fontR, "Encoding OberonEncoding OberonXEncoding OberonYEncoding /Encoding exch def"); Ln(fontR);
			Ln(fontR);
			Str(fontR, "/Encoding FullOberonEncoding def"); Ln(fontR); Ln(fontR);	(* hG/23-Jan-1996 *)
			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); Ch(fontR, "D");
			Str(fontR, " exch definefont pop");
			Ln(fontR); Ch(fontR, "/"); Str(fontR, fd.name); Str(fontR, " {/"); Str(fontR, fd.name); Str(fontR, "D f} bdef");
			Ln(fontR); Ln(fontR)
		END
	END SetBitmapFont;
	PROCEDURE SetPSFont(VAR R: Files.Rider; n: ARRAY OF CHAR): BOOLEAN;
		VAR PSFont, Pos, Typ, w: INTEGER;
		(* Search for Font in Mapping List *)
		PROCEDURE TestPSFont(VAR Name: ARRAY OF CHAR; VAR PSFont, Pos: INTEGER);
			VAR i, j: INTEGER;
		BEGIN
			FOR i:=0 TO NrPSFonts-1 DO
				j:=-1;
				REPEAT
					INC(j);
					IF FontsToMap[i,j]=CHR(0) THEN Pos:=j; PSFont:=i; RETURN END
				UNTIL Name[j]#FontsToMap[i,j]
			END;
			Pos:=-1
		END TestPSFont;
	BEGIN
		TestPSFont(n, PSFont, Pos);
		IF Pos<0 THEN RETURN FALSE END; (* entry in mapping list ? no => FALSE *)
		w:=0;
		WHILE (ORD(n[Pos])<58) & (ORD(n[Pos])>=48) DO w:=w*10+ORD(n[Pos])-48; INC(Pos) END;
		CASE n[Pos] OF
		| ".": Typ:= normal
		| "b": Typ:= bold
		| "i":  Typ:= italic
		| "m": Typ:= magic
		ELSE
			Typ:= normal
		END;
		IF ~ (Typ IN recodedPSFonts[PSFont]) THEN
			INCL(recodedPSFonts[PSFont], Typ);
			Str(R, "/Ob-"); Str(R, FontsToMap[PSFont]); Str (R, styleNames[Typ]); Str(R, " ");
			Str(R, FontsToMap[PSFont]); Str(R, styleNames[Typ]); Str(R, ".Fnt recode"); Ln(R);
		END;
		Ch(R, "/"); Str(R, n); Str(R, " {/Ob-"); Str(R, FontsToMap[PSFont]); Str (R, styleNames[Typ]); Str(R, " ");
		Int(R, w); Str(R, " "); Str(R, FontsToMap[PSFont]); Str(R, "-ScaleFactor MF} bdef"); Ln(R); Ln(R);
		RETURN TRUE
	END SetPSFont;
	PROCEDURE DefineFont(VAR fontR: Files.Rider; fd: FontDesc);
		VAR name: ARRAY 32 OF CHAR; i, size: INTEGER; VAR f: Files.File; R: Files.Rider;
	BEGIN
		COPY(fd.name, name); i := 0; size := 0;
		WHILE (name[i] # 0X) & (name[i] # ".") & ((name[i] < "0") OR (name[i] > "9")) DO INC(i) END;
		WHILE (name[i] >= "0") & (name[i] <= "9") DO size := size * 10 + ORD(name[i]) - ORD("0"); INC(i) END;
		WHILE (name[i] # 0X) & (name[i] # ".") DO INC(i) END;
		IF (name[i] # ".") OR (name[i+1] # "S") OR (name[i+2] #"c") OR (name[i+3] # "n") THEN
			PrinterDriver.Error(name, " illegal font name")
		ELSE
			name[i+1] := "P"; name[i+2] := "r";  name[i+3] := "3";
			f := Files.Old(name);
			IF f = NIL THEN
				IF ~SetPSFont(fontR, fd.name) THEN PrinterDriver.Error(name, " font missing and can not find PS font") END
			ELSE
				Files.Set(R, f, 0); SetBitmapFont(fontR, R, fd, resolution)
			END
		END
	END DefineFont;
	(* -- Printing Procedures -- *)
	PROCEDURE Open(VAR name, user: ARRAY OF CHAR; password: LONGINT);
	BEGIN
		curR := 0; curG := 0; curB := 0;
		PrinterDriver.res := 0; PrinterDriver.err := FALSE;
		resolution := DefaultResolution; (* COPY(name, printFileName); *)
		i := -1;
		REPEAT INC(i); printFileName[i] := name[i] UNTIL printFileName[i] = 0X;
		resolution := 0; mul := 1;
		LOOP
			DEC(i); ch := name[i];
			IF (i = 0) OR (ch = ".") THEN printFileName[i] := 0X; EXIT END;
			IF ("0" <= ch) & (ch <= "9") THEN INC(resolution, mul*(ORD(ch)-ORD("0"))); mul := 10*mul
			ELSE printFileName[i+1] := 0X; resolution := DefaultResolution; EXIT
			END
		END;
		headerF := Files.Old(headerFileName);
		IF headerF # NIL THEN
			bodyF := Files.New(""); Files.Set(bodyR, bodyF, 0);
			recodedPSFonts[0] := {}; recodedPSFonts[1] := {}; recodedPSFonts[2] := {};
			fontIndex := -1; curFont := -1; listFont := ""; ppos := 0; pno := 1
		ELSE
			PrinterDriver.Error("file not found", headerFileName)
		END
	END Open;
	PROCEDURE UseListFont(VAR name: ARRAY OF CHAR);
	BEGIN
		COPY(name, listFont); curFont := -1
	END UseListFont;
	PROCEDURE ReplConst(x, y, w, h: INTEGER);
	BEGIN
		IF (w > 0) & (h > 0) THEN
			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 ReplConst;
	PROCEDURE ContString(VAR s, fname: ARRAY OF CHAR);
		VAR fNo, i, n: INTEGER; ch: CHAR; family: ARRAY 7 OF CHAR; fontName: ARRAY 32 OF CHAR;
		PROCEDURE Use(ch: CHAR);
		BEGIN
			INCL(fontTable[curFont].used[ORD(ch) DIV 32], ORD(ch) MOD 32)
		END Use;
	BEGIN
		IF fname = listFont THEN fontName := "Courier8.Scn.Fnt" ELSE COPY (fname, fontName) END;
		IF (curFont < 0) OR (fontTable[curFont].name # fontName) THEN
			COPY(fontName, fontTable[fontIndex+1].name);
			i := 0; WHILE i < 8 DO fontTable[fontIndex+1].used[i] := {}; INC(i) END;
			fNo := 0;
			WHILE fontTable[fNo].name # fontName DO INC(fNo) END;
			IF fNo > fontIndex THEN (* DefineFont(fontName); *) fontIndex := fNo END;
			curFont := fNo;
			Str(bodyR, fontTable[curFont].name); Ch(bodyR, " ")
  (* something killed here *)
		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
				IF (ORD(ch) >= 32) & (ORD(ch)  < 127) THEN
					Ch(bodyR, ch)
				ELSE
					Ch(bodyR, "\");
					Ch(bodyR, CHR((ORD(ch) DIV 64) MOD 8 + ORD("0")));
					Ch(bodyR, CHR((ORD(ch) DIV 8) MOD 8 + ORD("0")));
					Ch(bodyR, CHR(ORD(ch) MOD 8 + ORD("0")))
				END;
				Use(ch)
			END ;
			INC(i); ch := s[i]
		END;
		Str(bodyR, ") s"); Ln(bodyR)
	END ContString;
	PROCEDURE String(x, y: INTEGER; VAR s, fname: ARRAY OF CHAR);
	BEGIN
		Int(bodyR, x); Ch(bodyR, " ");
		Int(bodyR, y); Str(bodyR, " m "); ContString(s, fname)
	END String;
	PROCEDURE ReplPattern(x, y, w, h, col: INTEGER);
	BEGIN
		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 ReplPattern;
	(* rewritten by RD 24.3.1996 *)
	PROCEDURE Picture(x, y, w, h, mode: INTEGER; adr: LONGINT);
		VAR
			n, i, z1, z2, v: INTEGER; ch: CHAR;
			P: Pictures.Picture;
			Map: ARRAY 256 OF BOOLEAN;
		PROCEDURE InitMap;
			VAR r, g, b, i: INTEGER;
		BEGIN
			FOR i:=0 TO 255 DO
				Display.GetColor(i, r, g, b);
				Map[i]:=((r+g+b)DIV 3)>Amiga.PictPrintThresh
			END;
		END InitMap;
		(*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;*)
	BEGIN
		InitMap;
		Int(bodyR, x); Ch(bodyR, " ");
		Int(bodyR, y); Ch(bodyR, " ");
		Int(bodyR, w); Ch(bodyR, " ");
		Int(bodyR, h); Ch(bodyR, " ");
		Int(bodyR,mode); Str(bodyR, " i");
		i:=0; n:=(w+7) DIV 8;
		adr:=adr+n*h;
		FOR z1:=0 TO h-1 DO
			adr:=adr-n;
			FOR z2:=0 TO n-1 DO
				SYSTEM.GET(adr+z2, ch); (* ch := Flip(ch); *)
				IF i MOD 40 = 0 THEN Ln(bodyR) END ;
				v := (-ORD(ch)-1) MOD 256;
				Hex(bodyR, v DIV 16); Hex(bodyR, v MOD 16);
				INC(i)
			END
		END ;
		w:=((w+7) DIV 8)*8; Ln(bodyR);
		P:=Pictures.ToPrint;
		FOR z2:=0 TO h-1 DO
			FOR z1:=0 TO w-1 BY 4 DO
				v:=0;
				IF Map[Pictures.Get(P, z1, z2)] THEN INC(v,8) END;
				IF Map[Pictures.Get(P, z1+1, z2)] THEN INC(v,4) END;
				IF Map[Pictures.Get(P, z1+2, z2)] THEN INC(v,2) END;
				IF Map[Pictures.Get(P, z1+4, z2)] THEN INC(v,1) END;
				Hex(bodyR, v);
				INC(i);
				IF i = 80 THEN i:=0; Ln(bodyR) END;
			END;
		END;
		Ln(bodyR)
	END Picture;
	PROCEDURE Circle(x0, y0, r: INTEGER);
	BEGIN
		Int(bodyR, x0); Ch(bodyR, " ");
		Int(bodyR, y0); Ch(bodyR, " ");
		Int(bodyR, r); Ch(bodyR, " ");
		Int(bodyR, r); Str(bodyR, " c");
		Ln(bodyR)
	END Circle;
	PROCEDURE Ellipse(x0, y0, a, b: INTEGER);
	BEGIN
		Int(bodyR, x0); Ch(bodyR, " ");
		Int(bodyR, y0); Ch(bodyR, " ");
		Int(bodyR, a); Ch(bodyR, " ");
		Int(bodyR, b); Str(bodyR, " c");
		Ln(bodyR)
	END Ellipse;
	PROCEDURE Line(x0, y0, x1, y1: INTEGER);
	BEGIN
		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 Line;
	PROCEDURE UseColor(red, green, blue: INTEGER);
	BEGIN
		IF (red # curR) OR (green # curG) OR (blue # curB) THEN
			curR := red; curG := green; curB := blue;
			Int(bodyR, curR); Str(bodyR, " 255 div ");
			Int(bodyR, curG); Str(bodyR, " 255 div ");
			Int(bodyR, curB); Str(bodyR, " 255 div u");
			Ln(bodyR)
		END
	END UseColor;
	(* -- Spline computation -- *)
	PROCEDURE SolveTriDiag(VAR a, b, c, y: RealVector; n: INTEGER);
		VAR i: INTEGER;
	BEGIN (*a, b, c of tri-diag matrix T; solve Ty' = y for y', assign y' to y*)
		i := 1;
		WHILE i < n DO y[i] := y[i] - c[i-1]*y[i-1]; INC(i) END ;
		i := n-1; y[i] := y[i]/a[i];
		WHILE i > 0 DO DEC(i); y[i] := (y[i] - b[i]*y[i+1])/a[i] 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(VAR p, q: Poly; lim: REAL);
		VAR x0, y0, x1, y1, x2, y2, x3, y3: REAL;
	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;
		Int(bodyR, ENTIER(x1)); Ch(bodyR, " ");
		Int(bodyR, ENTIER(y1)); Ch(bodyR, " ");
		Int(bodyR, ENTIER(x2)); Ch(bodyR, " ");
		Int(bodyR, ENTIER(y2)); Ch(bodyR, " ");
		Int(bodyR, ENTIER(x3)); Ch(bodyR, " ");
		Int(bodyR, ENTIER(y3)); Ch(bodyR, " ");
		Int(bodyR, ENTIER(x0)); Ch(bodyR, " ");
		Int(bodyR, ENTIER(y0)); Str(bodyR, " z");
		Ln(bodyR)
	END PrintPoly;
	PROCEDURE Spline(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 (*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[i], q[i], p[i+1].t - p[i].t); INC(i) END
	END Spline;
	PROCEDURE Page(nofcopies: INTEGER);
	BEGIN
		curR := 0; curG := 0; curB := 0;
		Int(bodyR, nofcopies); Str(bodyR, " p"); Ln(bodyR);
		curFont := -1; INC(pno); ppos := Files.Pos(bodyR);
		Str(bodyR, "%%Page: 0 "); Int(bodyR, pno); plen := Files.Pos(bodyR) - ppos; Ln(bodyR)
	END Page;
	PROCEDURE Close;
		CONST bufSize = 4*1024;
		VAR i: INTEGER; printF: Files.File; printR, srcR: Files.Rider; buffer: ARRAY bufSize OF SYSTEM.BYTE;
			cmd: ARRAY 512 OF CHAR;
	BEGIN
		IF ~PrinterDriver.err THEN
			Str(bodyR, "OberonClose"); Ln(bodyR);
			Files.Set(bodyR, bodyF, ppos);	(*overwrite last %%Page line*)
			Str(bodyR, "%%Trailer"); DEC(plen, 9); WHILE plen > 0 DO Ch(bodyR, " "); DEC(plen) END;
			cmd:="t:"; Append(cmd, printFileName);
			printF := Files.New(cmd); Files.Set(printR, printF, 0);
			Str(printR, "%!PS-Adobe- minimal conforming"); Ln(printR);
			Str(printR, "%%Creator: Oberon System V4 for Amiga"); Ln(printR);
			Str(printR, "%"); Ln(printR);
			Str(printR, "% Institute for Computer Systems, ETH Zurich, 1990-1995"); Ln(printR);
			Str(printR, "%"); Ln(printR);
			Files.Set(srcR, headerF, 0); Files.ReadBytes(srcR, buffer, bufSize);
			WHILE ~srcR.eof DO Files.WriteBytes(printR, buffer, bufSize); Files.ReadBytes(srcR, buffer, bufSize) END;
			IF srcR.res # bufSize THEN Files.WriteBytes(printR, buffer, bufSize-srcR.res) END;
			i := 0;
			WHILE i <= fontIndex DO DefineFont(printR, fontTable[i]); INC(i) END;
			Str(printR, "OberonInit"); Ln(printR);
			Str(printR, "save"); Ln(printR);
			Str(printR, "%%EndProlog"); Ln(printR); Ln(printR);
			Str(printR, "%%Page: 0 1"); Ln(printR);
			Files.Set(srcR, bodyF, 0); Files.ReadBytes(srcR, buffer, bufSize);
			WHILE ~srcR.eof DO Files.WriteBytes(printR, buffer, bufSize); Files.ReadBytes(srcR, buffer, bufSize) END;
			IF srcR.res # bufSize THEN Files.WriteBytes(printR, buffer, bufSize-srcR.res) END;
			Files.Register(printF);
			(* Files.Set(bodyR, NIL, 0); *)
			headerF := NIL; bodyF := NIL; printF := NIL;
			Kernel.GC(TRUE); (* Release the file immediately *)
			(*
				NOTE:
					In contrary to the Unix implementation, this one does not itself
					treat none as special file name, nor does it delete the file. Its
					up to the command/script OberonPrint to delete the file when
					it is finished with it.
					This procedure will not terminate unless OberonPrint terminates.
					But OberonPrint may choose to spawn a background process for
					printing and return immediately. This module will cycle through
					more than 600 different print file names, thus there shouldn't be
					a problem with reuse of a file name which has not yet finished to
					print.
			*)
			cmd:=''; Amiga.GetSearchPath(cmd);
			Append(cmd,'Script/OberonPrint "');
			Append(cmd,Amiga.PrinterName);
			Append(cmd,'" "');
			Append(cmd,printFileName);
			Append(cmd,'" PSPrinter');
			Amiga.DosCmd(cmd, "NIL:", i);
			IncPrintFile(printFileName)
		END
	END Close;
	PROCEDURE Init*;
	BEGIN
		PrinterDriver.Open := Open;
		PrinterDriver.UseListFont := UseListFont;
		PrinterDriver.ReplConst := ReplConst;
		PrinterDriver.ContString := ContString;
		PrinterDriver.String := String;
		PrinterDriver.ReplPattern := ReplPattern;
		PrinterDriver.Picture := Picture;
		PrinterDriver.Circle := Circle;
		PrinterDriver.Ellipse := Ellipse;
		PrinterDriver.Line := Line;
		PrinterDriver.UseColor := UseColor;
		PrinterDriver.Spline := Spline;
		PrinterDriver.Page := Page;
		PrinterDriver.Close := Close;
		resolution := DefaultResolution
	END Init;
	PROCEDURE SetHeader*;
		VAR s: Texts.Scanner;
	BEGIN
		ScanFirst(s);
		IF s.class IN {Texts.Name, Texts.String} THEN COPY(s.s, headerFileName) END
	END SetHeader;
BEGIN
	headerFileName := defaultHeaderFileName;
	hexArray := "0123456789ABCDEF";
	resolution := DefaultResolution;
	printFileName:="Oberon.Printfile.aa.ps";
	FontsToMap[0]:="Syntax";	FontsToMap[1]:="Times";	FontsToMap[2]:="Courier";
	styleNames[normal] := ".Roman"; styleNames[bold] := ".Bold";
	styleNames[italic] := ".Italic"; styleNames[magic] := ".Magic"
END PSPrinter.