1MODULE Printer; (*UNIX version: JT 11.5.90, RC 2.7.93, JS 29.4.94, JT 14.4.95 *) 2 3 IMPORT SYSTEM, Files, Platform; 4 5 CONST 6 N = 20; 7 maxFonts = 64; 8 headerFileName = "Oberon.Header.ps"; 9 printFileName = "Oberon.Printfile.ps"; 10 11 TYPE 12 Name = ARRAY 32 OF CHAR; 13 FontDesc = RECORD 14 name: Name; 15 used: ARRAY 8 OF SET; 16 END; 17 RealVector = ARRAY N OF REAL; 18 Poly = RECORD a, b, c, d, t: REAL END ; 19 PolyVector = ARRAY N OF Poly; 20 21 VAR 22 res*: INTEGER; (*0 = done, 1 = not done*) 23 PageWidth*, PageHeight*: INTEGER; 24 fontTable: ARRAY maxFonts OF FontDesc; 25 fontIndex, curFont: INTEGER; 26 PrinterName, listFont: Name; 27 headerF, bodyF: Files.File; 28 bodyR: Files.Rider; 29 pno, ppos: LONGINT; 30 hexArray: ARRAY 17 OF CHAR; 31 curR, curG, curB: INTEGER; 32 PrintMode: ARRAY 3 OF CHAR; (* may be empty, 1: or 2: *) 33 PrintCopies: INTEGER; (* saved nofcopies for printing last page *) 34 35 36 (* -- Output procedures -- *) 37 38 PROCEDURE Ch (VAR R: Files.Rider; ch: CHAR); 39 BEGIN 40 Files.Write(R, ch) 41 END Ch; 42 43 PROCEDURE Str (VAR R: Files.Rider; s: ARRAY OF CHAR); 44 VAR i: INTEGER; 45 BEGIN 46 i := 0; 47 WHILE s[i] # 0X DO Ch(R, s[i]); INC(i) END; 48 END Str; 49 50 PROCEDURE Int (VAR R: Files.Rider; i: LONGINT); 51 VAR j: LONGINT; 52 BEGIN 53 IF i = 0 THEN Ch(R, "0") ELSIF i < 0 THEN i := -i; Ch(R, "-") END; 54 j := 1; 55 WHILE (i DIV j) # 0 DO j := j * 10 END; 56 WHILE j >= 10 DO j := j DIV 10; Ch(R, CHR(ORD("0") + (i DIV j) MOD 10)) END; 57 END Int; 58 59 PROCEDURE Hex(VAR R: Files.Rider; i: INTEGER); 60 BEGIN 61 IF i < 10 THEN Ch(R, CHR(i+ORD("0"))) 62 ELSE Ch(R, CHR(i+(ORD("a")-10))) 63 END 64 END Hex; 65 66 PROCEDURE Hex2(VAR R: Files.Rider; ch: CHAR); 67 BEGIN 68 Ch(R, hexArray[ORD(ch) DIV 16]); 69 Ch(R, hexArray[ORD(ch) MOD 16]); 70 END Hex2; 71 72 PROCEDURE Ln(VAR R: Files.Rider); 73 BEGIN 74 Ch(R, 0AX); 75 END Ln; 76 77 (* -- Error handling -- *) 78 79 PROCEDURE Error(s0, s1: ARRAY OF CHAR); 80 VAR error, f: ARRAY 32 OF CHAR; 81 BEGIN COPY(s0, error); COPY(s1, f); HALT(99) 82 END Error; 83 84 (* -- Font Mapping -- *) 85 86 PROCEDURE SetMappedFont(VAR fontR: Files.Rider; fname: ARRAY OF CHAR); 87 VAR family: ARRAY 7 OF CHAR; 88 BEGIN 89 COPY(fname, family); 90 Ch(fontR, "/"); Str(fontR, fname); 91 IF family = "Syntax" THEN Str(fontR, " DefineSMapFont") ELSE Str(fontR, " DefineMapFont") END; 92 Ln(fontR); Ln(fontR); 93 END SetMappedFont; 94 95 PROCEDURE SetBitmapFont(VAR fontR, R: Files.Rider; fd: FontDesc; pRes: INTEGER); 96 CONST fontFileId = 0DBX; 97 TYPE 98 RunRec = RECORD beg, end: INTEGER END; 99 Metrics = RECORD dx, x, y, w, h: INTEGER END; 100 101 VAR 102 ch: CHAR; 103 pixmapDX, n, b: LONGINT; 104 k, m: INTEGER; 105 height, minX, maxX, minY, maxY: INTEGER; 106 nOfBoxes, nOfRuns: INTEGER; 107 run: ARRAY 16 OF RunRec; 108 metrics: ARRAY 256 OF Metrics; 109 110 PROCEDURE Flip(ch: CHAR): CHAR; 111 VAR i, s, d: INTEGER; 112 BEGIN 113 i := 0; s := ORD(ch); d := 0; 114 WHILE i < 8 DO 115 IF s MOD 2 = 1 THEN d := d * 2 + 1 ELSE d := d * 2 END; 116 s := s DIV 2; 117 INC(i) 118 END; 119 RETURN CHR(d); 120 END Flip; 121 122 PROCEDURE Name(m: INTEGER); 123 BEGIN 124 CASE m OF 125 | 9: Str(fontR, "tab") 126 | 32: Str(fontR, "space") 127 | 33: Str(fontR, "exclam") 128 | 34: Str(fontR, "quotedbl") 129 | 35: Str(fontR, "numbersign") 130 | 36: Str(fontR, "dollar") 131 | 37: Str(fontR, "percent") 132 | 38: Str(fontR, "ampersand") 133 | 39: Str(fontR, "quotesingle") 134 | 40: Str(fontR, "parenleft") 135 | 41: Str(fontR, "parenright") 136 | 42: Str(fontR, "asterisk") 137 | 43: Str(fontR, "plus") 138 | 44: Str(fontR, "comma") 139 | 45: Str(fontR, "minus") 140 | 46: Str(fontR, "period") 141 | 47: Str(fontR, "slash") 142 | 48: Str(fontR, "zero") 143 | 49: Str(fontR, "one") 144 | 50: Str(fontR, "two") 145 | 51: Str(fontR, "three") 146 | 52: Str(fontR, "four") 147 | 53: Str(fontR, "five") 148 | 54: Str(fontR, "six") 149 | 55: Str(fontR, "seven") 150 | 56: Str(fontR, "eight") 151 | 57: Str(fontR, "nine") 152 | 58: Str(fontR, "colon") 153 | 59: Str(fontR, "semicolon") 154 | 60: Str(fontR, "less") 155 | 61: Str(fontR, "equal") 156 | 62: Str(fontR, "greater") 157 | 63: Str(fontR, "question") 158 | 64: Str(fontR, "at") 159 | 65..90: Ch(fontR, CHR(m)) 160 | 91: Str(fontR, "bracketleft") 161 | 92: Str(fontR, "backslash") 162 | 93: Str(fontR, "bracketright") 163 | 94: Str(fontR, "arrowup") 164 | 95: Str(fontR, "underscore") 165 | 96: Str(fontR, "grave") 166 | 97..122: Ch(fontR, CHR(m)) 167 | 123: Str(fontR, "braceleft") 168 | 124: Str(fontR, "bar") 169 | 125: Str(fontR, "braceright") 170 | 126: Str(fontR, "tilde") 171 | 128: Str(fontR, "Adieresis") 172 | 129: Str(fontR, "Odieresis") 173 | 130: Str(fontR, "Udieresis") 174 | 131: Str(fontR, "adieresis") 175 | 132: Str(fontR, "odieresis") 176 | 133: Str(fontR, "udieresis") 177 | 134: Str(fontR, "acircumflex") 178 | 135: Str(fontR, "ecircumflex") 179 | 136: Str(fontR, "icircumflex") 180 | 137: Str(fontR, "oicircumflex") 181 | 138: Str(fontR, "uicircumflex") 182 | 139: Str(fontR, "agrave") 183 | 140: Str(fontR, "egrave") 184 | 141: Str(fontR, "igrave") 185 | 142: Str(fontR, "ograve") 186 | 143: Str(fontR, "ugrave") 187 | 144: Str(fontR, "eacute") 188 | 145: Str(fontR, "edieresis") 189 | 146: Str(fontR, "idieresis") 190 | 147: Str(fontR, "ccedilla") 191 | 148: Str(fontR, "aacute") 192 | 149: Str(fontR, "ntilde") 193 | 155: Str(fontR, "endash") 194 | 159: Str(fontR, "hyphen") 195 | 171: Str(fontR, "germandbls") 196 ELSE 197 Str(fontR, "ascii"); 198 Ch(fontR, CHR(ORD("0") + (m DIV 100) MOD 10)); 199 Ch(fontR, CHR(ORD("0") + (m DIV 10) MOD 10)); 200 Ch(fontR, CHR(ORD("0") + m MOD 10)) 201 END 202 END Name; 203 204 BEGIN 205 Str(fontR, "% Conversion of the Oberon font "); Str(fontR, fd.name); Ln(fontR); 206 Files.Read(R, ch); 207 IF ch = fontFileId THEN 208 Files.Read(R, ch); Str(fontR, "% abstraction: "); Int(fontR, ORD(ch)); 209 Files.Read(R, ch); Str(fontR, ", family: "); Ch(fontR, ch); 210 Files.Read(R, ch); Str(fontR, ", variant: "); Int(fontR, ORD(ch)); Ln(fontR); 211 Files.ReadInt(R, height); Str(fontR, "% height: "); Int(fontR, height); Ln(fontR); Ln(fontR); 212 Files.ReadInt(R, minX); Files.ReadInt(R, maxX); 213 Files.ReadInt(R, minY); Files.ReadInt(R, maxY); 214 Files.ReadInt(R, nOfRuns); 215 nOfBoxes := 0; k := 0; 216 WHILE k # nOfRuns DO 217 Files.ReadInt(R, run[k].beg); Files.ReadInt(R, run[k].end); 218 INC(nOfBoxes, run[k].end - run[k].beg); 219 INC(k) 220 END; 221 Str(fontR, "9 dict begin"); Ln(fontR); Ln(fontR); 222 Str(fontR, "/FontType 3 def"); Ln(fontR); 223 Str(fontR, "/FontMatrix [ 72 "); Int(fontR, pRes); Str(fontR, " div "); Str(fontR, " .24 div 0 0 "); 224 Str(fontR, "72 "); Int(fontR, pRes); Str(fontR, " div "); Str(fontR, " .24 div 0 0"); 225 Str(fontR, "] def"); Ln(fontR); 226 Str(fontR, "/FontBBox ["); 227 Int(fontR, minX); Ch(fontR, " "); 228 Int(fontR, minY); Ch(fontR, " "); 229 Int(fontR, maxX); Ch(fontR, " "); 230 Int(fontR, maxY); 231 Str(fontR, "] def"); Ln(fontR); Ln(fontR); 232 Str(fontR, "/Encoding 256 array def"); Ln(fontR); 233 Str(fontR, "0 1 255 {Encoding exch /.notdef put} for"); Ln(fontR); 234 Str(fontR, "Encoding OberonEncoding /Encoding exch def"); Ln(fontR); 235 Ln(fontR); 236 Str(fontR, "/CharData "); Int(fontR, nOfBoxes+1); 237 Str(fontR, " dict def"); Ln(fontR); 238 Str(fontR, "CharData begin"); Ln(fontR); 239 k := 0; m := 0; 240 WHILE k < nOfRuns DO 241 m := run[k].beg; 242 WHILE m < run[k].end DO 243 Files.ReadInt(R, metrics[m].dx); 244 Files.ReadInt(R, metrics[m].x); Files.ReadInt(R, metrics[m].y); 245 Files.ReadInt(R, metrics[m].w); Files.ReadInt(R, metrics[m].h); 246 INC(m); 247 END; 248 INC(k) 249 END; 250 Str(fontR, "/.notdef"); Str(fontR, " ["); 251 Int(fontR, metrics[32].w); Str(fontR, " 0 0 0 0 1 1 0 0"); Ln(fontR); 252 Str(fontR, "<>] bdef"); Ln(fontR); 253 k := 0; m := 0; 254 WHILE k < nOfRuns DO 255 m := run[k].beg; 256 WHILE m < run[k].end DO 257 IF m MOD 32 IN fd.used[m DIV 32] THEN 258 Str(fontR, "/"); Name(m); Str(fontR, " ["); 259IF m = ORD(" ") THEN 260(* jt, 13.10.95: 261 ugly special case, but some printers (e.g the HP Laser Jet) crash(!) when rotating the coordinate 262 system with the old implementation and there is a blank character beeing downloded*) 263 Str(fontR, "11 0 0 1 1 1 1 0 0 <00"); 264ELSE 265 Int(fontR, metrics[m].dx); Str(fontR, " "); 266 Int(fontR, metrics[m].x); Str(fontR, " "); Int(fontR, metrics[m].y); Str(fontR, " "); 267 Int(fontR, metrics[m].x + metrics[m].w); Str(fontR, " "); 268 Int(fontR, metrics[m].y + metrics[m].h); Str(fontR, " "); 269 IF metrics[m].w > 0 THEN Int(fontR, metrics[m].w); ELSE Int(fontR, 1) END; Str(fontR, " "); 270 IF metrics[m].h > 0 THEN Int(fontR, metrics[m].h); ELSE Int(fontR, 1) END; Str(fontR, " "); 271 Int(fontR, -metrics[m].x); Str(fontR, " "); Int(fontR, -metrics[m].y); Ln(fontR); 272 Str(fontR, "<"); 273 pixmapDX := (metrics[m].w + 7) DIV 8; 274 n := pixmapDX * metrics[m].h; 275 b := 0; 276 WHILE b < n DO 277 Files.Read(R, ch); Hex2(fontR, Flip(ch)); 278 INC(b); 279 IF b MOD 32 = 0 THEN Ln(fontR); Str(fontR, " ") END 280 END; 281END; 282 Str(fontR, ">] bdef"); Ln(fontR); 283 ELSE 284 n := (metrics[m].w + 7) DIV 8 * metrics[m].h; 285 b := 0; WHILE b < n DO Files.Read(R, ch); INC(b) END; 286 END; 287 INC(m); 288 END; 289 INC(k) 290 END; 291 Str(fontR, " end"); Ln(fontR); Ln(fontR); 292 Str(fontR, "/BuildGlyph {GlobalBuildGlyph} bdef"); Ln(fontR); 293 Str(fontR, "/BuildChar {GlobalBuildChar} bdef"); Ln(fontR); Ln(fontR); 294 Str(fontR, "/imageMaskMatrix [1 0 0 1 0 0] bdef"); Ln(fontR); Ln(fontR); 295 Str(fontR, "currentdict"); Ln(fontR); Ln(fontR); 296 Str(fontR, "end"); Ln(fontR); Ln(fontR); 297 Ch(fontR, "/"); Str(fontR, fd.name); 298 Str(fontR, " exch definefont pop"); Ln(fontR); Ln(fontR); 299 END; 300 END SetBitmapFont; 301 302 PROCEDURE DefineFont(VAR fontR: Files.Rider; fd: FontDesc); 303 VAR name: ARRAY 32 OF CHAR; i, size: INTEGER; VAR f: Files.File; R: Files.Rider; 304 BEGIN 305 COPY(fd.name, name); i := 0; size := 0; 306 WHILE (name[i] # 0X) & (name[i] # ".") & ((name[i] < "0") OR (name[i] > "9")) DO INC(i) END; 307 WHILE (name[i] >= "0") & (name[i] <= "9") DO size := size * 10 + ORD(name[i]) - ORD("0"); INC(i) END; 308 WHILE (name[i] # 0X) & (name[i] # ".") DO INC(i) END; 309 IF (name[i] # ".") OR (name[i+1] # "S") OR (name[i+2] # "c") OR (name[i+3] # "n") THEN 310 SetMappedFont (fontR, fd.name); 311 ELSE 312 name[i+1] := "P"; name[i+2] := "r"; name[i+3] := "3"; 313 f := Files.Old(name); 314 IF f = NIL THEN 315 SetMappedFont (fontR, fd.name); 316 ELSE 317 Files.Set(R, f, 0); SetBitmapFont(fontR, R, fd, 300) 318 END; 319 END; 320 END DefineFont; 321 322 (* -- Exported Procedures -- *) 323 324 PROCEDURE Open*(VAR name, user: ARRAY OF CHAR; password: LONGINT); 325 VAR i: INTEGER; 326 BEGIN 327 curR := 0; curG := 0; curB := 0; res := 1; 328 COPY(name, PrinterName); 329 COPY(name, PrintMode); (* shortens implicitly *) 330 IF PrintMode[1] = ":" THEN i := 2; 331 REPEAT PrinterName[i-2] := PrinterName[i]; INC(i) UNTIL PrinterName[i-1] = 0X 332 END ; 333 headerF := Files.Old(headerFileName); 334 IF headerF # NIL THEN 335 bodyF := Files.New(""); Files.Set(bodyR, bodyF, 0); 336 fontIndex := -1; curFont := -1; listFont := ""; ppos := 0; pno := 1; 337 res := 0 338 ELSE 339 Error("file not found", headerFileName) 340 END 341 END Open; 342 343 PROCEDURE UseListFont*(VAR name: ARRAY OF CHAR); 344 BEGIN 345 COPY(name, listFont); curFont := -1 346 END UseListFont; 347 348 PROCEDURE ReplConst*(x, y, w, h: INTEGER); 349 BEGIN 350 IF (w > 0) & (h > 0) THEN 351 Int(bodyR, x); Ch(bodyR, " "); 352 Int(bodyR, y); Ch(bodyR, " "); 353 Int(bodyR, w); Ch(bodyR, " "); 354 Int(bodyR, h); Str(bodyR, " l"); Ln(bodyR); 355 END 356 END ReplConst; 357 358 PROCEDURE ContString*(VAR s, fname: ARRAY OF CHAR); 359 VAR fNo, i, n: INTEGER; ch: CHAR; family: ARRAY 7 OF CHAR; 360 fontname: ARRAY 32 OF CHAR; 361 362 PROCEDURE Use(ch: CHAR); 363 BEGIN 364 INCL(fontTable[curFont].used[ORD(ch) DIV 32], ORD(ch) MOD 32); 365 END Use; 366 367 BEGIN 368 IF fname = listFont THEN fontname := "Courier8.Scn.Fnt" ELSE COPY(fname, fontname) END ; 369 IF (curFont < 0) OR (fontTable[curFont].name # fontname) THEN 370 COPY(fontname, fontTable[fontIndex+1].name); 371 i := 0; WHILE i < 8 DO fontTable[fontIndex+1].used[i] := {}; INC(i) END; 372 fNo := 0; 373 WHILE fontTable[fNo].name # fontname DO INC(fNo) END; 374 IF fNo > fontIndex THEN (* DefineFont(fontname); *) fontIndex := fNo END; 375 curFont := fNo; Ch(bodyR, "("); 376 Str(bodyR, fontTable[curFont].name); 377 Str(bodyR, ") f ") 378 END; 379 Ch(bodyR, "("); 380 i := 0; ch := s[0]; 381 WHILE ch # 0X DO 382 CASE ch OF 383 | "(", ")", "\": Ch(bodyR, "\"); Ch(bodyR, ch); Use(ch); 384 | 9X: Str(bodyR, " "); Use(" ") (* or Str("\tab") *) 385 | 80X..95X, 0ABX: 386 Str(bodyR, "\2"); n := ORD(ch)-128; 387 Ch(bodyR, CHR(n DIV 8 + 48)); Ch(bodyR, CHR(n MOD 8 + 48)); Use(ch) 388 | 9FX: COPY(fontTable[curFont].name, family); 389 IF family = "Courie" THEN Ch(bodyR, " ") ELSE Str(bodyR, " ") END; Use(" "); 390 ELSE 391 Ch(bodyR, ch); Use(ch); 392 END ; 393 INC(i); ch := s[i]; 394 END; 395 Str(bodyR, ") s"); Ln(bodyR) 396 END ContString; 397 398 PROCEDURE String*(x, y: INTEGER; VAR s, fname: ARRAY OF CHAR); 399 BEGIN 400 Int(bodyR, x); Ch(bodyR, " "); 401 Int(bodyR, y); Str(bodyR, " m "); ContString(s, fname) 402 END String; 403 404 PROCEDURE ReplPattern*(x, y, w, h, col: INTEGER); 405 BEGIN 406 Int(bodyR, x); Ch(bodyR, " "); 407 Int(bodyR, y); Ch(bodyR, " "); 408 Int(bodyR, w); Ch(bodyR, " "); 409 Int(bodyR, h); Ch(bodyR, " "); 410 Int(bodyR, col); Str(bodyR, " b"); Ln(bodyR); 411 END ReplPattern; 412 413 PROCEDURE Picture*(x, y, w, h, mode: INTEGER; adr: SYSTEM.ADDRESS); 414 VAR n, i, v: INTEGER; ch: CHAR; 415 BEGIN 416 Int(bodyR, x); Ch(bodyR, " "); 417 Int(bodyR, y); Ch(bodyR, " "); 418 Int(bodyR, w); Ch(bodyR, " "); 419 Int(bodyR, h); Ch(bodyR, " "); 420 Int(bodyR,mode); Str(bodyR, " i"); 421 n := (w + 7) DIV 8 * h; i := 0; 422 WHILE i < n DO 423 SYSTEM.GET(adr+i, ch); 424 IF i MOD 40 = 0 THEN Ln(bodyR); END ; 425 v := (-ORD(ch)-1) MOD 256; 426 Hex(bodyR, v DIV 16); Hex(bodyR, v MOD 16); 427 INC(i) 428 END ; 429 Ln(bodyR); 430 END Picture; 431 432 PROCEDURE Circle*(x0, y0, r: INTEGER); 433 BEGIN 434 Int(bodyR, x0); Ch(bodyR, " "); 435 Int(bodyR, y0); Ch(bodyR, " "); 436 Int(bodyR, r); Ch(bodyR, " "); 437 Int(bodyR, r); Str(bodyR, " c"); 438 Ln(bodyR); 439 END Circle; 440 441 PROCEDURE Ellipse*(x0, y0, a, b: INTEGER); 442 BEGIN 443 Int(bodyR, x0); Ch(bodyR, " "); 444 Int(bodyR, y0); Ch(bodyR, " "); 445 Int(bodyR, a); Ch(bodyR, " "); 446 Int(bodyR, b); Str(bodyR, " c"); 447 Ln(bodyR); 448 END Ellipse; 449 450 PROCEDURE Line*(x0, y0, x1, y1: INTEGER); 451 BEGIN 452 Int(bodyR, x0); Ch(bodyR, " "); 453 Int(bodyR, y0); Ch(bodyR, " "); 454 Int(bodyR, x1-x0); Ch(bodyR, " "); 455 Int(bodyR, y1-y0); Str(bodyR, " x"); 456 Ln(bodyR); 457 END Line; 458 459 PROCEDURE UseColor*(red, green, blue: INTEGER); 460 BEGIN 461 IF (red # curR) OR (green # curG) OR (blue # curB) THEN 462 curR := red; curG := green; curB := blue; 463 Int(bodyR, curR); Str(bodyR, " 255 div "); 464 Int(bodyR, curG); Str(bodyR, " 255 div "); 465 Int(bodyR, curB); Str(bodyR, " 255 div u"); 466 Ln(bodyR); 467 END; 468 END UseColor; 469 470 (* -- Spline computation -- *) 471 472 PROCEDURE SolveTriDiag(VAR a, b, c, y: RealVector; n: INTEGER); 473 VAR i: INTEGER; 474 BEGIN (*a, b, c of tri-diag matrix T; solve Ty' = y for y', assign y' to y*) 475 i := 1; 476 WHILE i < n DO y[i] := y[i] - c[i-1]*y[i-1]; INC(i) END ; 477 i := n-1; y[i] := y[i]/a[i]; 478 WHILE i > 0 DO DEC(i); y[i] := (y[i] - b[i]*y[i+1])/a[i] END 479 END SolveTriDiag; 480 481 PROCEDURE OpenSpline(VAR x, y, d: RealVector; n: INTEGER); 482 VAR i: INTEGER; d1, d2: REAL; 483 a, b, c: RealVector; 484 BEGIN (*from x, y compute d = y'*) 485 b[0] := 1.0/(x[1] - x[0]); a[0] := 2.0*b[0]; c[0] := b[0]; 486 d1 := (y[1] - y[0])*3.0*b[0]*b[0]; d[0] := d1; i := 1; 487 WHILE i < n-1 DO 488 b[i] := 1.0/(x[i+1] - x[i]); 489 a[i] := 2.0*(c[i-1] + b[i]); 490 c[i] := b[i]; 491 d2 := (y[i+1] - y[i])*3.0*b[i]*b[i]; 492 d[i] := d1 + d2; d1 := d2; INC(i) 493 END ; 494 a[i] := 2.0*b[i-1]; d[i] := d1; i := 0; 495 WHILE i < n-1 DO c[i] := c[i]/a[i]; a[i+1] := a[i+1] - c[i]*b[i]; INC(i) END ; 496 SolveTriDiag(a, b, c, d, n) 497 END OpenSpline; 498 499 PROCEDURE ClosedSpline(VAR x, y, d: RealVector; n: INTEGER); 500 VAR i: INTEGER; d1, d2, hn, dn: REAL; 501 a, b, c, w: RealVector; 502 BEGIN (*from x, y compute d = y'*) 503 hn := 1.0/(x[n-1] - x[n-2]); 504 dn := (y[n-1] - y[n-2])*3.0*hn*hn; 505 b[0] := 1.0/(x[1] - x[0]); 506 a[0] := 2.0*b[0] + hn; 507 c[0] := b[0]; 508 d1 := (y[1] - y[0])*3.0*b[0]*b[0]; d[0] := dn + d1; 509 w[0] := 1.0; i := 1; 510 WHILE i < n-2 DO 511 b[i] := 1.0/(x[i+1] - x[i]); 512 a[i] := 2.0*(c[i-1] + b[i]); 513 c[i] := b[i]; 514 d2 := (y[i+1] - y[i])*3.0*b[i]*b[i]; d[i] := d1 + d2; d1 := d2; 515 w[i] := 0; INC(i) 516 END ; 517 a[i] := 2.0*b[i-1] + hn; d[i] := d1 + dn; 518 w[i] := 1.0; i := 0; 519 WHILE i < n-2 DO c[i] := c[i]/a[i]; a[i+1] := a[i+1] - c[i]*b[i]; INC(i) END ; 520 SolveTriDiag(a, b, c, d, n-1); SolveTriDiag(a, b, c, w, n-1); 521 d1 := (d[0] + d[i])/(w[0] + w[i] + x[i+1] - x[i]); i := 0; 522 WHILE i < n-1 DO d[i] := d[i] - d1*w[i]; INC(i) END ; 523 d[i] := d[0] 524 END ClosedSpline; 525 526 PROCEDURE PrintPoly(VAR p, q: Poly; lim: REAL); 527 VAR x0, y0, x1, y1, x2, y2, x3, y3: REAL; 528 BEGIN 529 x0 := p.d; 530 y0 := q.d; 531 x1 := x0 + p.c*lim/3.0; 532 y1 := y0 + q.c*lim/3.0; 533 x2 := x1 + (p.c + p.b*lim)*lim/3.0; 534 y2 := y1 + (q.c + q.b*lim)*lim/3.0; 535 x3 := x0 + (p.c + (p.b + p.a*lim)*lim)*lim; 536 y3 := y0 + (q.c + (q.b + q.a*lim)*lim)*lim; 537 Int(bodyR, ENTIER(x1)); Ch(bodyR, " "); 538 Int(bodyR, ENTIER(y1)); Ch(bodyR, " "); 539 Int(bodyR, ENTIER(x2)); Ch(bodyR, " "); 540 Int(bodyR, ENTIER(y2)); Ch(bodyR, " "); 541 Int(bodyR, ENTIER(x3)); Ch(bodyR, " "); 542 Int(bodyR, ENTIER(y3)); Ch(bodyR, " "); 543 Int(bodyR, ENTIER(x0)); Ch(bodyR, " "); 544 Int(bodyR, ENTIER(y0)); Str(bodyR, " z"); 545 Ln(bodyR); 546 END PrintPoly; 547 548 PROCEDURE Spline*(x0, y0, n, open: INTEGER; VAR X, Y: ARRAY OF INTEGER); 549 VAR i: INTEGER; dx, dy, ds: REAL; 550 x, xd, y, yd, s: RealVector; 551 p, q: PolyVector; 552 BEGIN (*from u, v compute x, y, s*) 553 x[0] := X[0] + x0; y[0] := Y[0] + y0; s[0] := 0; i := 1; 554 WHILE i < n DO 555 x[i] := X[i] + x0; dx := x[i] - x[i-1]; 556 y[i] := Y[i] + y0; dy := y[i] - y[i-1]; 557 s[i] := ABS(dx) + ABS(dy) + s[i-1]; INC(i) 558 END ; 559 IF open = 1 THEN OpenSpline(s, x, xd, n); OpenSpline(s, y, yd, n) 560 ELSE ClosedSpline(s, x, xd, n); ClosedSpline(s, y, yd, n) 561 END ; 562 (*compute coefficients from x, y, xd, yd, s*) i := 0; 563 WHILE i < n-1 DO 564 ds := 1.0/(s[i+1] - s[i]); 565 dx := (x[i+1] - x[i])*ds; 566 p[i].a := ds*ds*(xd[i] + xd[i+1] - 2.0*dx); 567 p[i].b := ds*(3.0*dx - 2.0*xd[i] -xd[i+1]); 568 p[i].c := xd[i]; 569 p[i].d := x[i]; 570 p[i].t := s[i]; 571 dy := ds*(y[i+1] - y[i]); 572 q[i].a := ds*ds*(yd[i] + yd[i+1] - 2.0*dy); 573 q[i].b := ds*(3.0*dy - 2.0*yd[i] - yd[i+1]); 574 q[i].c := yd[i]; 575 q[i].d := y[i]; 576 q[i].t := s[i]; INC(i) 577 END ; 578 p[i].t := s[i]; q[i].t := s[i]; 579 (*print polynomials*) 580 i := 0; 581 WHILE i < n-1 DO PrintPoly(p[i], q[i], p[i+1].t - p[i].t); INC(i) END 582 END Spline; 583 584 PROCEDURE Page*(nofcopies: INTEGER); 585 BEGIN 586 curR := 0; curG := 0; curB := 0; curFont := -1; 587 INC(pno); ppos := Files.Pos(bodyR); PrintCopies := nofcopies; 588 IF PrintMode[1] # ":" THEN 589 Int(bodyR, nofcopies); Str(bodyR, " p"); Ln(bodyR); 590 Str(bodyR, "%%Page: 0 "); Int(bodyR, pno); Ln(bodyR) 591 ELSIF ODD(pno) THEN 592 Int(bodyR, nofcopies); Str(bodyR, " p"); Ln(bodyR); 593 Str(bodyR, "%%Page: 0 "); Int(bodyR, pno DIV 2 + 1); Ln(bodyR); 594 IF PrintMode = "1:" THEN 595 Str(bodyR, "2480 0 translate"); Ln(bodyR) 596 END 597 ELSIF PrintMode = "1:" THEN (* start second A5 page such that the order is 4:1*) 598 Str(bodyR, "-2480 0 translate"); Ln(bodyR) 599 ELSE (* start second A5 page such that the order is 2:3 *) 600 Str(bodyR, "2480 0 translate"); Ln(bodyR) 601 END 602 END Page; 603 604 PROCEDURE Append(VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR); 605 VAR i, j: INTEGER; ch: CHAR; 606 BEGIN i := 0; j := 0; 607 WHILE s1[i] # 0X DO INC(i) END ; 608 REPEAT ch := s2[j]; s1[i] := ch; INC(i); INC(j) UNTIL ch = 0X 609 END Append; 610 611 PROCEDURE Close*; 612 CONST bufSize = 4*1024; 613 VAR 614 cmd: ARRAY 256 OF CHAR; i: INTEGER; 615 printF: Files.File; printR, srcR: Files.Rider; ch: CHAR; buffer: ARRAY bufSize OF SYSTEM.BYTE; 616 BEGIN 617 Files.Set(bodyR, bodyF, ppos); (*overwrite last %%Page line*) 618 Int(bodyR, PrintCopies); Str(bodyR, " p"); Ln(bodyR); 619 Str(bodyR, "%%Trailer "); Ln(bodyR); 620 printF := Files.New(printFileName); Files.Set(printR, printF, 0); 621 IF PrinterName # "none" THEN Files.Write(printR, 4X) (*force reset postscript*) END ; 622 Files.Set(srcR, headerF, 0); 623 REPEAT Files.ReadBytes(srcR, buffer, bufSize); Files.WriteBytes(printR, buffer, bufSize-srcR.res) UNTIL srcR.eof; 624 i := 0; 625 WHILE i <= fontIndex DO DefineFont(printR, fontTable[i]); INC(i) END; 626 Ln(printR); 627 IF PrintMode[1] # ":" THEN 628 Str(printR, "OberonInit"); Ln(printR); Ln(printR) 629 ELSE Str(printR, "OberonInit2"); Ln(printR); Ln(printR) 630 END ; 631 Str(printR, "%%EndProlog"); Ln(printR); 632 Str(printR, "%%Page: 0 1"); Ln(printR); 633 Str(printR, "save"); Ln(printR); Ln(printR); 634 IF PrintMode = "1:" THEN 635 Str(printR, "2480 0 translate"); Ln(printR) 636 END ; 637 Files.Set(srcR, bodyF, 0); 638 REPEAT Files.ReadBytes(srcR, buffer, bufSize); Files.WriteBytes(printR, buffer, bufSize-srcR.res) UNTIL srcR.eof; 639 IF PrinterName # "none" THEN Files.Write(printR, 4X) (*force reset postscript*) END ; 640 Files.Register(printF); 641 IF PrinterName # "none" THEN 642 cmd := "lp -c -s "; 643 IF PrinterName # "Pluto" THEN Append(cmd, "-d "); Append(cmd, PrinterName) END ; 644 Append(cmd, " "); Append(cmd, printFileName); 645 i := Platform.System(cmd); 646 Files.Delete(printFileName, res); 647 END; 648 Files.Set(bodyR, NIL, 0); 649 headerF := NIL; bodyF := NIL; printF := NIL 650 END Close; 651 652BEGIN 653 hexArray := "0123456789ABCDEF"; 654 PageWidth := 2336; PageHeight := 3425 655END Printer. 656