diff options
Diffstat (limited to 'systems/tex-extensions/clasen/hz/hz.ch')
-rw-r--r-- | systems/tex-extensions/clasen/hz/hz.ch | 465 |
1 files changed, 465 insertions, 0 deletions
diff --git a/systems/tex-extensions/clasen/hz/hz.ch b/systems/tex-extensions/clasen/hz/hz.ch new file mode 100644 index 0000000000..b2b2d9f6f5 --- /dev/null +++ b/systems/tex-extensions/clasen/hz/hz.ch @@ -0,0 +1,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 + |