summaryrefslogtreecommitdiff
path: root/systems/tex-extensions/clasen/math/accent.ch
blob: be9ba91347947a516f4f80cd0c16acf1ef508b62 (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
@x
@d normal=0 {the most common case when several cases are named}
@y
@d normal=0 {the most common case when several cases are named}
@d under_accent=2 {|subtype| of under math accents}
@d nesting=1 {add this to an accent |subtype| to make it nesting}
@z

@x
primitive("mathaccent",math_accent,0);@/
@!@:math_accent_}{\.{\\mathaccent} primitive@>
@y
primitive("mathaccent",math_accent,normal);@/
@!@:math_accent_}{\.{\\mathaccent} primitive@>
primitive("nestingmathaccent",math_accent,normal+nesting);@/
@!@:nesting_math_accent_}{\.{\\nestingmathaccent} primitive@>
primitive("mathunderaccent",math_accent,under_accent);@/
@!@:math_under_accent_}{\.{\\mathunderaccent} primitive@>
primitive("nestingmathunderaccent",math_accent,under_accent+nesting);@/
@!@:nesting_math_under_accent_}{\.{\\nestingmathunderaccent} primitive@>
@z

@x
math_accent: print_esc("mathaccent");
@y
math_accent: case chr_code of
  normal:              print_esc("mathaccent");
  normal+nesting:      print_esc("nestingmathaccent");
  under_accent:        print_esc("mathunderaccent");
  under_accent+nesting:print_esc("nestingmathunderaccent");
  othercases           print("Unknown accent!")
endcases;
@z

@x
accent_noad: make_math_accent(q);
@y
accent_noad: if subtype(q)<under_accent then make_math_accent(q)
             else make_math_under_accent(q);
@z

@x
procedure make_math_accent(@!q:pointer);
label done,done1;
var p,@!x,@!y:pointer; {temporary registers for box construction}
@y
procedure horizontally_stack_into_box(@!b:pointer;@!f:internal_font_number;@!c:quarterword);
var p:pointer; {new node placed into |b|}
begin
 p:=char_box(f,c); link(p):=list_ptr(b); list_ptr(b):=p;
 width(b):=width(b)+width(p);
end;

procedure make_math_under_accent(@!q:pointer);
label done,done1,done2,done3;
var p,qq,@!x,@!y:pointer; {temporary registers for box construction}
@!a:integer; {address of lig/kern instruction}
@!c:quarterword; {accent character}
@!f:internal_font_number; {its font}
@!i,ii:four_quarters; {its |char_info|}
@!s:scaled; {amount to skew the accent to the right}
@!h:scaled; {height of character being accented}
@!delta,sep:scaled; {space to insert between accentee and accent}
@!w,v,u:scaled; {width of the accentee, not including sub/superscripts}
@!t:four_quarters;
@!m,n:integer;
@!hd:eight_bits;
begin fetch(accent_chr(q));
if char_exists(cur_i) then
  begin i:=cur_i; c:=cur_c; f:=cur_f;@/
  @<Compute under accent skew@>;
  @<Compute separation for under accent@>;
   x:=clean_box(nucleus(q),cur_style); w:=width(x); h:=height(x);
  @<Switch to a larger accent if available and appropriate@>;
  if (math_type(supscr(q))<>empty)or(math_type(subscr(q))<>empty) then
    if math_type(nucleus(q))=math_char then
      @<Swap the subscript and superscript into box |x|@>;
  shift_amount(y):=half(w-width(y))-s; width(y):=0;
  p:=new_kern(sep); link(x):=p; link(p):=y;
  p:=new_kern(-sep-x_height(f)); link(y):=p;
  y:=vpack(x,natural); width(y):=w;
  depth(y):=depth(y)+height(y)-h; height(y):=h;
  info(nucleus(q)):=y; math_type(nucleus(q)):=sub_box;
  end;
end;

procedure make_math_accent(@!q:pointer);
label done,done1,done2;
var p,qq,@!x,@!y:pointer; {temporary registers for box construction}
@z

@x
@!w:scaled; {width of the accentee, not including sub/superscripts}
@y
@!w,v,u:scaled; {width of the accentee, not including sub/superscripts}
@!t:four_quarters;
@!m,n:integer;
@!hd:eight_bits;
@z

@x
  y:=char_box(f,c);
@y
@z

@x
@ @<Switch to a larger accent if available and appropriate@>=
loop@+  begin if char_tag(i)<>list_tag then goto done;
  y:=rem_byte(i);
  i:=char_info(f)(y);
  if not char_exists(i) then goto done;
  if char_width(f)(i)>w then goto done;
  c:=y;
  end;
done:
@y
@ @<Switch to a larger accent if available and appropriate@>=
loop@+  begin
  if char_tag(i)=ext_tag then begin
    y:=new_null_box;
    type(y):=hlist_node;
    i:=font_info[exten_base[f]+rem_byte(i)].qqqq;@/
    c:=ext_rep(i); t:=char_info(f)(c); u:=char_width(f)(t); v:=0;
    hd:=height_depth(t); height(y):=char_height(f)(hd); depth(y):=char_depth(f)(hd);
    c:=ext_bot(i); t:=char_info(f)(c); @+if c<>min_quarterword then v:=v+char_width(f)(t);
    c:=ext_mid(i); t:=char_info(f)(c); @+if c<>min_quarterword then v:=v+char_width(f)(t);
    c:=ext_top(i); t:=char_info(f)(c); @+if c<>min_quarterword then v:=v+char_width(f)(t);
    n:=0;
    if u>0 then while v<w do begin
      v:=v+u; incr(n);
      if ext_mid(i)<>min_quarterword then v:=v+u;
    end;
    c:=ext_bot(i);
    if c<>min_quarterword then horizontally_stack_into_box(y,f,c);
    c:=ext_rep(i);
    for m:=1 to n do horizontally_stack_into_box(y,f,c);
    c:=ext_mid(i);
    if c<>min_quarterword then begin
      horizontally_stack_into_box(y,f,c);
      c:=ext_rep(i);
      for m:=1 to n do horizontally_stack_into_box(y,f,c);
    end;
    c:=ext_top(i);
    if c<>min_quarterword then horizontally_stack_into_box(y,f,c);
    goto done2;
  end;
  if char_tag(i)<>list_tag then goto done;
  y:=rem_byte(i);
  i:=char_info(f)(y);
  if not char_exists(i) then goto done;
  if char_width(f)(i)>w then goto done;
  c:=y;
end;
done:
  y:=char_box(f,c);
done2:
@z

%
% Here is the logic for finding the accentee:
% We pass by accent_noads as long as they are of the opposite kind
% or of same kind and also nesting. This logic is necessary to make
% \Hat{\uhat{\hat A}} align the two hats properly.

@x
@ @<Compute the amount of skew@>=
s:=0;
if math_type(nucleus(q))=math_char then
  begin fetch(nucleus(q));
@y
@ @<Compute under accent skew@>=
s:=0;
qq:=q;
if odd(subtype(q)) then 
  while (math_type(nucleus(qq))=sub_mlist)and
        (type(info(nucleus(qq)))=accent_noad)and
        ((subtype(qq)=subtype(q))or(subtype(qq) div 2<>subtype(q) div 2)) do 
    qq:=info(nucleus(qq));
if math_type(nucleus(qq))=math_char then
  begin fetch(nucleus(qq));
  ii:=char_info(cur_f)(skew_char[cur_f]);
  if char_tag(ii)=lig_tag then
    begin a:=lig_kern_start(cur_f)(ii);
    ii:=font_info[a].qqqq;
    if skip_byte(ii)>stop_flag then
      begin a:=lig_kern_restart(cur_f)(ii);
      ii:=font_info[a].qqqq;
      end;
    loop@+ begin if qo(next_char(ii))=cur_c then
        begin if op_byte(ii)>=kern_flag then
          if skip_byte(ii)<=stop_flag then s:=char_kern(cur_f)(ii);
        goto done1;
        end;
      if skip_byte(ii)>=stop_flag then goto done1;
      a:=a+qo(skip_byte(ii))+1;
      ii:=font_info[a].qqqq;
      end;
    end;
  end;
done1:

@ @<Compute separation for under accent@>=
  sep:=0;
  ii:=i;
  if char_tag(ii)=lig_tag then
    begin a:=lig_kern_start(f)(ii);
    ii:=font_info[a].qqqq;
    if skip_byte(ii)>stop_flag then
      begin a:=lig_kern_restart(f)(ii);
      ii:=font_info[a].qqqq;
      end;
    loop@+ begin if qo(next_char(ii))=c then
        begin if op_byte(ii)>=kern_flag then
          if skip_byte(ii)<=stop_flag then sep:=char_kern(f)(ii);
        goto done3;
        end;
      if skip_byte(ii)>=stop_flag then goto done3;
      a:=a+qo(skip_byte(ii))+1;
      ii:=font_info[a].qqqq;
      end;
    end;
done3:

@ @<Compute the amount of skew@>=
s:=0;
qq:=q;
{while odd(subtype(qq))and(math_type(nucleus(qq))=sub_mlist)and
   (type(info(nucleus(qq)))=accent_noad) do}
if odd(subtype(q)) then 
  while (math_type(nucleus(qq))=sub_mlist)and
        (type(info(nucleus(qq)))=accent_noad)and
        ((subtype(qq)=subtype(q))or(subtype(qq) div 2<>subtype(q) div 2)) do 
  qq:=info(nucleus(qq));
if math_type(nucleus(qq))=math_char then
  begin fetch(nucleus(qq));
@z

@x
procedure math_ac;
begin if cur_cmd=accent then
  @<Complain that the user should have said \.{\\mathaccent}@>;
tail_append(get_node(accent_noad_size));
type(tail):=accent_noad; subtype(tail):=normal;
@y
procedure math_ac;
begin if cur_cmd=accent then
  @<Complain that the user should have said \.{\\mathaccent}@>;
tail_append(get_node(accent_noad_size));
type(tail):=accent_noad; subtype(tail):=cur_chr;
@z