home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / oberon / system / psprinter.mod (.txt) < prev    next >
Oberon Text  |  1977-12-31  |  27KB  |  755 lines
  1. Syntax10.Scn.Fnt
  2. Syntax10b.Scn.Fnt
  3. ParcElems
  4. Alloc
  5. Syntax10i.Scn.Fnt
  6. MODULE PSPrinter;
  7.     (* 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,
  8.         PSFonts again hG 23 Jan 94, Pictures rewritten RD 24.3.96 *)
  9.     IMPORT SYSTEM, PrinterDriver, Files, Texts, Oberon, Kernel, Amiga, Pictures, Display;
  10.     CONST
  11.         N = 20;
  12.         maxFonts = 64;
  13.         DefaultResolution = 300;
  14.         defaultHeaderFileName = "Oberon.Header.ps";
  15.         CR = 0DX; LF = 0AX;
  16.         NrPSFonts = 3;
  17.         normal=0; bold=1; italic=2; magic=3;
  18.     TYPE
  19.         Name = ARRAY 32 OF CHAR;
  20.         FontDesc = RECORD
  21.             name: Name;
  22.             used: ARRAY 8 OF SET
  23.         END;
  24.         RealVector = ARRAY N OF REAL;
  25.         Poly = RECORD a, b, c, d, t: REAL END ;
  26.         PolyVector = ARRAY N OF Poly;
  27.         headerFileName, printFileName: Name;
  28.         fontTable: ARRAY maxFonts OF FontDesc;
  29.         fontIndex, curFont: INTEGER;
  30.         listFont: Name;
  31.         headerF, bodyF: Files.File;
  32.         bodyR: Files.Rider;
  33.         pno, ppos, plen: LONGINT;
  34.         hexArray: ARRAY 17 OF CHAR;
  35.         curR, curG, curB: INTEGER;
  36.         resolution: INTEGER;
  37.         FontsToMap: ARRAY NrPSFonts OF ARRAY 10 OF CHAR;    (* PSFonts know to Oberon.Header.ps *)
  38.         styleNames: ARRAY 4 OF ARRAY 10 OF CHAR;
  39.         recodedPSFonts: ARRAY NrPSFonts OF SET;
  40.     PROCEDURE IncPrintFile(VAR name:ARRAY OF CHAR);
  41.         i:INTEGER;
  42.     BEGIN
  43.         i:=0; WHILE name[i]#0X DO INC(i) END;
  44. a    i-5
  45. a    i-4
  46. .    i-3
  47. p    i-2
  48. s    i-1
  49.         i:=i-4;
  50.         name[i]:=CHR(ORD(name[i])+1);
  51.         IF (name[i]>"z") THEN
  52.             name[i]:="a";
  53.             name[i-1]:=CHR(ORD(name[i-1])+1);
  54.             IF (name[i-1]>"z") THEN
  55.                 name[i-1]:="a"
  56.             END
  57.         END
  58.     END IncPrintFile;
  59.     PROCEDURE Append(VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
  60.         VAR i, j: INTEGER; ch: CHAR;
  61.     BEGIN i := 0; j := 0;
  62.         WHILE s1[i] # 0X DO INC(i) END ;
  63.         REPEAT ch := s2[j]; s1[i] := ch; INC(i); INC(j) UNTIL ch = 0X
  64.     END Append;
  65.     PROCEDURE ScanFirst(VAR s: Texts.Scanner);    (* Scan first parameter *)
  66.         VAR sel: Texts.Text; beg, end, time: LONGINT;
  67.     BEGIN
  68.         Texts.OpenScanner(s, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(s);
  69.         IF (s.class = Texts.Char) & (s.line = 0) & (s.c = "^") THEN
  70.             Oberon.GetSelection(sel, beg, end, time);
  71.             IF time >= 0 THEN Texts.OpenScanner(s, sel, beg); Texts.Scan(s) ELSE s.class := Texts.Inval END
  72.         END
  73.     END ScanFirst;
  74.     (* -- Output procedures -- *)
  75.     PROCEDURE Ch (VAR R: Files.Rider; ch: CHAR);
  76.     BEGIN Files.Write(R, ch)
  77.     END Ch;
  78.     PROCEDURE Str (VAR R: Files.Rider; s: ARRAY OF CHAR);
  79.         VAR i: INTEGER;
  80.     BEGIN
  81.         i := 0;
  82.         WHILE s[i] # 0X DO Ch(R, s[i]); INC(i) END
  83.     END Str;
  84.     PROCEDURE Int (VAR R: Files.Rider; i: LONGINT);
  85.         VAR j: LONGINT;
  86.     BEGIN
  87.         IF i = 0 THEN Ch(R, "0") ELSIF i < 0 THEN i := -i; Ch(R, "-") END;
  88.         j := 1;
  89.         WHILE (i DIV j) # 0 DO j := j * 10 END;
  90.         WHILE j >= 10 DO j := j DIV 10; Ch(R, CHR(ORD("0") + (i DIV j) MOD 10)) END
  91.     END Int;
  92.     PROCEDURE Hex(VAR R: Files.Rider; i: INTEGER);
  93.     BEGIN
  94.         IF i < 10 THEN Ch(R, CHR(i+ORD("0")))
  95.         ELSE Ch(R, CHR(i+(ORD("a")-10)))
  96.         END
  97.     END Hex;
  98.     PROCEDURE Hex2(VAR R: Files.Rider; ch: CHAR);
  99.     BEGIN
  100.         Ch(R, hexArray[ORD(ch) DIV 16]);
  101.         Ch(R, hexArray[ORD(ch) MOD 16])
  102.     END Hex2;
  103.     PROCEDURE Ln(VAR R: Files.Rider);
  104.     BEGIN
  105.         Ch(R, 0AX)
  106.     END Ln;
  107.     (* -- Font Mapping -- *)
  108.     PROCEDURE SetBitmapFont(VAR fontR, R: Files.Rider; fd: FontDesc; pRes: INTEGER);
  109.         CONST fontFileId = 0DBX;
  110.         TYPE
  111.             RunRec = RECORD beg, end: INTEGER END;
  112.             Metrics = RECORD dx, x, y, w, h: INTEGER END;
  113.         VAR
  114.             ch: CHAR;
  115.             pixmapDX, n, b: LONGINT;
  116.             k, m: INTEGER;
  117.             height, minX, maxX, minY, maxY: INTEGER;
  118.             nOfBoxes, nOfRuns: INTEGER;
  119.             run: ARRAY 16 OF RunRec;
  120.             metrics: ARRAY 256 OF Metrics;
  121.         PROCEDURE Flip(ch: CHAR): CHAR;
  122.             VAR i, s, d: INTEGER;
  123.         BEGIN
  124.             i := 0; s := ORD(ch); d := 0;
  125.             WHILE i < 8 DO
  126.                 IF s MOD 2 = 1 THEN d := d * 2 + 1 ELSE d := d * 2 END;
  127.                 s := s DIV 2;
  128.                 INC(i)
  129.             END;
  130.             RETURN CHR(d)
  131.         END Flip;
  132.         PROCEDURE Name(m: INTEGER);
  133.         BEGIN
  134.             CASE m OF
  135.             | 9: Str(fontR, "tab")
  136.             | 32: Str(fontR, "space")
  137.             | 33: Str(fontR, "exclam")
  138.             | 34: Str(fontR, "quotedbl")
  139.             | 35: Str(fontR, "numbersign")
  140.             | 36: Str(fontR, "dollar")
  141.             | 37: Str(fontR, "percent")
  142.             | 38: Str(fontR, "ampersand")
  143.             | 39: Str(fontR, "quotesingle")
  144.             | 40: Str(fontR, "parenleft")
  145.             | 41: Str(fontR, "parenright")
  146.             | 42: Str(fontR, "asterisk")
  147.             | 43: Str(fontR, "plus")
  148.             | 44: Str(fontR, "comma")
  149.             | 45: Str(fontR, "minus")
  150.             | 46: Str(fontR, "period")
  151.             | 47: Str(fontR, "slash")
  152.             | 48: Str(fontR, "zero")
  153.             | 49: Str(fontR, "one")
  154.             | 50: Str(fontR, "two")
  155.             | 51: Str(fontR, "three")
  156.             | 52: Str(fontR, "four")
  157.             | 53: Str(fontR, "five")
  158.             | 54: Str(fontR, "six")
  159.             | 55: Str(fontR, "seven")
  160.             | 56: Str(fontR, "eight")
  161.             | 57: Str(fontR, "nine")
  162.             | 58: Str(fontR, "colon")
  163.             | 59: Str(fontR, "semicolon")
  164.             | 60: Str(fontR, "less")
  165.             | 61: Str(fontR, "equal")
  166.             | 62: Str(fontR, "greater")
  167.             | 63: Str(fontR, "question")
  168.             | 64: Str(fontR, "at")
  169.             | 65..90: Ch(fontR, CHR(m))
  170.             | 91: Str(fontR, "bracketleft")
  171.             | 92:  Str(fontR, "backslash")
  172.             | 93: Str(fontR, "bracketright")
  173.             | 94: Str(fontR, "arrowup")
  174.             | 95: Str(fontR, "underscore")
  175.             | 96: Str(fontR, "grave")
  176.             | 97..122: Ch(fontR, CHR(m))
  177.             | 123: Str(fontR, "braceleft")
  178.             | 124: Str(fontR, "bar")
  179.             | 125: Str(fontR, "braceright")
  180.             | 126: Str(fontR, "tilde")
  181.             | 128: Str(fontR, "Adieresis")
  182.             | 129: Str(fontR, "Odieresis")
  183.             | 130: Str(fontR, "Udieresis")
  184.             | 131: Str(fontR, "adieresis")
  185.             | 132: Str(fontR, "odieresis")
  186.             | 133: Str(fontR, "udieresis")
  187.             | 134: Str(fontR, "acircumflex")
  188.             | 135: Str(fontR, "ecircumflex")
  189.             | 136: Str(fontR, "icircumflex")
  190.             | 137: Str(fontR, "oicircumflex")
  191.             | 138: Str(fontR, "uicircumflex")
  192.             | 139: Str(fontR, "agrave")
  193.             | 140: Str(fontR, "egrave")
  194.             | 141: Str(fontR, "igrave")
  195.             | 142: Str(fontR, "ograve")
  196.             | 143: Str(fontR, "ugrave")
  197.             | 144: Str(fontR, "eacute")
  198.             | 145: Str(fontR, "edieresis")
  199.             | 146: Str(fontR, "idieresis")
  200.             | 147: Str(fontR, "ccedilla")
  201.             | 148: Str(fontR, "aacute")
  202.             | 149: Str(fontR, "ntilde")
  203.             | 155: Str(fontR, "endash")
  204.             | 159: Str(fontR, "hyphen")
  205.             | 171: Str(fontR, "germandbls")
  206.             ELSE
  207.                 Str(fontR, "ascii");
  208.                 Ch(fontR, CHR(ORD("0") + (m DIV 100) MOD 10));
  209.                 Ch(fontR, CHR(ORD("0") + (m DIV 10) MOD 10));
  210.                 Ch(fontR, CHR(ORD("0") + m MOD 10))
  211.             END
  212.         END Name;
  213.     BEGIN
  214.         Str(fontR, "% Conversion of the Oberon font "); Str(fontR, fd.name); Ln(fontR);
  215.         Files.Read(R, ch);
  216.         IF ch = fontFileId THEN
  217.             Files.Read(R, ch); Str(fontR, "% abstraction: "); Int(fontR, ORD(ch));
  218.             Files.Read(R, ch); Str(fontR, ", family: "); Ch(fontR, ch);
  219.             Files.Read(R, ch); Str(fontR, ", variant: "); Int(fontR, ORD(ch)); Ln(fontR);
  220.             Files.ReadInt(R, height); Str(fontR, "% height: "); Int(fontR, height); Ln(fontR); Ln(fontR);
  221.             Files.ReadInt(R, minX); Files.ReadInt(R, maxX);
  222.             Files.ReadInt(R, minY); Files.ReadInt(R, maxY);
  223.             Files.ReadInt(R, nOfRuns);
  224.             nOfBoxes := 0; k := 0;
  225.             WHILE k # nOfRuns DO
  226.                 Files.ReadInt(R, run[k].beg); Files.ReadInt(R, run[k].end);
  227.                 INC(nOfBoxes, run[k].end - run[k].beg);
  228.                 INC(k)
  229.             END;
  230.             Str(fontR, "9 dict begin"); Ln(fontR); Ln(fontR);
  231.             Str(fontR, "/FontType 3 def"); Ln(fontR);
  232.             Str(fontR, "/FontMatrix [ 72 "); Int(fontR, pRes); Str(fontR, " div "); Str(fontR, " .24 div 0 0 ");
  233.             Str(fontR, "72 "); Int(fontR, pRes); Str(fontR, " div "); Str(fontR, " .24 div 0 0");
  234.             Str(fontR, "] def"); Ln(fontR);
  235.             Str(fontR, "/FontBBox [");
  236.             Int(fontR, minX); Ch(fontR, " ");
  237.             Int(fontR, minY); Ch(fontR, " ");
  238.             Int(fontR, maxX); Ch(fontR, " ");
  239.             Int(fontR, maxY);
  240.             Str(fontR, "] def"); Ln(fontR);
  241. (* hG/23-Jan-1996
  242.             Str(fontR, "/Encoding 256 array def"); Ln(fontR);
  243.             Str(fontR, "0 1 255 {Encoding exch /.notdef put} for"); Ln(fontR);
  244.             Str(fontR, "Encoding OberonEncoding OberonXEncoding OberonYEncoding /Encoding exch def"); Ln(fontR);
  245.             Ln(fontR);
  246.             Str(fontR, "/Encoding FullOberonEncoding def"); Ln(fontR); Ln(fontR);    (* hG/23-Jan-1996 *)
  247.             Str(fontR, "/CharData "); Int(fontR, nOfBoxes+1);
  248.             Str(fontR, " dict def"); Ln(fontR);
  249.             Str(fontR, "CharData begin"); Ln(fontR);
  250.             k := 0; m := 0;
  251.             WHILE k < nOfRuns DO
  252.                 m := run[k].beg;
  253.                 WHILE m < run[k].end DO
  254.                     Files.ReadInt(R, metrics[m].dx);
  255.                     Files.ReadInt(R, metrics[m].x); Files.ReadInt(R, metrics[m].y);
  256.                     Files.ReadInt(R, metrics[m].w); Files.ReadInt(R, metrics[m].h);
  257.                     INC(m)
  258.                 END;
  259.                 INC(k)
  260.             END;
  261.             Str(fontR, "/.notdef"); Str(fontR, " [");
  262.             Int(fontR, metrics[32].w); Str(fontR, " 0 0 0 0 1 1 0 0"); Ln(fontR);
  263.             Str(fontR, "<>] bdef"); Ln(fontR);
  264.             k := 0; m := 0;
  265.             WHILE k < nOfRuns DO
  266.                 m := run[k].beg;
  267.                 WHILE m < run[k].end DO
  268.                     IF m MOD 32 IN fd.used[m DIV 32] THEN
  269.                         Str(fontR, "/"); Name(m); Str(fontR, " [");
  270.                         Int(fontR, metrics[m].dx); Str(fontR, " ");
  271.                         Int(fontR, metrics[m].x); Str(fontR, " "); Int(fontR, metrics[m].y); Str(fontR, " ");
  272.                         Int(fontR, metrics[m].x + metrics[m].w); Str(fontR, " ");
  273.                         Int(fontR, metrics[m].y + metrics[m].h); Str(fontR, " ");
  274.                         IF metrics[m].w > 0 THEN Int(fontR, metrics[m].w) ELSE Int(fontR, 1) END; Str(fontR, " ");
  275.                         IF metrics[m].h > 0 THEN Int(fontR, metrics[m].h) ELSE Int(fontR, 1) END; Str(fontR, " ");
  276.                         Int(fontR, -metrics[m].x); Str(fontR, " "); Int(fontR, -metrics[m].y); Ln(fontR);
  277.                         Str(fontR, "<");
  278.                         pixmapDX := (metrics[m].w + 7) DIV 8;
  279.                         n := pixmapDX * metrics[m].h;
  280.                         b := 0;
  281.                         WHILE b < n DO
  282.                             Files.Read(R, ch); Hex2(fontR, Flip(ch));
  283.                             INC(b);
  284.                             IF b MOD 32 = 0 THEN Ln(fontR); Str(fontR, " ") END
  285.                         END;
  286.                         Str(fontR, ">] bdef"); Ln(fontR)
  287.                     ELSE
  288.                         n := (metrics[m].w + 7) DIV 8 * metrics[m].h;
  289.                         b := 0; WHILE b < n DO Files.Read(R, ch); INC(b) END
  290.                     END;
  291.                     INC(m)
  292.                 END;
  293.                 INC(k)
  294.             END;
  295.             Str(fontR, "  end"); Ln(fontR); Ln(fontR);
  296.             Str(fontR, "/BuildGlyph {GlobalBuildGlyph} bdef"); Ln(fontR);
  297.             Str(fontR, "/BuildChar {GlobalBuildChar} bdef"); Ln(fontR); Ln(fontR);
  298.             Str(fontR, "/imageMaskMatrix [1 0 0 1 0 0] bdef"); Ln(fontR); Ln(fontR);
  299.             Str(fontR, "currentdict"); Ln(fontR); Ln(fontR);
  300.             Str(fontR, "end"); Ln(fontR); Ln(fontR);
  301.             Ch(fontR, "/"); Str(fontR, fd.name); Ch(fontR, "D");
  302.             Str(fontR, " exch definefont pop");
  303.             Ln(fontR); Ch(fontR, "/"); Str(fontR, fd.name); Str(fontR, " {/"); Str(fontR, fd.name); Str(fontR, "D f} bdef");
  304.             Ln(fontR); Ln(fontR)
  305.         END
  306.     END SetBitmapFont;
  307.     PROCEDURE SetPSFont(VAR R: Files.Rider; n: ARRAY OF CHAR): BOOLEAN;
  308.         VAR PSFont, Pos, Typ, w: INTEGER;
  309.         (* Search for Font in Mapping List *)
  310.         PROCEDURE TestPSFont(VAR Name: ARRAY OF CHAR; VAR PSFont, Pos: INTEGER);
  311.             VAR i, j: INTEGER;
  312.         BEGIN
  313.             FOR i:=0 TO NrPSFonts-1 DO
  314.                 j:=-1;
  315.                 REPEAT
  316.                     INC(j);
  317.                     IF FontsToMap[i,j]=CHR(0) THEN Pos:=j; PSFont:=i; RETURN END
  318.                 UNTIL Name[j]#FontsToMap[i,j]
  319.             END;
  320.             Pos:=-1
  321.         END TestPSFont;
  322.     BEGIN
  323.         TestPSFont(n, PSFont, Pos);
  324.         IF Pos<0 THEN RETURN FALSE END; (* entry in mapping list ? no => FALSE *)
  325.         w:=0;
  326.         WHILE (ORD(n[Pos])<58) & (ORD(n[Pos])>=48) DO w:=w*10+ORD(n[Pos])-48; INC(Pos) END;
  327.         CASE n[Pos] OF
  328.         | ".": Typ:= normal
  329.         | "b": Typ:= bold
  330.         | "i":  Typ:= italic
  331.         | "m": Typ:= magic
  332.         ELSE
  333.             Typ:= normal
  334.         END;
  335.         IF ~ (Typ IN recodedPSFonts[PSFont]) THEN
  336.             INCL(recodedPSFonts[PSFont], Typ);
  337.             Str(R, "/Ob-"); Str(R, FontsToMap[PSFont]); Str (R, styleNames[Typ]); Str(R, " ");
  338.             Str(R, FontsToMap[PSFont]); Str(R, styleNames[Typ]); Str(R, ".Fnt recode"); Ln(R);
  339.         END;
  340.         Ch(R, "/"); Str(R, n); Str(R, " {/Ob-"); Str(R, FontsToMap[PSFont]); Str (R, styleNames[Typ]); Str(R, " ");
  341.         Int(R, w); Str(R, " "); Str(R, FontsToMap[PSFont]); Str(R, "-ScaleFactor MF} bdef"); Ln(R); Ln(R);
  342.         RETURN TRUE
  343.     END SetPSFont;
  344.     PROCEDURE DefineFont(VAR fontR: Files.Rider; fd: FontDesc);
  345.         VAR name: ARRAY 32 OF CHAR; i, size: INTEGER; VAR f: Files.File; R: Files.Rider;
  346.     BEGIN
  347.         COPY(fd.name, name); i := 0; size := 0;
  348.         WHILE (name[i] # 0X) & (name[i] # ".") & ((name[i] < "0") OR (name[i] > "9")) DO INC(i) END;
  349.         WHILE (name[i] >= "0") & (name[i] <= "9") DO size := size * 10 + ORD(name[i]) - ORD("0"); INC(i) END;
  350.         WHILE (name[i] # 0X) & (name[i] # ".") DO INC(i) END;
  351.         IF (name[i] # ".") OR (name[i+1] # "S") OR (name[i+2] #"c") OR (name[i+3] # "n") THEN
  352.             PrinterDriver.Error(name, " illegal font name")
  353.         ELSE
  354.             name[i+1] := "P"; name[i+2] := "r";  name[i+3] := "3";
  355.             f := Files.Old(name);
  356.             IF f = NIL THEN
  357.                 IF ~SetPSFont(fontR, fd.name) THEN PrinterDriver.Error(name, " font missing and can not find PS font") END
  358.             ELSE
  359.                 Files.Set(R, f, 0); SetBitmapFont(fontR, R, fd, resolution)
  360.             END
  361.         END
  362.     END DefineFont;
  363.     (* -- Printing Procedures -- *)
  364.     PROCEDURE Open(VAR name, user: ARRAY OF CHAR; password: LONGINT);
  365.     BEGIN
  366.         curR := 0; curG := 0; curB := 0;
  367.         PrinterDriver.res := 0; PrinterDriver.err := FALSE;
  368.         resolution := DefaultResolution; (* COPY(name, printFileName); *)
  369.         i := -1;
  370.         REPEAT INC(i); printFileName[i] := name[i] UNTIL printFileName[i] = 0X;
  371.         resolution := 0; mul := 1;
  372.         LOOP
  373.             DEC(i); ch := name[i];
  374.             IF (i = 0) OR (ch = ".") THEN printFileName[i] := 0X; EXIT END;
  375.             IF ("0" <= ch) & (ch <= "9") THEN INC(resolution, mul*(ORD(ch)-ORD("0"))); mul := 10*mul
  376.             ELSE printFileName[i+1] := 0X; resolution := DefaultResolution; EXIT
  377.             END
  378.         END;
  379.         headerF := Files.Old(headerFileName);
  380.         IF headerF # NIL THEN
  381.             bodyF := Files.New(""); Files.Set(bodyR, bodyF, 0);
  382.             recodedPSFonts[0] := {}; recodedPSFonts[1] := {}; recodedPSFonts[2] := {};
  383.             fontIndex := -1; curFont := -1; listFont := ""; ppos := 0; pno := 1
  384.         ELSE
  385.             PrinterDriver.Error("file not found", headerFileName)
  386.         END
  387.     END Open;
  388.     PROCEDURE UseListFont(VAR name: ARRAY OF CHAR);
  389.     BEGIN
  390.         COPY(name, listFont); curFont := -1
  391.     END UseListFont;
  392.     PROCEDURE ReplConst(x, y, w, h: INTEGER);
  393.     BEGIN
  394.         IF (w > 0) & (h > 0) THEN
  395.             Int(bodyR, x+1); Ch(bodyR, " ");
  396.             Int(bodyR, y);  Ch(bodyR, " ");
  397.             Int(bodyR, w-1); Ch(bodyR, " ");
  398.             Int(bodyR, h-1); Str(bodyR, " l"); Ln(bodyR)
  399.         END
  400.     END ReplConst;
  401.     PROCEDURE ContString(VAR s, fname: ARRAY OF CHAR);
  402.         VAR fNo, i, n: INTEGER; ch: CHAR; family: ARRAY 7 OF CHAR; fontName: ARRAY 32 OF CHAR;
  403.         PROCEDURE Use(ch: CHAR);
  404.         BEGIN
  405.             INCL(fontTable[curFont].used[ORD(ch) DIV 32], ORD(ch) MOD 32)
  406.         END Use;
  407.     BEGIN
  408.         IF fname = listFont THEN fontName := "Courier8.Scn.Fnt" ELSE COPY (fname, fontName) END;
  409.         IF (curFont < 0) OR (fontTable[curFont].name # fontName) THEN
  410.             COPY(fontName, fontTable[fontIndex+1].name);
  411.             i := 0; WHILE i < 8 DO fontTable[fontIndex+1].used[i] := {}; INC(i) END;
  412.             fNo := 0;
  413.             WHILE fontTable[fNo].name # fontName DO INC(fNo) END;
  414.             IF fNo > fontIndex THEN (* DefineFont(fontName); *) fontIndex := fNo END;
  415.             curFont := fNo;
  416.             Str(bodyR, fontTable[curFont].name); Ch(bodyR, " ")
  417.   (* something killed here *)
  418.         END;
  419.         Ch(bodyR, "(");
  420.         i := 0; ch := s[0];
  421.         WHILE ch # 0X DO
  422.             CASE ch OF
  423.             | "(", ")", "\": Ch(bodyR, "\"); Ch(bodyR, ch); Use(ch)
  424.             | 9X: Str(bodyR, "  "); Use(" ")    (* or Str("\tab") *)
  425.             | 80X..95X, 0ABX:
  426.                 Str(bodyR, "\2"); n := ORD(ch)-128;
  427.                 Ch(bodyR, CHR(n DIV 8 + 48)); Ch(bodyR, CHR(n MOD 8 + 48)); Use(ch)
  428.             | 9FX: COPY(fontTable[curFont].name, family);
  429.                 IF family = "Courie" THEN Ch(bodyR, " ") ELSE Str(bodyR, "  ") END; Use(" ")
  430.             ELSE
  431.                 IF (ORD(ch) >= 32) & (ORD(ch)  < 127) THEN
  432.                     Ch(bodyR, ch)
  433.                 ELSE
  434.                     Ch(bodyR, "\");
  435.                     Ch(bodyR, CHR((ORD(ch) DIV 64) MOD 8 + ORD("0")));
  436.                     Ch(bodyR, CHR((ORD(ch) DIV 8) MOD 8 + ORD("0")));
  437.                     Ch(bodyR, CHR(ORD(ch) MOD 8 + ORD("0")))
  438.                 END;
  439.                 Use(ch)
  440.             END ;
  441.             INC(i); ch := s[i]
  442.         END;
  443.         Str(bodyR, ") s"); Ln(bodyR)
  444.     END ContString;
  445.     PROCEDURE String(x, y: INTEGER; VAR s, fname: ARRAY OF CHAR);
  446.     BEGIN
  447.         Int(bodyR, x); Ch(bodyR, " ");
  448.         Int(bodyR, y); Str(bodyR, " m "); ContString(s, fname)
  449.     END String;
  450.     PROCEDURE ReplPattern(x, y, w, h, col: INTEGER);
  451.     BEGIN
  452.         Int(bodyR, x+1); Ch(bodyR, " ");
  453.         Int(bodyR, y); Ch(bodyR, " ");
  454.         Int(bodyR, w-1); Ch(bodyR, " ");
  455.         Int(bodyR, h-1); Ch(bodyR, " ");
  456.         Int(bodyR, col); Str(bodyR, " b"); Ln(bodyR)
  457.     END ReplPattern;
  458.     (* rewritten by RD 24.3.1996 *)
  459.     PROCEDURE Picture(x, y, w, h, mode: INTEGER; adr: LONGINT);
  460.         VAR
  461.             n, i, z1, z2, v: INTEGER; ch: CHAR;
  462.             P: Pictures.Picture;
  463.             Map: ARRAY 256 OF BOOLEAN;
  464.         PROCEDURE InitMap;
  465.             VAR r, g, b, i: INTEGER;
  466.         BEGIN
  467.             FOR i:=0 TO 255 DO
  468.                 Display.GetColor(i, r, g, b);
  469.                 Map[i]:=((r+g+b)DIV 3)>Amiga.PictPrintThresh
  470.             END;
  471.         END InitMap;
  472.         (*PROCEDURE Flip(ch: CHAR): CHAR;
  473.             VAR i, s, d: INTEGER;
  474.         BEGIN
  475.             i := 0; s := ORD(ch); d := 0;
  476.             WHILE i < 8 DO
  477.                 IF s MOD 2 = 1 THEN d := d * 2 + 1 ELSE d := d * 2 END;
  478.                 s := s DIV 2;
  479.                 INC(i)
  480.             END;
  481.             RETURN CHR(d)
  482.         END Flip;*)
  483.     BEGIN
  484.         InitMap;
  485.         Int(bodyR, x); Ch(bodyR, " ");
  486.         Int(bodyR, y); Ch(bodyR, " ");
  487.         Int(bodyR, w); Ch(bodyR, " ");
  488.         Int(bodyR, h); Ch(bodyR, " ");
  489.         Int(bodyR,mode); Str(bodyR, " i");
  490.         i:=0; n:=(w+7) DIV 8;
  491.         adr:=adr+n*h;
  492.         FOR z1:=0 TO h-1 DO
  493.             adr:=adr-n;
  494.             FOR z2:=0 TO n-1 DO
  495.                 SYSTEM.GET(adr+z2, ch); (* ch := Flip(ch); *)
  496.                 IF i MOD 40 = 0 THEN Ln(bodyR) END ;
  497.                 v := (-ORD(ch)-1) MOD 256;
  498.                 Hex(bodyR, v DIV 16); Hex(bodyR, v MOD 16);
  499.                 INC(i)
  500.             END
  501.         END ;
  502.         w:=((w+7) DIV 8)*8; Ln(bodyR);
  503.         P:=Pictures.ToPrint;
  504.         FOR z2:=0 TO h-1 DO
  505.             FOR z1:=0 TO w-1 BY 4 DO
  506.                 v:=0;
  507.                 IF Map[Pictures.Get(P, z1, z2)] THEN INC(v,8) END;
  508.                 IF Map[Pictures.Get(P, z1+1, z2)] THEN INC(v,4) END;
  509.                 IF Map[Pictures.Get(P, z1+2, z2)] THEN INC(v,2) END;
  510.                 IF Map[Pictures.Get(P, z1+4, z2)] THEN INC(v,1) END;
  511.                 Hex(bodyR, v);
  512.                 INC(i);
  513.                 IF i = 80 THEN i:=0; Ln(bodyR) END;
  514.             END;
  515.         END;
  516.         Ln(bodyR)
  517.     END Picture;
  518.     PROCEDURE Circle(x0, y0, r: INTEGER);
  519.     BEGIN
  520.         Int(bodyR, x0); Ch(bodyR, " ");
  521.         Int(bodyR, y0); Ch(bodyR, " ");
  522.         Int(bodyR, r); Ch(bodyR, " ");
  523.         Int(bodyR, r); Str(bodyR, " c");
  524.         Ln(bodyR)
  525.     END Circle;
  526.     PROCEDURE Ellipse(x0, y0, a, b: INTEGER);
  527.     BEGIN
  528.         Int(bodyR, x0); Ch(bodyR, " ");
  529.         Int(bodyR, y0); Ch(bodyR, " ");
  530.         Int(bodyR, a); Ch(bodyR, " ");
  531.         Int(bodyR, b); Str(bodyR, " c");
  532.         Ln(bodyR)
  533.     END Ellipse;
  534.     PROCEDURE Line(x0, y0, x1, y1: INTEGER);
  535.     BEGIN
  536.         Int(bodyR, x0); Ch(bodyR, " ");
  537.         Int(bodyR, y0); Ch(bodyR, " ");
  538.         Int(bodyR, x1-x0); Ch(bodyR, " ");
  539.         Int(bodyR, y1-y0); Str(bodyR, " x");
  540.         Ln(bodyR)
  541.     END Line;
  542.     PROCEDURE UseColor(red, green, blue: INTEGER);
  543.     BEGIN
  544.         IF (red # curR) OR (green # curG) OR (blue # curB) THEN
  545.             curR := red; curG := green; curB := blue;
  546.             Int(bodyR, curR); Str(bodyR, " 255 div ");
  547.             Int(bodyR, curG); Str(bodyR, " 255 div ");
  548.             Int(bodyR, curB); Str(bodyR, " 255 div u");
  549.             Ln(bodyR)
  550.         END
  551.     END UseColor;
  552.     (* -- Spline computation -- *)
  553.     PROCEDURE SolveTriDiag(VAR a, b, c, y: RealVector; n: INTEGER);
  554.         VAR i: INTEGER;
  555.     BEGIN (*a, b, c of tri-diag matrix T; solve Ty' = y for y', assign y' to y*)
  556.         i := 1;
  557.         WHILE i < n DO y[i] := y[i] - c[i-1]*y[i-1]; INC(i) END ;
  558.         i := n-1; y[i] := y[i]/a[i];
  559.         WHILE i > 0 DO DEC(i); y[i] := (y[i] - b[i]*y[i+1])/a[i] END
  560.     END SolveTriDiag;
  561.     PROCEDURE OpenSpline(VAR x, y, d: RealVector; n: INTEGER);
  562.         VAR i: INTEGER; d1, d2: REAL;
  563.             a, b, c: RealVector;
  564.     BEGIN (*from x, y compute d = y'*)
  565.         b[0] := 1.0/(x[1] - x[0]); a[0] := 2.0*b[0]; c[0] := b[0];
  566.         d1 := (y[1] - y[0])*3.0*b[0]*b[0]; d[0] := d1; i := 1;
  567.         WHILE i < n-1 DO
  568.             b[i] := 1.0/(x[i+1] - x[i]);
  569.             a[i] := 2.0*(c[i-1] + b[i]);
  570.             c[i] := b[i];
  571.             d2 := (y[i+1] - y[i])*3.0*b[i]*b[i];
  572.             d[i] := d1 + d2; d1 := d2; INC(i)
  573.         END ;
  574.         a[i] := 2.0*b[i-1]; d[i] := d1; i := 0;
  575.         WHILE i < n-1 DO c[i] := c[i]/a[i]; a[i+1] := a[i+1] - c[i]*b[i]; INC(i) END ;
  576.         SolveTriDiag(a, b, c, d, n)
  577.     END OpenSpline;
  578.     PROCEDURE ClosedSpline(VAR x, y, d: RealVector; n: INTEGER);
  579.         VAR i: INTEGER; d1, d2, hn, dn: REAL;
  580.             a, b, c, w: RealVector;
  581.     BEGIN (*from x, y compute d = y'*)
  582.         hn := 1.0/(x[n-1] - x[n-2]);
  583.         dn := (y[n-1] - y[n-2])*3.0*hn*hn;
  584.         b[0] := 1.0/(x[1] - x[0]);
  585.         a[0] := 2.0*b[0] + hn;
  586.         c[0] := b[0];
  587.         d1 := (y[1] - y[0])*3.0*b[0]*b[0]; d[0] := dn + d1;
  588.         w[0] := 1.0; i := 1;
  589.         WHILE i < n-2 DO
  590.             b[i] := 1.0/(x[i+1] - x[i]);
  591.             a[i] := 2.0*(c[i-1] + b[i]);
  592.             c[i] := b[i];
  593.             d2 := (y[i+1] - y[i])*3.0*b[i]*b[i]; d[i] := d1 + d2; d1 := d2;
  594.             w[i] := 0; INC(i)
  595.         END ;
  596.         a[i] := 2.0*b[i-1] + hn; d[i] := d1 + dn;
  597.         w[i] := 1.0; i := 0;
  598.         WHILE i < n-2 DO c[i] := c[i]/a[i]; a[i+1] := a[i+1] - c[i]*b[i]; INC(i) END ;
  599.         SolveTriDiag(a, b, c, d, n-1); SolveTriDiag(a, b, c, w, n-1);
  600.         d1 := (d[0] + d[i])/(w[0] + w[i] + x[i+1] - x[i]); i := 0;
  601.         WHILE i < n-1 DO d[i] := d[i] - d1*w[i]; INC(i) END ;
  602.         d[i] := d[0]
  603.     END ClosedSpline;
  604.     PROCEDURE PrintPoly(VAR p, q: Poly; lim: REAL);
  605.         VAR x0, y0, x1, y1, x2, y2, x3, y3: REAL;
  606.     BEGIN
  607.         x0 := p.d;
  608.         y0 := q.d;
  609.         x1 := x0 + p.c*lim/3.0;
  610.         y1 := y0 + q.c*lim/3.0;
  611.         x2 := x1 + (p.c + p.b*lim)*lim/3.0;
  612.         y2 := y1 + (q.c + q.b*lim)*lim/3.0;
  613.         x3 := x0 + (p.c + (p.b + p.a*lim)*lim)*lim;
  614.         y3 := y0 + (q.c + (q.b + q.a*lim)*lim)*lim;
  615.         Int(bodyR, ENTIER(x1)); Ch(bodyR, " ");
  616.         Int(bodyR, ENTIER(y1)); Ch(bodyR, " ");
  617.         Int(bodyR, ENTIER(x2)); Ch(bodyR, " ");
  618.         Int(bodyR, ENTIER(y2)); Ch(bodyR, " ");
  619.         Int(bodyR, ENTIER(x3)); Ch(bodyR, " ");
  620.         Int(bodyR, ENTIER(y3)); Ch(bodyR, " ");
  621.         Int(bodyR, ENTIER(x0)); Ch(bodyR, " ");
  622.         Int(bodyR, ENTIER(y0)); Str(bodyR, " z");
  623.         Ln(bodyR)
  624.     END PrintPoly;
  625.     PROCEDURE Spline(x0, y0, n, open: INTEGER; VAR X, Y: ARRAY OF INTEGER);
  626.         VAR i: INTEGER; dx, dy, ds: REAL;
  627.             x, xd, y, yd, s: RealVector;
  628.             p, q: PolyVector;
  629.     BEGIN (*from u, v compute x, y, s*)
  630.         x[0] := X[0] + x0; y[0] := Y[0] + y0; s[0] := 0; i := 1;
  631.         WHILE i < n DO
  632.             x[i] := X[i] + x0; dx := x[i] - x[i-1];
  633.             y[i] := Y[i] + y0; dy := y[i] - y[i-1];
  634.             s[i] := ABS(dx) + ABS(dy) + s[i-1]; INC(i)
  635.         END ;
  636.         IF open = 1 THEN OpenSpline(s, x, xd, n); OpenSpline(s, y, yd, n)
  637.         ELSE ClosedSpline(s, x, xd, n); ClosedSpline(s, y, yd, n)
  638.         END ;
  639.         (*compute coefficients from x, y, xd, yd, s*)  i := 0;
  640.         WHILE i < n-1 DO
  641.             ds := 1.0/(s[i+1] - s[i]);
  642.             dx := (x[i+1] - x[i])*ds;
  643.             p[i].a := ds*ds*(xd[i] + xd[i+1] - 2.0*dx);
  644.             p[i].b := ds*(3.0*dx - 2.0*xd[i] -xd[i+1]);
  645.             p[i].c := xd[i];
  646.             p[i].d := x[i];
  647.             p[i].t := s[i];
  648.             dy := ds*(y[i+1] - y[i]);
  649.             q[i].a := ds*ds*(yd[i] + yd[i+1] - 2.0*dy);
  650.             q[i].b := ds*(3.0*dy - 2.0*yd[i] - yd[i+1]);
  651.             q[i].c := yd[i];
  652.             q[i].d := y[i];
  653.             q[i].t := s[i]; INC(i)
  654.         END ;
  655.         p[i].t := s[i]; q[i].t := s[i];
  656.         (*print polynomials*)
  657.         i := 0;
  658.         WHILE i < n-1 DO PrintPoly(p[i], q[i], p[i+1].t - p[i].t); INC(i) END
  659.     END Spline;
  660.     PROCEDURE Page(nofcopies: INTEGER);
  661.     BEGIN
  662.         curR := 0; curG := 0; curB := 0;
  663.         Int(bodyR, nofcopies); Str(bodyR, " p"); Ln(bodyR);
  664.         curFont := -1; INC(pno); ppos := Files.Pos(bodyR);
  665.         Str(bodyR, "%%Page: 0 "); Int(bodyR, pno); plen := Files.Pos(bodyR) - ppos; Ln(bodyR)
  666.     END Page;
  667.     PROCEDURE Close;
  668.         CONST bufSize = 4*1024;
  669.         VAR i: INTEGER; printF: Files.File; printR, srcR: Files.Rider; buffer: ARRAY bufSize OF SYSTEM.BYTE;
  670.             cmd: ARRAY 512 OF CHAR;
  671.     BEGIN
  672.         IF ~PrinterDriver.err THEN
  673.             Str(bodyR, "OberonClose"); Ln(bodyR);
  674.             Files.Set(bodyR, bodyF, ppos);    (*overwrite last %%Page line*)
  675.             Str(bodyR, "%%Trailer"); DEC(plen, 9); WHILE plen > 0 DO Ch(bodyR, " "); DEC(plen) END;
  676.             cmd:="t:"; Append(cmd, printFileName);
  677.             printF := Files.New(cmd); Files.Set(printR, printF, 0);
  678.             Str(printR, "%!PS-Adobe- minimal conforming"); Ln(printR);
  679.             Str(printR, "%%Creator: Oberon System V4 for Amiga"); Ln(printR);
  680.             Str(printR, "%"); Ln(printR);
  681.             Str(printR, "% Institute for Computer Systems, ETH Zurich, 1990-1995"); Ln(printR);
  682.             Str(printR, "%"); Ln(printR);
  683.             Files.Set(srcR, headerF, 0); Files.ReadBytes(srcR, buffer, bufSize);
  684.             WHILE ~srcR.eof DO Files.WriteBytes(printR, buffer, bufSize); Files.ReadBytes(srcR, buffer, bufSize) END;
  685.             IF srcR.res # bufSize THEN Files.WriteBytes(printR, buffer, bufSize-srcR.res) END;
  686.             i := 0;
  687.             WHILE i <= fontIndex DO DefineFont(printR, fontTable[i]); INC(i) END;
  688.             Str(printR, "OberonInit"); Ln(printR);
  689.             Str(printR, "save"); Ln(printR);
  690.             Str(printR, "%%EndProlog"); Ln(printR); Ln(printR);
  691.             Str(printR, "%%Page: 0 1"); Ln(printR);
  692.             Files.Set(srcR, bodyF, 0); Files.ReadBytes(srcR, buffer, bufSize);
  693.             WHILE ~srcR.eof DO Files.WriteBytes(printR, buffer, bufSize); Files.ReadBytes(srcR, buffer, bufSize) END;
  694.             IF srcR.res # bufSize THEN Files.WriteBytes(printR, buffer, bufSize-srcR.res) END;
  695.             Files.Register(printF);
  696.             (* Files.Set(bodyR, NIL, 0); *)
  697.             headerF := NIL; bodyF := NIL; printF := NIL;
  698.             Kernel.GC(TRUE); (* Release the file immediately *)
  699.             (*
  700.                 NOTE:
  701.                     In contrary to the Unix implementation, this one does not itself
  702.                     treat none as special file name, nor does it delete the file. Its
  703.                     up to the command/script OberonPrint to delete the file when
  704.                     it is finished with it.
  705.                     This procedure will not terminate unless OberonPrint terminates.
  706.                     But OberonPrint may choose to spawn a background process for
  707.                     printing and return immediately. This module will cycle through
  708.                     more than 600 different print file names, thus there shouldn't be
  709.                     a problem with reuse of a file name which has not yet finished to
  710.                     print.
  711.             *)
  712.             cmd:=''; Amiga.GetSearchPath(cmd);
  713.             Append(cmd,'Script/OberonPrint "');
  714.             Append(cmd,Amiga.PrinterName);
  715.             Append(cmd,'" "');
  716.             Append(cmd,printFileName);
  717.             Append(cmd,'" PSPrinter');
  718.             Amiga.DosCmd(cmd, "NIL:", i);
  719.             IncPrintFile(printFileName)
  720.         END
  721.     END Close;
  722.     PROCEDURE Init*;
  723.     BEGIN
  724.         PrinterDriver.Open := Open;
  725.         PrinterDriver.UseListFont := UseListFont;
  726.         PrinterDriver.ReplConst := ReplConst;
  727.         PrinterDriver.ContString := ContString;
  728.         PrinterDriver.String := String;
  729.         PrinterDriver.ReplPattern := ReplPattern;
  730.         PrinterDriver.Picture := Picture;
  731.         PrinterDriver.Circle := Circle;
  732.         PrinterDriver.Ellipse := Ellipse;
  733.         PrinterDriver.Line := Line;
  734.         PrinterDriver.UseColor := UseColor;
  735.         PrinterDriver.Spline := Spline;
  736.         PrinterDriver.Page := Page;
  737.         PrinterDriver.Close := Close;
  738.         resolution := DefaultResolution
  739.     END Init;
  740.     PROCEDURE SetHeader*;
  741.         VAR s: Texts.Scanner;
  742.     BEGIN
  743.         ScanFirst(s);
  744.         IF s.class IN {Texts.Name, Texts.String} THEN COPY(s.s, headerFileName) END
  745.     END SetHeader;
  746. BEGIN
  747.     headerFileName := defaultHeaderFileName;
  748.     hexArray := "0123456789ABCDEF";
  749.     resolution := DefaultResolution;
  750.     printFileName:="Oberon.Printfile.aa.ps";
  751.     FontsToMap[0]:="Syntax";    FontsToMap[1]:="Times";    FontsToMap[2]:="Courier";
  752.     styleNames[normal] := ".Roman"; styleNames[bold] := ".Bold";
  753.     styleNames[italic] := ".Italic"; styleNames[magic] := ".Magic"
  754. END PSPrinter.
  755.