{$E+}
program signs;
{kilobaud, Aug '78, page 90
program originally in North Star BASIC by Joseph J. Roehrig
numbers in brackets indicate line numbers in original program
}
LABEL
1;
TYPE
$str8 = string 8;
VAR
fout : text;
V : array[0..31] of integer; {patterns}
L$ : array[1..27] of char; {top of array equ number of chars}
L : array[1..27,1..7] of integer; {dimensions of each letter}
Z : array[1..5] of integer;
D1$: array[1..7]of char;
D$ : array[1..7]of char; {top of array equ total number of letters}
C$ : char;
a,
b,
c,
d,
f,
g,
q,
e : integer;
function ucase(ch:char):char;
{This function filters all non-alphabetical characters, replacing
them with blanks. It also converts all lower case letters to
upper case.}
begin
if ch in ['A'..'Z'] then ucase := ch {accept uppers}
else
if ch in ['a'..'z'] then {translate to upper case}
ucase := chr(ord(ch) - 32)
else ucase := ' ' {filter illegal characters}
end; {ucase}
procedure setarray;
{This procedure fills the array L with the font values from
"font.dat". It takes the place of a series of DATA statements
in the original BASIC program.}
var
letter : $str8;
a,b : integer;
fin : file of $str8;
{L : array [1..27,1..7] of integer - global}
begin
reset('font.dat',fin); {font.dat contains array values}
for a := 1 to 27 do {70, set loop value to tot # chars formed}
begin
readln(fin,letter); {'letter' contains 8 char; 1st 7 are significant}
for b := 1 to 7 do {8th is "for info" label}
begin
L[a,b] := ord(letter[b])-64; {80}
end; {for b}
end; {for a}
end; {procedure setarray}
begin {main program}
D1$ := ' '; {7 blanks}
L$ := 'ABCDEFGHIJKLMNOPQRSTUVWXYZ '; {15}
z[1] := 10000; z[2] := 1000; z[3] := 100; z[4] := 10; z[5] := 1;
for a := 1 to 7 do {40 7 is the number of lines of ltrs}
begin
D$[a] := ' '; {fill array D$ with blanks}
end;
v[0]:=0; v[1]:=1; {50 read binary number line}
v[2]:=10; v[3]:=11; v[4]:=100; v[5]:=101; v[6]:=110; v[7]:=111;
v[8]:=1000; v[9]:=1001; v[10]:= 1010; v[11]:=1011; v[12]:= 1100;
v[13]:=1101; v[14]:=1110; v[15]:=1111;
for a := 16 to 31 do v[a] := 10000+v[a-16]; {60}
{there has to be a better way to fill this array, when you
find it, let me know}
setarray; {70,80}
rewrite('lst:',fout);
writeln('Instructions: This program will accept upper case');
writeln('characters and blanks. (Lower case letters will translate)');
writeln('Enter a period and a carriage return to end.');
writeln;
while D1$[1] <> '.' do
begin {while}
Writeln('Input line:');
writeln('_______');
readln(D1$);
if D1$[1] = '.' then goto 1; {sorry, had to GOTO}
for e := 1 to 7 do
D$[e] := ucase(D1$[e]);
{98 "get paper ready & enter <cr>}
for d := 1 to 7 do {105}
begin
for b := 1 to 7 do {110}
begin
c := b; {120}
C$ := D$[c]; {122}
c := ord(C$);
c := c-64; {124}
if 0 > c then c := 27;
f := L[c,d]; {135}
f := v[f]; {136}
q := c; {137}
for e := 1 to 5 do {150}
begin
g := trunc(f div z[e]); {160}
f := f-(g*z[e]); {165}
if g = 1 then write(fout,L$[q],L$[q]) {170}
else write(fout,' ');
end; {for e}
write(fout,' '); {200, number of spaces between letters}
end; {for b}
writeln(fout,' '); {220, ends each line of print}
end; {for d}
writeln(fout); writeln(fout); {230, 2 blank lines between each printed string}
1:
end; {while}
end.
