home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol085 / signs.pas < prev    next >
Pascal/Delphi Source File  |  1984-04-29  |  4KB  |  119 lines
  1. {$E+}
  2. program signs;
  3. {kilobaud, Aug '78, page 90
  4. program originally in North Star BASIC by Joseph J. Roehrig
  5. numbers in brackets indicate line numbers in original program
  6. }
  7. LABEL
  8.   1;
  9. TYPE
  10.   $str8 = string 8;
  11. VAR
  12.   fout : text;
  13.   V : array[0..31] of integer;    {patterns}
  14.   L$ : array[1..27] of char;    {top of array equ number of chars}
  15.   L  : array[1..27,1..7] of integer;    {dimensions of each letter}
  16.   Z  : array[1..5] of integer;
  17.   D1$: array[1..7]of char;
  18.   D$ : array[1..7]of char;    {top of array equ total number of letters}
  19.   C$ : char;
  20.   a,
  21.   b,
  22.   c,
  23.   d,
  24.   f,
  25.   g,
  26.   q,
  27.   e : integer;
  28.  
  29. function ucase(ch:char):char;
  30. {This function filters all non-alphabetical characters, replacing
  31. them with blanks.  It also converts all lower case letters to
  32. upper case.}
  33. begin
  34.   if ch in ['A'..'Z'] then ucase := ch    {accept uppers}
  35.   else
  36.     if ch in ['a'..'z'] then    {translate to upper case}
  37.       ucase := chr(ord(ch) - 32)
  38.       else ucase := ' '        {filter illegal characters}
  39. end;    {ucase}
  40.  
  41. procedure setarray;
  42. {This procedure fills the array L with the font values from
  43. "font.dat".  It takes the place of a series of DATA statements
  44. in the original BASIC program.}
  45. var
  46.   letter : $str8;
  47.   a,b    : integer;
  48.   fin    : file of $str8;
  49.   {L     : array [1..27,1..7] of integer - global}
  50. begin
  51.   reset('font.dat',fin);    {font.dat contains array values}
  52.   for a := 1 to 27 do        {70, set loop value to tot # chars formed}
  53.     begin
  54.     readln(fin,letter);    {'letter' contains 8 char; 1st 7 are significant}
  55.     for b := 1 to 7 do    {8th is "for info" label}
  56.       begin
  57.       L[a,b] := ord(letter[b])-64;    {80}
  58.       end;    {for b}
  59.     end;    {for a}
  60. end;    {procedure setarray}
  61.  
  62. begin    {main program}
  63.   D1$ := '       ';        {7 blanks}
  64.   L$  := 'ABCDEFGHIJKLMNOPQRSTUVWXYZ ';    {15}
  65.   z[1] := 10000; z[2] := 1000; z[3] := 100; z[4] := 10; z[5] := 1;
  66.   for a := 1 to 7 do        {40    7 is the number of lines of ltrs}
  67.     begin
  68.     D$[a] := ' ';        {fill array D$ with blanks}
  69.     end;
  70.   v[0]:=0; v[1]:=1;         {50    read binary number line}
  71.   v[2]:=10; v[3]:=11; v[4]:=100; v[5]:=101; v[6]:=110; v[7]:=111;
  72.   v[8]:=1000; v[9]:=1001; v[10]:= 1010; v[11]:=1011; v[12]:= 1100;
  73.   v[13]:=1101; v[14]:=1110; v[15]:=1111;
  74.   for a := 16 to 31 do v[a] := 10000+v[a-16];    {60}
  75.   {there has to be a better way to fill this array, when you
  76.   find it, let me know}
  77.   setarray;        {70,80}
  78.   rewrite('lst:',fout);
  79.   writeln('Instructions:  This program will accept upper case');
  80.   writeln('characters and blanks. (Lower case letters will translate)');
  81.   writeln('Enter a period and a carriage return to end.');
  82.   writeln;
  83.     while D1$[1] <> '.' do
  84.     begin    {while}
  85.     Writeln('Input line:');
  86.     writeln('_______');
  87.     readln(D1$);
  88.       if D1$[1] = '.' then goto 1;    {sorry, had to GOTO}
  89.     for e := 1 to 7 do
  90.     D$[e] := ucase(D1$[e]);
  91. {98 "get paper ready & enter <cr>}
  92.     for d := 1 to 7 do        {105}
  93.     begin
  94.       for b := 1 to 7 do    {110}
  95.       begin
  96.       c := b;            {120}
  97.       C$ := D$[c];        {122}
  98.       c := ord(C$);
  99.       c := c-64;        {124}
  100.       if 0 > c then c := 27;
  101.       f := L[c,d];        {135}
  102.       f := v[f];        {136}
  103.       q := c;            {137}
  104.       for e := 1 to 5 do    {150}
  105.         begin
  106.         g := trunc(f div z[e]);    {160}
  107.         f := f-(g*z[e]);    {165}
  108.         if g = 1 then write(fout,L$[q],L$[q])    {170}
  109.                  else write(fout,'  ');
  110.         end;    {for e}
  111.       write(fout,'  ');        {200, number of spaces between letters}
  112.       end;    {for b}
  113.     writeln(fout,' ');        {220, ends each line of print}
  114.     end;    {for d}
  115.   writeln(fout); writeln(fout);    {230, 2 blank lines between each printed string}
  116.   1:
  117.   end;    {while}
  118. end.
  119.