summaryrefslogtreecommitdiff
path: root/systems/tex-extensions/clasen/hz/hz.ch
blob: b2b2d9f6f505684bb86c8c260e7bb04be8d4f932 (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
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
@x
{hz int_pars go here}
@y
@d hz_state_code=80
@z

@x
@d error_context_lines==int_par(error_context_lines_code)
@y
@d hz_state==int_par(hz_state_code)
@d hz_en==(hz_state>0)
@d error_context_lines==int_par(error_context_lines_code)
@z

@x
error_context_lines_code:print_esc("errorcontextlines");
@y
error_context_lines_code:print_esc("errorcontextlines");
hz_state_code:print_esc("hzstate");
@z

@x
primitive("errorcontextlines",assign_int,int_base+error_context_lines_code);@/
@!@:error_context_lines_}{\.{\\errorcontextlines} primitive@>
@y
primitive("errorcontextlines",assign_int,int_base+error_context_lines_code);@/
@!@:error_context_lines_}{\.{\\errorcontextlines} primitive@>
primitive("hzstate",assign_int,int_base+hz_state_code);@/
@!@:hz_state_}{\.{\\hzstate} primitive@>
@z

@x
escape_char:="\"; end_line_char:=carriage_return;
@y
escape_char:="\"; end_line_char:=carriage_return;
hz_state:=0;
@z

@x
primitive("font",def_font,0);@/
@!@:font_}{\.{\\font} primitive@>
@y
primitive("font",def_font,0);@/
@!@:font_}{\.{\\font} primitive@>
primitive("fontvariant",def_font,1);@/
@!@:fontvariant_}{\.{\\fontvariant} primitive@>
@z

@x
def_font: print_esc("font");
@y
def_font: if chr_code=0 then print_esc("font") else print_esc("fontvariant");
@z

@x l.8326
@p procedure scan_something_internal(@!level:small_number;@!negative:boolean);
  {fetch an internal parameter}
var m:halfword; {|chr_code| part of the operand token}
@y
@p procedure scan_something_internal(@!level:small_number;@!negative:boolean);
  {fetch an internal parameter}
var m:halfword; {|chr_code| part of the operand token}
r:pointer; {used with font variants}
@z

@x l.8379
else  begin back_input; scan_font_ident;
  scanned_result(font_id_base+cur_val)(ident_val);
  end
@y
else begin
  if m=0 then begin
    back_input; scan_font_ident;
    scanned_result(font_id_base+cur_val)(ident_val);
  end else if hz_en then begin
    scan_font_ident;
    r:=font_variants[cur_val]; cur_val:=0;
    while r<>null do begin
      incr(cur_val); r:=link(r);
    end;
    scanned_result(cur_val)(int_val);
  end else begin
    print_err("Improper "); print_cmd_chr(def_font,m);
    error;
  end;
end
@z

@x l.10710
@!font_false_bchar:array[internal_font_number] of min_quarterword..non_char;
  {|font_bchar| if it doesn't exist in the font, otherwise |non_char|}
@y
@!font_false_bchar:array[internal_font_number] of min_quarterword..non_char;
  {|font_bchar| if it doesn't exist in the font, otherwise |non_char|}
@!font_variants:array[internal_font_number] of min_halfword..max_halfword;
@z

@x l.10762
for k:=0 to 6 do font_info[k].sc:=0;
@y
for k:=0 to 6 do font_info[k].sc:=0;
font_variants[null_font]:=null;
@z

@x l.11189
fmem_ptr:=fmem_ptr+lf; font_ptr:=f; g:=f; goto done
@y
fmem_ptr:=fmem_ptr+lf; font_ptr:=f; g:=f;
for a:=0 to 255 do begin
  qw:=char_info(f)(a);
  if char_exists(qw) then begin
    font_variants[f]:=get_avail;
    font(font_variants[f]):=f;
    character(font_variants[f]):=a;
    link(font_variants[f]):=null;
    goto done;
  end;
end;
goto done;
@z

@x l.12860
@ Here now is |hpack|, which contains few if any surprises.

@p function hpack(@!p:pointer;@!w:scaled;@!m:small_number):pointer;
label reswitch, common_ending, exit;
var r:pointer; {the box node that will be returned}
@!q:pointer; {trails behind |p|}
@!h,@!d,@!x:scaled; {height, depth, and natural width}
@y
@ This routine replaces characters in the hlist |p| with variants from other
fonts in order to stretch the natural width by |r|. It returns the amount by 
which the natural width could be stretched.

@p function adjust_excess(p:pointer;r:real):scaled;
label reswitch,found,done;
var v,w,d,dd:scaled;
f,ff,c:eight_bits;
i,ii:four_quarters;
s:pointer;
j:integer;
begin
@!debug
print("(adjust_excess: "); print_scaled(round(unity*r)); 
print(" --> ");
gubed
v:=0; w:=0;
while p<>null do begin
  reswitch: while is_char_node(p) do begin
    c:=character(p); f:=font(p); i:=char_info(f)(c);
    w:=w+char_width(f)(i);
    s:=font_variants[f];
    f:=font(s); i:=char_info(f)(c);
    d:=abs(v+char_width(f)(i)-r*w);
    s:=link(s);
@!debug
    j:=0;
gubed
    while s<>null do begin
      ff:=font(s); ii:=char_info(ff)(c);
      dd:=abs(v+char_width(ff)(ii)-r*w);
      if dd>=d then goto found;
      d:=dd; f:=ff; i:=ii;
@!debug
      j:=j+1;
gubed
      s:=link(s);
    end;
    found: 
    font(p):=f;
@!debug
    print_int(j);
gubed
    v:=v+char_width(f)(i);
    p:=link(p);
  end;
  if p=null then goto done;
  if type(p)=ligature_node then
    @<Make node |p| look like a |char_node| and |goto reswitch|@>
  else p:=link(p);
end;
done:
@!debug
print_ln;
print(" got "); print_scaled(v-w); print(")");
gubed 
adjust_excess:=v-w;
end;

@ Here now is |hpack|, which contains few if any surprises.

@p function hpack(@!p:pointer;@!w:scaled;@!m:small_number):pointer;
label reswitch, common_ending, exit;
var r:pointer; {the box node that will be returned}
@!q:pointer; {trails behind |p|}
@!h,@!d,@!x:scaled; {height, depth, and natural width}
@!gw:scaled; {natural width coming from glyphs}
@z

@x
h:=0; @<Clear dimensions to zero@>;
@y
h:=0; gw:=0; @<Clear dimensions to zero@>;
@z

@x
@<Incorporate character dimensions into the dimensions of the hbox...@>=
begin f:=font(p); i:=char_info(f)(character(p)); hd:=height_depth(i);
x:=x+char_width(f)(i);@/
@y
@<Incorporate character dimensions into the dimensions of the hbox...@>=
begin f:=font(p); i:=char_info(f)(character(p)); hd:=height_depth(i);
x:=x+char_width(f)(i);@/
gw:=gw+char_width(f)(i);
@z

@x
else if x>0 then @<Determine horizontal glue stretch setting, then |return|
    or \hbox{|goto common_ending|}@>
else @<Determine horizontal glue shrink setting, then |return|
    or \hbox{|goto common_ending|}@>
@y
else begin
  if hz_en then begin
    if gw<>0 then begin
      x:=x-adjust_excess(link(q),(gw+x)/gw);
    end;
  end;
  if x>0 then @<Determine horizontal glue stretch setting, then |return|
    or \hbox{|goto common_ending|}@>
  else @<Determine horizontal glue shrink setting, then |return|
    or \hbox{|goto common_ending|}@>;
end
@z

@x
@d delta_node_size=7 {number of words in a delta node}
@d delta_node=2 {|type| field in a delta node}
@y
@d delta_node_size=9 {number of words in a delta node}
@d delta_node=2 {|type| field in a delta node}
@z

@x
@d do_all_six(#)==#(1);#(2);#(3);#(4);#(5);#(6)

@<Glo...@>=
@!active_width:array[1..6] of scaled;
  {distance from first active node to~|cur_p|}
@!cur_active_width:array[1..6] of scaled; {distance from current active node}
@!background:array[1..6] of scaled; {length of an ``empty'' line}
@!break_width:array[1..6] of scaled; {length being computed after current break}
@y
For the hz algorithm, we add two more fields to store the finite
stretch and shrink from glyphs.

@d do_all_six(#)==#(1);#(2);#(3);#(4);#(5);#(6)
@d do_all_eight(#)==do_all_six(#);#(7);#(8)

@<Glo...@>=
@!active_width:array[1..8] of scaled;
  {distance from first active node to~|cur_p|}
@!cur_active_width:array[1..8] of scaled; {distance from current active node}
@!background:array[1..8] of scaled; {length of an ``empty'' line}
@!break_width:array[1..8] of scaled; {length being computed after current break}
@z

@x
background[6]:=shrink(q)+shrink(r);
@y
background[6]:=shrink(q)+shrink(r);
background[7]:=0; background[8]:=0;
@z

@x
do_all_six(copy_to_cur_active);
@y
do_all_eight(copy_to_cur_active);
@z

@x
  begin do_all_six(update_width);
@y
  begin do_all_eight(update_width);
@z

@x
begin no_break_yet:=false; do_all_six(set_break_width_to_background);
@y
begin no_break_yet:=false; do_all_eight(set_break_width_to_background);
@z

@x
  begin do_all_six(convert_to_break_width);
@y
  begin do_all_eight(convert_to_break_width);
@z

@x
  begin do_all_six(store_break_width);
@y
  begin do_all_eight(store_break_width);
@z

@x
  do_all_six(new_delta_to_break_width);
@y
  do_all_eight(new_delta_to_break_width);
@z

@x
  do_all_six(new_delta_from_break_width);
@y
  do_all_eight(new_delta_from_break_width);
@z

@x
shortfall:=line_width-cur_active_width[1]; {we're this much too short}
@y
if hz_en then begin
  if cur_active_width[1]+cur_active_width[7]<line_width then
    shortfall:=line_width-(cur_active_width[1]+cur_active_width[7])
  else if cur_active_width[1]-cur_active_width[8]>line_width then
    shortfall:=line_width-(cur_active_width[1]-cur_active_width[8])
  else shortfall:=0;
end else shortfall:=line_width-cur_active_width[1]; {we're this much too short}
@z

@x
    begin do_all_six(downdate_width);
@y
    begin do_all_eight(downdate_width);
@z

@x
    begin do_all_six(update_width);
    do_all_six(combine_two_deltas);
@y
    begin do_all_eight(update_width);
    do_all_eight(combine_two_deltas);
@z

@x
  begin do_all_six(update_active);
  do_all_six(copy_to_cur_active);
@y
  begin do_all_eight(update_active);
  do_all_eight(copy_to_cur_active);
@z

@x
do_all_six(store_background);@/
@y
do_all_eight(store_background);@/
@z

@x
begin prev_p:=cur_p;
repeat f:=font(cur_p);
act_width:=act_width+char_width(f)(char_info(f)(character(cur_p)));
cur_p:=link(cur_p);
until not is_char_node(cur_p);
end
@y
begin prev_p:=cur_p;
repeat f:=font(cur_p);
w:=char_width(f)(char_info(f)(character(cur_p)));
act_width:=act_width+w;
if hz_en then @<Update stretch and shrink in the presence of font variants@>;
cur_p:=link(cur_p);
until not is_char_node(cur_p);
end

@ @<Local variables for line...@>=
@!w:scaled; {used when calculating character widths}

@ @<Update stretch and shrink...@>=
begin
r:=font_variants[f];
active_width[7]:=active_width[7]+
           char_width(font(r))(char_info(font(r))(character(cur_p)))-w;
while link(r)<>null do r:=link(r);
active_width[8]:=active_width[8]+
           w-char_width(font(r))(char_info(font(r))(character(cur_p)));
end
@z

@x
def_font: new_font(a);
@y
def_font: if cur_chr=0 then new_font(a) else
  if hz_en then font_variant(a)
  else begin print_err("Improper "); print_cmd_chr(def_font,cur_chr); error; end;


@ @<Declare subprocedures for |prefixed_command|@>=
procedure font_variant(@!a:small_number);
label found,done;
var @!f,ff:internal_font_number;
@!i:eight_bits;
@!qw,qww:four_quarters;
@!r,s,p: pointer;
begin
  scan_font_ident; f:=cur_val;
  scan_optional_equals; scan_font_ident; ff:=cur_val;
  @<If |ff| is |null_font|, reset the list of variants and goto |found|@>;
  @<Check that |ff| is a valid variant of |f|, else goto |done|@>;
  s:=null; r:=font_variants[f];
  i:=character(r);
  p:=new_character(ff,i);
  qww:=char_info(ff)(i);
  while r<>null do begin
    if font(r)=ff then goto done;
    qw:=char_info(font(r))(i);
    if char_width(font(r))(qw)<char_width(ff)(qww) then goto found;
    s:=r; r:=link(r);
  end;
found:
 link(p):=r;
 if s=null then font_variants[f]:=p
 else link(s):=p;
 done:
@!debug
 print("(fontvariants of ");
 print(font_name[f]); print(": ");
 r:=font_variants[f];
 while r<>null do begin
   print(font_name[font(r)]); 
   r:=link(r);
   if r<>null then print(", ");
 end;
 print(")");
gubed
end;

@ Fonts can only be variants of each other if they provide the
same characters.

@<Check that |ff| is a valid variant of |f|...@>=
for i:=0 to 255 do begin
  qw:=char_info(f)(i);
  qww:=char_info(f)(i);
  if (char_exists(qw) and not char_exists(qww)) or
     (not char_exists(qw) and char_exists(qww)) then begin
    print_err("Font "); print_esc(font_id_text(ff));
    print(" is not a variant of font "); print_esc(font_id_text(f));
@.Font x is not a...@>
    help2("Fonts can only be used as variants of each other")@/
      ("if they contain the same characters.");
    error;
    goto done;
  end;
end

@ The only way to remove variants of a font is to assign |null_font|
as a variant.

@<If |ff| is |null_font|...@>=
if ff=null_font then begin
  r:=null; s:=null; p:=new_character(f,character(font_variants[f]));
  flush_node_list(font_variants[f]);
  goto found;
end
@z