summaryrefslogtreecommitdiff
path: root/systems/tex-extensions/clasen/hz/hz.ch
diff options
context:
space:
mode:
Diffstat (limited to 'systems/tex-extensions/clasen/hz/hz.ch')
-rw-r--r--systems/tex-extensions/clasen/hz/hz.ch465
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
+