diff options
author | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
commit | e0c6872cf40896c7be36b11dcc744620f10adf1d (patch) | |
tree | 60335e10d2f4354b0674ec22d7b53f0f8abee672 /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.ch | 251 |
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 + |