summaryrefslogtreecommitdiff
path: root/dviware/psprint/unix/pswriter.p
blob: 88c71f270ffb05ba292ae26902fc574b2f523b57 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
(* PSWriter defines PostScript output routines used by PSDVI.
   The output file consists of calls to various PostScript procedures
   defined in a header file prefixed to the output.
   Some of the PostScript procedures expect integer arguments that represent
   page positions in TeX's coordinate system.  Units are in "dots"
   (i.e., device pixels, where resolution defines the number of dots per inch).
   The origin (0,0) is a dot 1 inch in from both the top and left paper edges.
   Horizontal coordinates increase to the right and vertical coordinates
   increase down the page.  The header file contains the necessary matrix
   transformations to convert TeX coordinates back into device coordinates.
*)

#include 'globals.h';
#include 'options.h';
#include 'pswriter.h';

CONST O_RDONLY = 0;        (* SYSDEP: read-only flag for open *)
      maxrbuf = 256;

TYPE rbuf = PACKED ARRAY [1..maxrbuf] OF CHAR;

FUNCTION open (VAR path : string; flags, mode : integer) : integer;   EXTERNAL;
FUNCTION read (f : integer; VAR buf : rbuf; n : integer) : integer;   EXTERNAL;
FUNCTION close(f : integer) : integer;                                EXTERNAL;

VAR
   curh, curv,             (* for SetBitmapChar and SetPostScriptChar *)
   stringlen : INTEGER;    (* ditto; current string length *)
   pendingch : CHAR;       (* ditto; terminates current string *)

(******************************************************************************)

FUNCTION OpenOutput (name : string) : BOOLEAN;

(* Returns TRUE if given file can be opened for output. *)

BEGIN
rewrite(PSfile,name);   (* create a new file and open it for writing *)
OpenOutput := TRUE;     (* assume given file is created *)
END; (* OpenOutput *)

(******************************************************************************)

FUNCTION OutputHeader (name : string) : BOOLEAN;

(* Returns TRUE if given file can be copied to output.
   Returns FALSE if file could not be opened.
*)

VAR f, length, result, buflen : integer;   buf : rbuf;

BEGIN
(* try and open existing file for reading *)
length := Len(name);
IF length < maxstring THEN name[length] := CHR(0);   (* terminate with NULL *)
f := open(name, O_RDONLY, 0);                        (* read only *)
IF length < maxstring THEN name[length] := ' ';      (* restore space *)
IF f >= 0 THEN BEGIN
   (* copy f to PSfile *)
   REPEAT
      buflen := read(f,buf,maxrbuf);
      IF buflen > 0 THEN write(PSfile,buf:buflen);
   UNTIL buflen <= 0;
   result := close(f);
   OutputHeader := TRUE;
