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
|
PACKET font analysis DEFINES find fonttable,
analyze fonts,
analyze indent levels :
INT VAR th index, cmd index, no of params;
TEXT VAR buffer line;
TEXT PROC next type command (FILE VAR f, INT VAR line number, cont pos) :
INT VAR start pos;
TEXT VAR type cmd := "";
search loop;
line number := line no (f);
type cmd
.
search loop :
REP
downety (f, "#type");
IF pattern found
THEN start pos := col (f);
read record (f, buffer line);
IF even number of command delimiters (buffer line, start pos - 1)
THEN extract command (buffer line, start pos, cont pos, type cmd);
col (f, cont pos);
LEAVE search loop
ELSE col (f, start pos + 1)
FI
FI
UNTIL NOT pattern found PER;
cont pos := col (f)
END PROC next type command;
PROC find fonttable (THESAURUS CONST used fonts th, TEXT VAR table name) :
LET old table type = 3009,
new table type = 3100;
TEXT VAR font name;
TEXT CONST users fonttable := fonttable;
INT VAR ds type, fonttable th index;
disable stop;
command dialogue (FALSE);
THESAURUS CONST fonttable th := ALL /"configurator";
try all fonttables;
fonttable (users fonttable);
command dialogue (TRUE);
enable stop;
IF table name = ""
THEN errorstop ("Keine zur Datei passende Fonttabelle gefunden")
FI
.
try all fonttables :
fonttable th index := 0;
get (fonttable th, table name, fonttable th index);
WHILE fonttable th index > 0 REP
fetch (table name, /"configurator");
ds type := type (old (table name));
forget (table name);
IF ds type = old table type COR ds type = new table type
THEN fonttable (table name);
IF is error
THEN put error;
putline ("Fonttabelle `" + table name + "' kann nicht eingestellt werden.");
IF yes ("Abbrechen")
THEN enable stop
ELSE clear error
FI
ELSE IF all used fonts present
THEN LEAVE try all fonttables
FI
FI
FI;
get (fonttable th, table name, fonttable th index)
PER;
table name := ""
.
all used fonts present :
th index := 0;
get (used fonts th, font name, th index);
WHILE th index > 0 REP
IF NOT font exists (font name)
THEN LEAVE all used fonts present WITH FALSE
FI;
get (used fonts th, font name, th index)
PER;
TRUE
END PROC find fonttable;
PROC analyze fonts (FILE VAR f, TEXT VAR fonttable name,
font numbers, INT VAR base font index) :
THESAURUS VAR font th;
TEXT VAR usage, base font;
fonttable name := "";
font numbers := "";
base font index := 0;
collect fonts (f, font th, usage);
IF highest entry (font th) <> 0
THEN analyze users fonts
FI;
.
analyze users fonts :
find fonttable (font th, fonttable name);
TEXT CONST users fonttable := fonttable;
fonttable (fonttable name);
provide font numbers (font th, font numbers, usage, base font);
sort fonts (font numbers);
base font index := pos (font numbers, base font);
IF users fonttable <> ""
THEN fonttable (users fonttable)
FI
END PROC analyze fonts;
PROC analyze fonts (TEXT CONST file name, TEXT VAR fonttable name,
font numbers, INT VAR base font index) :
FILE VAR f := sequential file (modify, file name);
analyze fonts (f, fonttable name, font numbers, base font index)
END PROC analyze fonts;
PROC collect fonts (FILE VAR f, THESAURUS VAR th, TEXT VAR line numbers) :
TEXT VAR cmd, font name, param2;
INT VAR current ln, last ln := 0,
act distance, current font lines,
next pos;
th := empty thesaurus;
line numbers := "";
toline (f, 1);
col (f, 1);
WHILE NOT eof (f) REP
cmd := next type command (f, current ln, next pos);
cout (current ln);
note text lines for last font;
process font cmd
PER
.
note text lines for last font :
IF last ln <> 0
THEN act distance := current ln - last ln;
current font lines := line numbers ISUB th index;
current font lines INCR act distance;
replace (line numbers, th index, current font lines)
FI
.
process font cmd :
analyze command ("type:1.1", cmd, 0, cmd index, no of params,
font name, param2);
IF cmd index = 1
THEN th index := link (th, font name);
IF th index = 0
THEN add new font
FI;
last ln := current ln
FI
.
add new font :
insert (th, font name, th index);
line numbers CAT ""0""0""
END PROC collect fonts;
PROC provide font numbers (THESAURUS CONST fonts th, TEXT VAR font numbers,
line numbers, base font name) :
TEXT VAR font name, font no, old line numbers := line numbers;
font numbers := "";
line numbers := "";
INT VAR font index, line number, last greatest;
th index := 0;
get (fonts th, font name, th index);
WHILE th index > 0 REP
font no := code (font (font name));
font index := pos (font numbers, font no);
IF font index = 0
THEN transfer font
ELSE sum text line number
FI;
get (fonts th, font name, th index)
PER;
determine font with most text
.
transfer font :
font numbers CAT font no;
line numbers CAT (old line numbers ISUB th index)
.
sum text line number :
line number := line numbers ISUB font index;
line number INCR (old line numbers ISUB th index);
replace (line numbers, font index, line number)
.
determine font with most text :
last greatest := 0;
FOR font index FROM 1 UPTO (LENGTH line numbers) DIV 2 REP
line number := line numbers ISUB font index;
IF line number > last greatest
THEN last greatest := line number;
base font name := font numbers SUB font index
FI
PER;
END PROC provide font numbers;
PROC sort fonts (TEXT VAR fonts) :
TEXT VAR font name, spec font;
INT VAR font no, size;
th index := 0;
disable stop;
FILE VAR f := sequential file (output, "fonts");
get font sizes;
sort ("fonts");
restore fonts text;
forget ("fonts", quiet);
enable stop
.
get font sizes :
FOR th index FROM 1 UPTO LENGTH fonts REP
font name := fonts SUB th index;
font no := code (font name);
specify size
PER
.
specify size :
size := (indentation pitch (font no) DIV 2)
* (font height (font no) DIV 2);
rotate (size, 8);
spec font := ""223""223"";
replace (spec font, 1, size);
spec font CAT font name;
putline (f, spec font)
.
restore fonts text :
fonts := "";
input (f);
WHILE NOT eof (f) REP
getline (f, spec font);
font name := spec font SUB 3;
fonts CAT font name
PER
END PROC sort fonts;
PROC analyze indent levels (TEXT CONST file name, TEXT VAR levels string) :
FILE VAR f := sequential file (input, file name);
analyze indent levels (f, levels string);
modify (f)
END PROC analyze indent levels;
PROC analyze indent levels (FILE VAR f, TEXT VAR levels string) :
INT VAR i;
TEXT VAR l, act blanks, current item;
levels string := "";
WHILE NOT eof (f) REP
getline (f, l);
i := pos (l, ""33"", ""255"", 1) - 1;
IF i > 0
THEN act blanks := code (i);
i := 1;
IF not yet remembered
THEN insert act blanks
FI
FI
PER;
modify (f)
.
not yet remembered :
WHILE i <= LENGTH levels string REP
current item := levels string SUB i;
IF current item < act blanks
THEN i INCR 1
ELIF current item = act blanks
THEN LEAVE not yet remembered WITH FALSE
ELSE LEAVE not yet remembered WITH TRUE
FI
PER;
TRUE
.
insert act blanks :
insert char (levels string, act blanks, i)
END PROC analyze indent levels;
END PACKET font analysis;
|
