⟦242bdf434⟧

TextFile



(**************************************************************)
(*                                                            *)
(*                   OUTPUT MODULE starts                     *)

(* version not utilising the printer's sub/superscript facility *)

var
  (* total_feed : integer; *)
  line_feed_pending : integer;
  current_attr,
  underscore_set, subsuperscript : attribute_set;

type
   width_table = array(.#0..#127.) of 0..24;
const
  esc = #27;
  nlq_width : width_table =
    (23, 22, 22, 22, 20, 12, 21, 10, 20, 22, 22, 20, 24, 24, 23, 20,
     19, 22, 24, 23, 24, 22, 18, 24, 24, 24, 23, 22, 22, 22, 22, 24,
     24, 10, 20, 24, 20, 24, 23, 10, 12, 12, 22, 20, 10, 20, 10, 24,
     20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 10, 10, 23, 20, 23, 20,
     20, 24, 22, 22, 22, 22, 22, 24, 24, 20, 20, 23, 22, 24, 22, 24,
     22, 24, 24, 22, 22, 24, 24, 24, 24, 24, 22, 12, 24, 12, 16, 24,
     12, 23, 22, 20, 22, 22, 21, 23, 22, 20, 17, 23, 20, 24, 22, 22,
     22, 22, 23, 20, 20, 22, 24, 24, 24, 24, 20, 14,  6, 14, 16, 20);

  normal_width : array(.boolean.) of width_table =
    (
    (* normal characters : *)
     (12, 12, 11, 10,  8,  8, 12,  5, 12, 12, 11, 12, 12, 12, 12, 11,
      10, 11, 12, 12, 12, 12,  8, 12, 12, 12, 12, 10, 11, 12, 12, 12,
      12,  5,  8, 12, 12, 12, 12,  5,  6,  6, 12, 12,  6, 12,  6, 10,
      12,  8, 12, 12, 12, 12, 12, 12, 12, 12,  6,  6, 10, 12, 10, 12,
      12, 12, 12, 12, 12, 12, 12, 12, 12,  8, 11, 12, 12, 12, 12, 12,
      12, 12, 12, 12, 12, 12, 12, 12, 10, 12, 10,  8, 10,  8, 12, 12,
       5, 12, 11, 11, 11, 12, 10, 11, 11,  8,  9, 10,  8, 12, 11, 12,
      11, 11, 11, 12, 11, 12, 12, 12, 10, 12, 10,  9,  5,  9, 12, 12),
    (* italic characters : *)
     (11, 11, 11, 11,  8,  8, 12,  6, 11, 12, 12, 12, 12, 12, 11, 11,
      12, 11, 12, 12, 12, 11,  8, 12, 12, 12, 11, 11, 11, 12, 11, 12,
      12, 10, 10, 12, 10, 12, 12,  5,  8,  8, 12, 12,  8, 12,  7, 10,
      12,  9, 12, 12, 12, 12, 11, 12, 12, 11,  8,  9, 10, 11, 10, 11,
      12, 12, 12, 12, 12, 12, 12, 12, 12, 10, 12, 12, 10, 12, 12, 12,
      12, 12, 12, 12, 12, 12, 11, 12, 12, 12, 12, 11,  7, 11, 10, 12,
       5, 11, 11, 11, 12, 11, 12, 11, 11,  9, 10, 11,  9, 11, 10, 11,
      11, 11, 10, 11, 10, 11, 10, 12, 12, 11, 12, 10,  9, 10, 12, 12)
    );


(******************************************)
(* local procedures for the output module *)

procedure feed_paper;
  var pending : integer;
begin
  (* write(esc, 'Ifeed', line_feed_pending:4, esc, 'i  '); *)
  (**) if line_feed_pending >= 0 then
  (*   total_feed := total_feed + line_feed_pending *)
  (**) else begin
  (**)   writeln('Baglæns papirfremføring!'); writeln;
  (**) end;
  pending := line_feed_pending*3;
  while pending > 300 do begin
    write(lst, esc, 'J', chr(255)); pending := pending-255
  end;
  if pending > 255 then begin
    write(lst, esc, 'J', chr(100)); pending := pending-100
  end; (* because 1 or 2 steps at a time will give inaccurate results *)
  if pending > 0 then write(lst, esc, 'J', chr(pending));
  line_feed_pending := 0;
end;

procedure install(attr : attribute_set);
  var at : attribute_set;
begin
  if nlq in attr then
    attr := attr-(.bold.)
  else
    if proportional in attr then
      attr := attr+(.bold.);
  at := current_attr-attr; (* attributes to switch off *)
  if subscript      in at then write(lst, esc, 'j', #18);
  if superscript    in at then write(lst, esc, 'J', #18);
  if underscore     in at then write(lst, esc, '-0');
  if bold           in at then write(lst, esc, 'F', esc, 'H');
  if italic         in at then write(lst, esc, '5');
  if nlq            in at then write(lst, esc, 'P');
  if proportional   in at then write(lst, esc, 'p0');
  if unidirectional in at then write(lst, esc, 'U0');
  at := attr-current_attr; (* attributes to switch on *)
  if subscript      in at then write(lst, esc, 'J', #18);
  if superscript    in at then write(lst, esc, 'j', #18);
  if underscore     in at then write(lst, esc, '-1');
  if bold           in at then write(lst, esc, 'E', esc, 'G');
  if italic         in at then write(lst, esc, '4');
  if nlq            in at then write(lst, esc, '(');
  if proportional   in at then write(lst, esc, 'p1');
  if unidirectional in at then write(lst, esc, 'U1');
  current_attr := attr;
end;

function char_width(ch : char; attr : attribute_set) : integer;
  (* calculates the width of an attributed character *)
begin
  if proportional in attr then begin
    if nlq in attr then
      char_width := nlq_width(.ch.)
    else
      char_width := 2*normal_width(.italic in attr, ch.);
  end else
    char_width := 24;
end;

(* end of local procedures for the output module *)
(*************************************************)

procedure init_output;

  procedure change(var table : width_table);
  begin
    table(.'Æ'.) := table(.#18.);
    table(.'æ'.) := table(.#19.);
    table(.'Ø'.) := table(.#20.);
    table(.'ø'.) := table(.#21.);
    table(.'Å'.) := table(.#13.);
    table(.'å'.) := table(.#14.);
  end;

begin
  line_feed_pending := 0;
  (* total_feed := 0; *)
  underscore_set := (.underscore.);
  subsuperscript := (.subscript, superscript.);
  current_attr := (.underscore, bold, italic,
                    nlq, proportional, unidirectional.);
  install( (..) );
  (* change character width tables to accomodate the
     danish character set : *)
  change(nlq_width); change(normal_width(.false.));
  change(normal_width(.true.));
end;

function hyphen_width(attr : attribute_set) : integer;
(* returns the width of a hyphen that would be added
   to the end of a line by "add_hyphen" provided that
   the attributes of the last character of that line
   is attr *)
begin
  hyphen_width := char_width('-', attr-subsuperscript);
end;

procedure add_hyphen(var line : f_string; var len : index0;
                     var width : integer);
(* adds a hyphen to line with almost the same attributes
   as the last character in line. Used for adding a hyphen
   at the end of a line in case of division of a word *)
begin
  len := len+1;
  with line(.len.) do begin
    ch := '-'; attr := line(.len-1.).attr-subsuperscript;
    width := width+char_width(ch, attr);
  end;
end;

procedure add_space(var line : f_string; var len : index0;
                    var width : integer);
(* adds a space to line with almost the same attributes
   as the last character in line. Used for filling in a space
   between two words when formatting *)
begin
  len := len+1;
  with line(.len.) do begin
    ch := ' ';
    attr := line(.len-1.).attr-subsuperscript-underscore_set;
    width := width+char_width(ch, attr);
  end;
end;

function width(var line : f_string; first, last : index0) : integer;
  var w : integer; i : index0; c : char;
begin
  w := 0;
  for i := first to last do with line(.i.) do begin
    if ch = forced_space then c := ' ' else c := ch;
    (* the following is almost a duplicate of the code
       in "char_width" : *)
    if space in attr then
      w := w + sp_len
    else
    if proportional in attr then begin
      if nlq in attr then
        w := w + nlq_width(.c.)
      else
        w := w + 2*normal_width(.italic in attr, c.);
    end else
      w := w + 24;
  end;
  width := w;
end;

procedure expand(var line : f_string; var last : index0;
                 first : index0; nr_words, missing : integer);
(* expands the text in line(.first..last.) so that it takes
   up 'missing' more points of space. 'Last' is updated to
   reflect any extra characters put into line. The text in
   'line' consists of 'nr_words' words separated by single
   spaces. It contains no characters with the 'space' attribute. *)
  var extra_per_space, nr_bigger_spaces, i, j, w : integer;
begin
  extra_per_space :=  missing div (nr_words-1);
  nr_bigger_spaces := missing mod (nr_words-1);
  i := first;
  for j := 1 to nr_words-1 do begin
    i := f_pos(' ', line, i, last);
    with line(.i.) do begin
      w := char_width(ch, attr)+extra_per_space;
      if j <= nr_bigger_spaces then w := w+1;
      attr := attr+(.space.); sp_len := w;
    end;
    i := i+1;
  end;
end;

procedure write_white_space_output(size : integer);
begin
  (* write('white',size:4,' '); *)
  line_feed_pending := line_feed_pending + size;
end;

procedure write_line_output(var line : f_string; len : index0;
                            line_spacing : integer);
  var i : index0; j, pending : integer;
begin
  feed_paper;
  for i := 1 to len do with line(.i.) do begin
    if space in attr then begin
      if sp_len > 0 then begin
        if sp_len mod 24 = 0 then begin
          install(current_attr-subsuperscript
                  -underscore_set-(.proportional.));
          write(lst, ' ' : (sp_len div 24));
        end else begin
          write(lst, esc, 'Z', chr(sp_len mod 256), chr(sp_len div 256));
          for j := 1 to sp_len do write(lst, #0);
        end
      end
    end else begin
      if ch = forced_space then ch := ' ';
      if attr <> current_attr then install(attr);
      write(lst, ch);
    end;
  end;
  write(lst, cr); line_feed_pending := line_spacing;
  (* write('line', line_spacing:4, '  '); *)
end;

procedure terminate_output;
begin
  feed_paper;
  install( (..) );
  (* writeln; writeln; *)
  (* writeln(esc, 'ITotal feed ', total_feed, ' = ', *)
  (* total_feed div 864, ' * 864 + ', total_feed mod 864, esc, 'i'); *)
end;


(*                     MODULE 4 ends                          *)
(*                                                            *)
(**************************************************************)




«eof»
DataMuseum.dk

Bogika Butler

⟦242bdf434⟧ TextFile

Derivation

TextFile
