home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol148 / signs.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1984-04-29  |  5.2 KB  |  168 lines
  1. program signs;
  2. {kilobaud, Aug '78, page 90
  3. program originally in North Star BASIC by Joseph J. Roehrig
  4. numbers in brackets indicate line numbers in original program
  5. }
  6. LABEL
  7.   1;
  8. CONST
  9.   wdth = 11;        {# letters per line
  10.     Each letter requires 12 spaces; an 80 column screen can
  11.         accomodate 6 letters (6x12=72).  A 132 column printer
  12.         can handle 11 letters
  13.     The program is now constructed so that changing wdth is the
  14.     ONLY thing that is necessary to changing the letter count.}
  15.   alphabet = 27;    {number of letters supported in alphabet}
  16.     {To expand the alphabet several things need to be done:
  17.         1.  Change "alphabet" appropriately.
  18.         2.  Alter procedure ucase so it filters correctly.
  19.         3.  Include new characters in font.dat.
  20.         4.  Main program line "if 0>c then c := 27;" prohibits 
  21.             mapping characters into negative values in array L.
  22.             It also effectively prohibits any characters whose
  23.             ASCII values are less than 64.  You are going to 
  24.             have to redo the logic there to include numbers...}
  25. VAR
  26.   fout : text;
  27.   V : array[0..31] of integer;        {patterns}
  28.   L$ : array[1..alphabet] of char;    {top of array equ number of chars}
  29.   L  : array[1..alphabet,1..7] of integer;    {dimensions of each letter}
  30.   Z  : array[1..5] of integer;    {decoder}
  31.   D1$ : array[1..wdth]of char;    {wdth equ total # of letters on a line}
  32.   C$ : char;
  33.   a,
  34.   b,
  35.   c,
  36.   d,
  37.   f,
  38.   g,
  39.   q,
  40.   e : integer;
  41.  
  42. function ucase(ch:char):char;
  43. {This function filters all non-alphabetical characters, replacing
  44. them with blanks.  It also converts all lower case letters to
  45. upper case.}
  46. begin
  47.   if (ch in ['A'..'Z']) {or (ch in ['0'..'9'])} then ucase := ch    
  48.     {accept upper case [and numbers as is]}
  49.   else
  50.     if ch in ['a'..'z'] then    {translate to upper case}
  51.       ucase := chr(ord(ch) - 32)
  52.       else ucase := ' '        {filter illegal characters}
  53. end;    {ucase}
  54.  
  55. procedure setfont;
  56. {This procedure fills the array L with the font values from
  57. "font.dat".  It takes the place of a series of DATA statements
  58. in the original BASIC program.
  59. Additionally, L$ is filled from the 8th character in each font value.
  60. This allows L$ to grow automatically with alphabet.}
  61. TYPE
  62.   $str8 = string 8;    {for reading font.dat}
  63. var
  64.   letter : $str8;
  65.   a,b    : integer;
  66.   fin    : file of $str8;
  67.   {L     : array [1..alphabet,1..7] of integer - global
  68.    L$     : array [1..alphabet] of char - global}
  69. begin
  70.   reset('font.dat',fin);    {font.dat contains array values}
  71.   if eof(fin) then writeln('"Font.dat" must be on logged disk.');
  72.   for a := 1 to alphabet do        {70, set loop value to tot # chars formed}
  73.     begin
  74.     readln(fin,letter);    {'letter' contains 8 char; 1st 7 are significant}
  75.     for b := 1 to 7 do    {8th is the L$ label}
  76.       begin
  77.       L[a,b] := ord(letter[b])-64;    {80}
  78.       L$[a] := letter[8];        {15}
  79.       end;    {for b}
  80.     end;    {for a}
  81. end;    {procedure setfont}
  82.  
  83. procedure initialize;
  84. {fill arrays D1$, Z and V}
  85. begin
  86.   for a := 1 to wdth do D1$[a] := ' ';        {wdth blanks}
  87.   z[1] := 10000; z[2] := 1000; z[3] := 100; z[4] := 10; z[5] := 1;
  88.   v[0]:=0; v[1]:=1;         {50    read binary number line}
  89.   v[2]:=10; v[3]:=11; v[4]:=100; v[5]:=101; v[6]:=110; v[7]:=111;
  90.   v[8]:=1000; v[9]:=1001; v[10]:= 1010; v[11]:=1011; v[12]:= 1100;
  91.   v[13]:=1101; v[14]:=1110; v[15]:=1111;
  92.   for a := 16 to 31 do v[a] := 10000+v[a-16];    {60}
  93.   {there has to be a better way to fill this array, when you
  94.   find it, let me know}
  95. end;    {procedure initialize}
  96.  
  97. procedure setdev;
  98. {output direction}
  99. var
  100.   choice : integer;
  101.   filnam : string 14;
  102. begin
  103.   writeln;
  104.   writeln('Do you wish output to:');
  105.   writeln('            1) printer (lst:)');
  106.   writeln('            2) screen  (con:)');
  107.   writeln('            3) a file');
  108.   repeat
  109.   read(choice);
  110.   until choice in [1,2,3];
  111.   case choice of
  112.   1: rewrite('lst:',fout);
  113.   2: rewrite('con:',fout);
  114.   3: begin
  115.      write('Name of file: ');
  116.      readln(filnam);
  117.      rewrite(filnam,fout)
  118.      end;
  119.   end;    {case}
  120. end;    {procedure setdev}
  121.  
  122. begin    {main program}
  123.   setfont;        {70,80}
  124.   initialize;
  125.   writeln('Pick your device: screen, printer or file.');
  126.   writeln;
  127.   writeln('  This program will accept upper case');
  128.   writeln('characters and blanks. (Lower case letters will translate)');
  129.   writeln;
  130.   writeln('Enter a period and a carriage return to end.');
  131.   setdev;
  132.   writeln;
  133.     while D1$[1] <> '.' do
  134.     begin    {while}
  135.     Writeln('Input line:');
  136.     for a := 1 to wdth do write('_');
  137.     writeln;
  138.     readln(D1$);
  139.       if D1$[1] = '.' then goto 1;    {sorry, had to GOTO}
  140.     for e := 1 to wdth do
  141.     D1$[e] := ucase(D1$[e]);
  142. {98 "get paper ready & enter <cr>}
  143.     for d := 1 to 7 do        {105}
  144.     begin
  145.       for b := 1 to wdth do    {110}
  146.       begin
  147.       c := b;            {120}
  148.       c := ord(D1$[c])-64;
  149.       if 0 > c then c := 27;
  150.       f := L[c,d];        {135}
  151.       f := v[f];        {136}
  152.       q := c;            {137}
  153.       for e := 1 to 5 do    {150}
  154.         begin
  155.         g := trunc(f div z[e]);    {160}
  156.         f := f-(g*z[e]);    {165}
  157.         if g = 1 then write(fout,L$[q],L$[q])    {170}
  158.                  else write(fout,'  ');
  159.         end;    {for e}
  160.       write(fout,'  ');        {200, number of spaces between letters}
  161.       end;    {for b}
  162.     writeln(fout);        {220, ends each line of print}
  163.     end;    {for d}
  164.   writeln(fout); writeln(fout);    {230, 2 blank lines between each printed string}
  165.   1:
  166.   end;    {while}
  167. end.
  168.