END
ELSE
   OutputHeader := FALSE;   (* couldn't open given file *)
END; (* OutputHeader *)

(******************************************************************************)

PROCEDURE BeginPage (DVIpage : INTEGER);

BEGIN
writeln(PSfile,DVIpage:1,' @bop0');
END; (* BeginPage *)

(******************************************************************************)

PROCEDURE NewBitmapFont (VAR fontid : string);

BEGIN
writeln(PSfile,'/',fontid:Len(fontid),' @newfont');
END; (* NewBitmapFont *)

(******************************************************************************)

PROCEDURE OutputPage (DVIpage : INTEGER);

BEGIN
writeln(PSfile,DVIpage:1,' @bop1');
END; (* OutputPage *)

(******************************************************************************)

FUNCTION OutputSpecial (VAR name : string;
                        hpos, vpos : INTEGER) : BOOLEAN;

(* Returns TRUE if given file can be copied to output.
   Returns FALSE if file could not be opened.
   name can also include a space and additional PostScript text that will
   be prefixed to the given file as a separate line.  This allows users to
   include a command like "\special{foo.ps 2 2 scale}" in their TeX source.
   name is declared to be a variable parameter for efficiency reasons.
   hpos and vpos define the page position of the \special command.
   It's a good idea to do all specials on a page BEFORE chars and rules so that
   users can do nifty things like overlaying TeX text onto a shaded box.
*)

LABEL 888, 999;

VAR f, i, j, result, buflen : INTEGER;   buf : rbuf;   fspec : string;

BEGIN
(* check name for optional space (indicating additional PostScript text) *)
i := 0;
fspec := ' ';                  (* SYSDEP: fill with spaces *)
WHILE i < maxstring DO BEGIN
   IF name[i] = ' ' THEN goto 888;
   fspec[i] := name[i];        (* extract file spec from name *)
   i := i + 1;
END;
888:
(* SYSDEP: test if i = 0 otherwise open will succeed and we'll read
   some file (fspec = all spaces) full of mildly interesting junk!
*)
IF i = 0 THEN BEGIN
   OutputSpecial := FALSE; goto 999;
END;
(* try and open existing file for reading *)
IF i < maxstring THEN fspec[i] := CHR(0);   (* terminate with NULL *)
f := open(fspec, O_RDONLY, 0);              (* read only *)
IF i < maxstring THEN fspec[i] := ' ';      (* restore space *)
IF f >= 0 THEN BEGIN
   writeln(PSfile, hpos:1, ' ', vpos:1, ' p');
   writeln(PSfile, '@bsp');
   (* use j to see if there is optional text after file name *)
   j := maxstring - 1;
   WHILE name[j] = ' ' DO j := j - 1;
   j := j + 1;
   IF i < j THEN BEGIN
      (* name[i] is first ' '; skip this and copy rest of name to output *)
      i := i + 1;
      WHILE i < j DO BEGIN
         write(PSfile,name[i]);
         i := i + 1;
      END;
      writeln(PSfile);           (* text becomes first line of file *)
   END;
   (* copy f to PSfile *)
   REPEAT
      buflen := read(f,buf,maxrbuf);
      IF buflen > 0 THEN write(PSfile,buf:buflen);
   UNTIL buflen <= 0;
   result := close(f);
   writeln(PSfile, '@esp');
   OutputSpecial := TRUE;
END
ELSE
   OutputSpecial := FALSE;     (* couldn't open given file *)
999:
END; (* OutputSpecial *)

(******************************************************************************)

PROCEDURE SaveVM (VAR fontid : string);

BEGIN
writeln(PSfile,'/',fontid:Len(fontid),' @saveVM');
END; (* SaveVM *)

(******************************************************************************)

PROCEDURE BeginPostScriptFont (VAR fontname : string;
                               scaledsize, mag : INTEGER);

(* Output PostScript code to scale and set a resident PostScript font.
   The fontname will be the name of a TFM file (beginning with psprefix value).
   This TFM name will need to be converted into a PostScript font name.
   The scaledsize and mag parameters represent the desired size of the font.
*)

BEGIN
(* sp will convert scaled points to dots *)
writeln(PSfile, scaledsize:1, ' sp ', mag:1, ' 1000 div mul ',
        fontname:Len(fontname), ' PSfont');
(* initialize some globals for first SetPostScriptChar in this font *)
curh := 999999999;
curv := 999999999;
stringlen := 0;
pendingch := '?';
END; (* BeginPostScriptFont *)

(******************************************************************************)

PROCEDURE SetPostScriptChar (ch : CHAR; hpos, vpos, pwidth : INTEGER);

(* Similar to SetBitmapChar but we cannot use RELATIVE horizontal positioning
   because the advance widths of characters in a PostScript font are not
   an integral number of dots, and we must avoid accumulated rounding errors.
*)

BEGIN
IF curv = vpos THEN BEGIN      (* don't update v position *)
   IF curh <> hpos THEN BEGIN  (* update h position *)
      stringlen := 0;
      writeln(PSfile,')',pendingch);
      write(PSfile,hpos:1,'(');
      pendingch := 'H';
   END;
END
ELSE BEGIN                     (* update h and v position *)
   IF stringlen > 0 THEN BEGIN
      stringlen := 0;
      writeln(PSfile,')',pendingch);
   END;
   write(PSfile,hpos:1,' ',vpos:1,'(');
   pendingch := 'S';
END;
IF (ch >= ' ') AND (ch < CHR(127)) THEN BEGIN
   IF (ch = '(') OR (ch = ')') OR (ch = '\') THEN   (* prefix (,),\ with \ *)
      write(PSfile,'\',ch)
   ELSE
      write(PSfile,ch);
END
ELSE
   (* put out 3 octal digits representing ch *)
   write(PSfile,'\', CHR(ORD('0') + (ORD(ch) DIV 64)),
                     CHR(ORD('0') + ((ORD(ch) DIV 8) MOD 8)),
                     CHR(ORD('0') + (ORD(ch) MOD 8)) );
(* update current page position and string length for next call *)
curh := hpos + pwidth;
curv := vpos;
stringlen := stringlen + 1;
IF (stringlen MOD 72) = 0 THEN writeln(PSfile,'\');
END; (* SetPostScriptChar *)

(******************************************************************************)

PROCEDURE BeginBitmapFont (VAR fontid : string);

BEGIN
writeln(PSfile,fontid:Len(fontid),' sf');
(* Initialize some globals for first SetBitmapChar in this font.
   This is not relevant when BeginBitmapFont is used before OutputPage.
*)
curh := 999999999;
curv := 999999999;
stringlen := 0;
pendingch := '?';
END; (* BeginBitmapFont *)

(******************************************************************************)

PROCEDURE SetBitmapChar (ch : CHAR; hpos, vpos, pwidth : INTEGER);

BEGIN
IF curv = vpos THEN BEGIN      (* don't update v position *)
   IF curh <> hpos THEN BEGIN  (* update h position (kern or space) *)
      stringlen := 0;
      writeln(PSfile,')',pendingch);
      write(PSfile,hpos-curh:1,'(');
      pendingch := 'h';
   END;
END
ELSE BEGIN                     (* update h and v position *)
   IF stringlen > 0 THEN BEGIN
      stringlen := 0;
      writeln(PSfile,')',pendingch);
   END;
   write(PSfile,hpos:1,' ',vpos:1,'(');
   pendingch := 's';
END;
IF (ch >= ' ') AND (ch < CHR(127)) THEN BEGIN
   IF (ch = '(') OR (ch = ')') OR (ch = '\') THEN   (* prefix (,),\ with \ *)
      write(PSfile,'\',ch)
   ELSE
      write(PSfile,ch);
END
ELSE
   (* put out 3 octal digits representing ch *)
   write(PSfile,'\', CHR(ORD('0') + (ORD(ch) DIV 64)),
                     CHR(ORD('0') + ((ORD(ch) DIV 8) MOD 8)),
                     CHR(ORD('0') + (ORD(ch) MOD 8)) );
(* update current page position and string length for next call *)
curh := hpos + pwidth;
curv := vpos;
stringlen := stringlen + 1;
IF (stringlen MOD 72) = 0 THEN writeln(PSfile,'\');
END; (* SetBitmapChar *)

(******************************************************************************)

PROCEDURE EndFont;

(* Terminate the last "h v(..." or "dh(..." for the current font. *)

BEGIN
IF stringlen > 0 THEN writeln(PSfile,')',pendingch);
END; (* EndFont *)

(******************************************************************************)

PROCEDURE RestoreVM;

BEGIN
writeln(PSfile,'@restoreVM');
END; (* RestoreVM *)

(******************************************************************************)

PROCEDURE SetRule (wd, ht, hpos, vpos : INTEGER);

(* Output some PostScript to set the given rule at the given position. *)

BEGIN
writeln(PSfile, wd:1, ' ', ht:1, ' ', hpos:1, ' ', vpos:1, ' r');
END; (* SetRule *)

(******************************************************************************)

PROCEDURE EndPage (DVIpage : INTEGER);

(* Output some PostScript to end the current page. *)

BEGIN
writeln(PSfile, DVIpage:1, ' @eop');
END; (* EndPage *)

(******************************************************************************)

PROCEDURE CloseOutput;

(* Output some final PostScript. *)

BEGIN
writeln(PSfile, '@end');
(* no need to close PSfile *)
END; (* CloseOutput *)