home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / mbug / mbug077.arc / SIGNS2.PAS < prev    next >
Pascal/Delphi Source File  |  1979-12-31  |  7KB  |  231 lines
  1.   program signs;
  2.  
  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.   { Modified to work with Turbo pascal by Peter Billing  June 1985}
  8. LABEL
  9.   1;
  10. CONST
  11.   wdth=6;     {# letters per line
  12.                Each letter requires 12 spaces; an 80 column screen can
  13.                accomodate 6 letters (6x12=72).  A 132 column printer
  14.                can handle 11 letters
  15.                The program is now constructed so that changing wdth is the
  16.                ONLY thing that is necessary to changing the letter count.}
  17.  
  18.   alphabet = 27; {number of letters supported in alphabet}
  19.  
  20.   {To expand the alphabet several things need to be done:
  21.    1.  Change "alphabet" appropriately.
  22.    2.  Alter procedure ucase so it filters correctly.
  23.    3.  Include new characters in font.dat.
  24.    4.  Main program line "if 0>c then c := 27;" prohibits
  25.    mapping characters into negative values in array L.
  26.    It also effectively prohibits any characters whose
  27.    ASCII values are less than 64.  You are going to
  28.    have to redo the logic there to include numbers...}
  29.  
  30. TYPE
  31.     str8 = string [8]; {for reading font.dat}
  32.  
  33. VAR
  34.   fout : text;
  35.   V    : array[0..31] of integer;  {patterns}
  36.   LE   : array[1..alphabet] of char; {top of array equ number of chars}
  37.   L    : array[1..alphabet,1..7] of integer; {dimensions of each letter}
  38.   Z    : array[1..5] of integer; {decoder}
  39.   DD   : array[1..wdth]of char; {wdth equ total # of letters on a line}
  40.   CHA   : char;
  41.   a,
  42.   b,
  43.   c,
  44.   d,
  45.   f,
  46.   g,
  47.   i,
  48.   q,
  49.   num,
  50.   e : integer;
  51.  
  52.   function ucase(ch:char):char;
  53.     {This function filters all non-alphabetical characters, replacing
  54.      them with blanks.  It also converts all lower case letters to
  55.      upper case.}
  56.   begin
  57.     if (ch in ['A'..'Z']) {or (ch in ['0'..'9'])}
  58.       then ucase := ch
  59.         {accept upper case [and numbers as is]}
  60.       else
  61.         if ch in ['a'..'z']
  62.           then {translate to upper case}
  63.             ucase := chr(ord(ch) - 32)
  64.           else ucase := ' '  {filter illegal characters}
  65.   end; {ucase}
  66.  
  67.   Procedure Setfont(letter:str8);
  68.     {This procedure fills the array L with the font values from
  69.      "font.dat".  It takes the place of a series of DATA statements
  70.      in the original BASIC program.
  71.      Additionally, LE is filled from the 8th character in each font value.
  72.      This allows LE to grow automatically with alphabet.}
  73.   var
  74.     {letter : str8;}
  75.     a,b    : integer;
  76.     fin    : text; {file of str8;}
  77.     {L     : array [1..alphabet,1..7] of integer - global
  78.      LE  : array [1..alphabet] of char - global}
  79.   begin
  80. (*    assign(fin,'FONT.DAT');
  81.     reset(fin); {font.dat contains array values}
  82.     if eof(fin)
  83.       then writeln('"Font.dat" must be on logged disk.');
  84.    for a := 1 to alphabet do  {70, set loop value to tot # chars formed}
  85.     begin
  86.    readln(fin,letter); {'letter' contains 8 char; 1st 7 are significant}
  87.  *)     for b := 1 to 7 do {8th is the LE label}
  88.       begin
  89.         L[num,b] := ord(letter[b])-64; {80}
  90.         LE[num] := letter[8];  {15}
  91.       end; {for b}
  92.   (*  end; {for a}*)
  93.     num:=num+1;
  94.   end; {procedure setfont('}
  95.  
  96.   procedure initialize;
  97.     {fill arrays DD, Z and V}
  98.   begin
  99.     for a := 1 to wdth do DD[a] := ' ';  {wdth blanks}
  100.     z[1] := 10000; z[2] := 1000; z[3] := 100; z[4] := 10; z[5] := 1;
  101.     v[0]:=0; v[1]:=1;   {50 read binary number line}
  102.     v[2]:=10;    v[3]:=11;    v[4]:=100;    v[5]:=101;   v[6]:=110;   v[7]:=111;
  103.     v[8]:=1000;  v[9]:=1001;  v[10]:=1010;  v[11]:=1011; v[12]:= 1100;
  104.     v[13]:=1101; v[14]:=1110; v[15]:=1111;
  105.     for a := 16 to 31 do v[a] := 10000+v[a-16]; {60}
  106.     {there has to be a better way to fill this array, when you
  107.      find it, let me know}
  108.   end; {procedure initialize}
  109.  
  110.   procedure setdev;
  111.     {output direction}
  112.   var
  113.     choice : char;
  114.     filnam : string [14];
  115.   begin
  116.     writeln;
  117.     writeln('Do you wish output to:');
  118.     writeln('            1) printer (lst:)');
  119.     writeln('            2) screen  (con:)');
  120.     writeln('            3) a file');
  121.     repeat
  122.       read(kbd,choice);
  123.     until choice in ['1','2','3'];
  124.     case choice of
  125.       '1':   assign(fout,'lst:');
  126.       '2':   assign(fout,'con:');
  127.       '3':   begin
  128.               write('Name of file: ');
  129.               readln(filnam);
  130.               assign(fout,filnam);
  131.             end;
  132.     end; {case}
  133.     rewrite(fout)
  134.     end; {procedure setdev}
  135.  
  136. Procedure Data;
  137. begin
  138. setfont('DJQ_QQQA');
  139. setfont('^QQ_QQ^B');
  140. setfont('NQPPPQNC');
  141. setfont('\RQQQR\D');
  142. setfont('_PP^PP_E');
  143. setfont('_PP^PPPF');
  144. setfont('NQPPSQNG');
  145. setfont('QQQ_QQQH');
  146. setfont('NDDDDDNI');
  147. setfont('AAAAQIFJ');
  148. setfont('QRTXTRQK');
  149. setfont('PPPPPP_L');
  150. setfont('Q[UQQQQM');
  151. setfont('QYUUUSQN');
  152. setfont('DJQQQJDO');
  153. setfont('^QQ^PPPP');
  154. setfont('DJQQUJEQ');
  155. setfont('^QQ^TRQR');
  156. setfont('NQPNAQNS');
  157. setfont('_DDDDDDT');
  158. setfont('QQQQQQNU');
  159. setfont('QQQQQJDV');
  160. setfont('QQQQU_QW');
  161. setfont('QJJDJJQX');
  162. setfont('QQJDDDDY');
  163. setfont('_ABDDH_Z');
  164. setfont('@@@@@@@@');
  165. end;
  166.  
  167. begin {main program}
  168.   clrscr;
  169.   num:=1;
  170.   data;
  171.   initialize;
  172. writeln('          SSSSSS      IIIIII      GGGGGG    NN      NN    SSSSSS  ');
  173. writeln('        SS      SS      II      GG      GG  NNNN    NN  SS      SS');
  174. writeln('        SS              II      GG          NN  NN  NN  SS        ');
  175. writeln('          SSSSSS        II      GG          NN  NN  NN    SSSSSS  ');
  176. writeln('                SS      II      GG    GGGG  NN  NN  NN          SS');
  177. writeln('        SS      SS      II      GG      GG  NN    NNNN  SS      SS');
  178. writeln('          SSSSSS      IIIIII      GGGGGG    NN      NN    SSSSSS   ');
  179. writeln;
  180.   writeln;
  181.   writeln('  This program will accept upper case');
  182.   writeln('characters and blanks. (Lower case letters will translate)');
  183.   writeln;
  184.   writeln('Enter a period and a carriage return to end.');
  185.   writeln('Pick your device: screen, printer or file.');
  186.   setdev;
  187.   writeln;
  188.   while DD[1] <> '.' do
  189.   begin {while}
  190.     writeln('Enter a period and a carriage return to end.');
  191.     Writeln('Input line:');
  192.     for a := 1 to wdth do write('_');
  193.     writeln;
  194.     for i:= 1 to wdth do
  195.     begin
  196.     read(kbd,DD[i]);write(DD[i]);
  197.     if DD[1] = '.'
  198.       then goto 1; {sorry, had to GOTO}
  199.     end;writeln;
  200.     for e := 1 to wdth do
  201.     DD[e] := ucase(DD[e]);
  202.     {98 "get paper ready & enter <cr>}
  203.     for d := 1 to 7 do  {105}
  204.     begin
  205.       for b := 1 to wdth do {110}
  206.       begin
  207.         c := b;   {120}
  208.         c := ord(DD[c])-64;
  209.         if 0 > c
  210.           then c := 27;
  211.         f := L[c,d];  {135}
  212.         f := v[f];  {136}
  213.         q := c;   {137}
  214.         for e := 1 to 5 do {150}
  215.         begin
  216.           g := trunc(f div z[e]); {160}
  217.           f := f-(g*z[e]); {165}
  218.           if g = 1
  219.             then write(fout,LE[q],LE[q]) {170}
  220.             else write(fout,'  ');
  221.         end; {for e}
  222.         write(fout,'  ');  {200, number of spaces between letters}
  223.       end; {for b}
  224.       writeln(fout);  {220, ends each line of print}
  225.     end; {for d}
  226. writeln(fout); writeln(fout); {230, 2 blank lines between each printed string}
  227. 1:
  228.   end; {while}
  229. close(fout);
  230. end.
  231.