|
DataMuseum.dkPresents historical artifacts from the history of: Bogika Butler |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Bogika Butler Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 9984 (0x2700)
Types: TextFile
Names: »TFOUTYLA.BAK«
└─⟦514567ecc⟧ Bits:30009789/_.ft.Ibm2.50006603.imd Mogens Pelles Zilog 80,000 / EOS projekt
└─⟦this⟧ »TFOUTYLA.BAK«
(**************************************************************)
(* *)
(* OUTPUT MODULE starts *)
(* version not utilising the printer's sub/superscript facility *)
(* version for Lars Jakobsen's printer *)
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('NEGATIVE FEED!'); 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 720, ' * 720 + ', total_feed mod 720, esc, 'i'); *)
end;
(* MODULE 4 ends *)
(* *)
(**************************************************************)
«eof»