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
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
|
PACKET fonts routines
(**************************************************************************
***** Verwaltung der Schriftfontstabelle ** Author : R. Nolting *****
***** Benoetigt von allen Druckertreibern ** Version: 0.1 / 3.5.82 *****
***** ** Version: 1.0 / 8.6.82 *****
***** ** Version: 2.0 / 1. 8. 82 *****
***** Schrittweite in x und y in Tabelle ** Version: 3.0 / 1. 9. 83 *****
***** Zeilenhoehe in cm ** Version: 3.1 / 2. 4. 84 *****
**************************************************************************)
DEFINES
load font table,
get font,
list fonts,
inch,
current font number,
lf height of current font,
x factor per inch,
y factor per inch:
LET max fonts = 8;
LET max nr points = 4;
LET PRINTTYPE = STRUCT (INT x steps per inch, y steps per inch,
ROW max nr points INT point size,
TEXT name, pitch table, codetable);
ROW max fonts PRINTTYPE VAR font;
FILE VAR font file;
INT VAR font number := 1, point number := 1;
TEXT VAR record := " ",
symb;
INT VAR i;
REAL CONST inch := 2.54;
INT PROC x factor per inch:
x step
END PROC x factor per inch;
INT PROC y factor per inch:
lf
END PROC y factor per inch;
REAL PROC lf height of current font:
real(point (point number)) * inch / real (lf) (* 9.1.84 Nolting *)
END PROC lf height of current font;
INT PROC current font number:
font number
END PROC current font number;
(*******************************************************************
********* Setzen und Liefern von Schriftsaetzen ******
*******************************************************************)
PROC init font:
FOR font number FROM 1 UPTO max fonts REP;
lf := 1;
x step := 1;
FOR point number FROM 1 UPTO max nr points REP
point(point number) := 1;
PER;
kode := "";
name := "";
pitch:= "";
PER;
END PROC init font;
(******************************************************************)
PROC list fonts:
line;
FOR font number FROM 1 UPTO max fonts REP
IF name <> "" AND name <> " "
THEN put typ name
FI;
line;
PER;
font number := 1; point number := 1;
.
put typ name:
put (font number); put (".");
put ("'"); put (name); put ("'");
IF length (pitch) > 1
THEN put ("proportional mit Blankbreite"); put (code (pitch SUB 32))
ELSE put ("fest mit Blankbreite"); put (code (pitch));
FI;
put ("und Zeilenhoehe"); put (point (1));
END PROC list fonts;
BOOL PROC font is in table (TEXT CONST name of font):
record := name of font;
changeall (record, " ","");
IF record = ""
THEN font number := 1; TRUE
ELSE search through the table
FI
.
search through the table:
(* der Name des gewuenschten Types darf noch ein angehaengtes Attribut haben *)
FOR font number FROM 1 UPTO max fonts REPEAT
IF pos (record, name) = 1
THEN LEAVE search through the table WITH TRUE
FI;
PER;
font number := 1;
FALSE
ENDPROC font is in table;
PROC get font (TEXT VAR name of font,
TEXT VAR font pitch table, font code table,
BOOL VAR success):
INT VAR lf size := 0;
get font (name of font, lf size,
font pitch table, font code table, success);
replace (font pitch table, 10, code(lfsize));
END PROC get font;
PROC get font (TEXT VAR name of font, INT VAR size,
TEXT VAR font pitch table, font code table,
BOOL VAR success):
success := font is in table (name of font);
name of font := name;
(* hiermit wird eine Ueberpruefung 'alter Typ = neuer Typ'
im aufrufenden Programm ermoeglicht *)
font code table := kode;
font pitch table := pitch;
point number := max nr points;
WHILE point (point number) <> size REP
point number DECR 1;
UNTIL point number = 1 PER;
size := point (point number);
IF size = point (1)
THEN font pitch table := pitch;
LEAVE get font
ELSE font pitch table := ""
FI;
INT VAR j := point (1);
FOR i FROM 1 UPTO length (pitch) REP
font pitch table CAT code(code (pitch SUB i) * size DIV j)
PER;
END PROC get font;
LET tag = 1 ,
bold = 2 ,
number = 3 ,
string = 4 , (* = text; aber PROC text wird benoetigt *)
operator = 5 ,
delimiter = 6 ,
end of file = 7 ,
within comment = 8 ,
within text = 9 ;
PROC load font table (TEXT CONST font file name):
BOOL VAR prop font;
INT VAR type of symbol := 0;
REAL VAR blank in cm ,
lf in cm;
REAL VAR width, inch factor;
INT VAR factor width;
enable stop;
IF NOT exists (font file name)
THEN errorstop ("Fontdatei nicht vorhanden")
FI;
font file := sequential file (input, font file name);
init font;
font number := 0;
getline (font file, record);
protline (record);
WHILE NOT eof (font file) REP
font number INCR 1;
get font name and parameters;
get char width and output function;
UNTIL eof (font file) COR font number >= max fonts PER;
font number := 1; point number := 1;
.
get font name and parameters:
get font name;
get fixed or prop;
get blank width;
get linefeed height;
get pointsizes;
get optional x steps per inch;
fill pitch and code table with default;
.
get font name:
next entry; prot (symb);
IF (symb SUB 1) = "#"
THEN symb := subtext (symb, 2);
WHILE (symb SUB length(symb)) <> "#" REP
name CAT symb;
next entry; prot (symb);
IF symb = ""
THEN errorstop ("# fehlt beim Fontnamen");
FI;
PER;
name CAT subtext (symb, 1, length (symb)-1)
ELSE error stop ("1. Symbol kein Fontname")
FI;
.
get fixed or prop:
next entry;
prop font := (symb SUB 1) = "p" OR (symb SUB 1) = "P";
prot (symb);
.
get blank width:
next entry;
blank in cm := real (symb);
IF NOT last conversion ok COR blank in cm < 0.01
THEN errorstop ("Blankbreite falsch")
FI;
prot ("Blank=");prot (symb);
.
get linefeed height:
next entry;
lf in cm := real (symb);
IF NOT last conversion ok COR lf in cm < 0.01
THEN errorstop ("Linefeedhoehe falsch")
FI;
prot ("lf="); prot(symb);
.
get pointsizes:
next entry;
IF symb <> "("
THEN protline ("alle Pointgroessen = 1 per Voreinstellung") ;
LEAVE get pointsizes
FI;
protline(" "); prot ("lf in punkten=");
get one lf size;
lf := int (inch * real (point (1))/ lf in cm + 0.5);
.
get one lf size:
FOR i FROM 1 UPTO max nr points REP
next entry;
IF symb = ")"
THEN LEAVE get one lf size
ELIF symb = ""
THEN errorstop ("Pointangaben unvollstaendig")
FI;
point(i) := int (symb);
IF NOT last conversion ok COR point (i) < 1
THEN errorstop ("Pointgroesse falsch")
FI;
prot (symb); prot (",");
PER;
.
get optional x steps per inch:
IF symb = ")"
THEN next entry FI;
IF symb = ""
THEN width := 1.0
ELSE width := real (symb)
FI;
x step := int (inch * width / blank in cm + 0.5);
factor width := int (width + 0.5);
IF NOT last conversion ok COR x step < 1
THEN errorstop ("minimale Schritte falsch")
FI;
protline(" "); prot ("Schritte pro Inch="); prot (text(x step)); prot(","); prot (text(lf)); protline(" ");
.
fill pitch and code table with default:
IF prop font
THEN pitch := 255 * code (factor width)
ELSE pitch := code (factor width)
FI;
kode := 31 * ""0"";
kode CAT 224 * ""1""; (* print all *)
inch factor := real (x step)
.
get char width and output function:
WHILE NOT eof (font file) REP
getline (font file, record);
protline (record);
IF (record SUB 1) = "#" AND pos (record, "#", 2, length (record)) > 2
THEN LEAVE get char width and output function
FI;
get internal code for char;
IF char code > 0 AND char code <= 255
THEN IF prop font
THEN get char width;
prot (text(factor width));
replace (pitch, char code, code (factor width))
FI;
get output function
FI;
PER;
.
get internal code for char:
INT VAR char code;
next entry; prot (symb);
IF length(symb) = 1
THEN char code := code (symb SUB 1)
ELIF symb >= "000" AND symb <= "255"
THEN char code := int (symb);
IF NOT last conversion ok
THEN errorstop ("Zeichen falsch")
FI
ELSE errorstop ("Zeichen falsch")
FI;
.
get char width:
next entry;
IF pos (symb, ".") > 0
THEN width := real (symb);
factor width := int (round(((width * inch factor) / inch), 0))
ELSE factor width := int (symb)
FI;
IF NOT last conversion ok
THEN errorstop ("Breitenangabe falsch")
FI
.
get output function:
next entry; prot (symb); protline(" ");
IF symb = ""
THEN symb := "1"
FI;
replace (kode, char code, code (int (symb)));
IF NOT last conversion ok
THEN errorstop ("Ausgabefunktion falsch")
FI;
END PROC load font table;
PROC next entry:
INT VAR next blank pos;
WHILE (record SUB 1) = " " REP
record := subtext (record, 2, length (record)) PER;
next blank pos := pos (record, " ");
IF next blank pos >= 1
THEN symb := subtext (record, 1, next blank pos - 1);
record := subtext (record, next blank pos + 1)
ELSE symb := record;
record := ""
FI;
END PROC next entry;
PROC prot (TEXT CONST t):
IF online
THEN put (t)
FI;
END PROC prot;
PROC protline (TEXT CONST t):
IF online
THEN putline (t)
FI;
END PROC protline;
init font; (* PACKET Initialisierung ******************************)
.
name: font[font number].name
.
pitch: font[font number].pitch table
.
kode: font [font number].code table
.
lf: font [fontnumber].y steps per inch
.
x step: font [font number].x steps per inch
.
point: font [font number].point size
.
END PACKET fonts routines;
|
