summaryrefslogtreecommitdiff
path: root/systems/tex-extensions/clasen/math/accent.ch
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
committerNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
commite0c6872cf40896c7be36b11dcc744620f10adf1d (patch)
tree60335e10d2f4354b0674ec22d7b53f0f8abee672 /systems/tex-extensions/clasen/math/accent.ch
Initial commit
Diffstat (limited to 'systems/tex-extensions/clasen/math/accent.ch')
-rw-r--r--systems/tex-extensions/clasen/math/accent.ch251
1 files changed, 251 insertions, 0 deletions
diff --git a/systems/tex-extensions/clasen/math/accent.ch b/systems/tex-extensions/clasen/math/accent.ch
new file mode 100644
index 0000000000..be9ba91347
--- /dev/null
+++ b/systems/tex-extensions/clasen/math/accent.ch
@@ -0,0 +1,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
+