{ This program produces six 16-bit check digits from a
  a Pascal program. These check digits can be used to 
  ensure that the Pascal source text has not been changed. 
  The check digits are calculated by using the ISO/CCITT 
  cyclic check approved for data transmission and usually 
  performed by hardware (some 500 times faster than this 
  program). 
  For a description of the checking algorithm, see 
  D W Davies et al. 'Networks and their Protocols' 
  pp263-270. 
  Mark 2 version using sets. 
  V4.2 version has modified error reporting ( see second 
  comment in procedure 'readline'). 
} 
program v4p3checktext(input, output); 
const 
   linelength = 72; 
 { Implementation defined values, to be set for each machine} 
   mincharvalue = 0; 
   maxcharvalue = 255; 
type
   lineindex = 1 .. linelength; 
   regindex = 0 .. 16; 
   bits = (one, two, three, four, five, six); 
   setbits = set of bits; 
   ShiftRegister = array [regindex] of setbits; 
var 
   lpos, lineno, errorlines: integer; 
   firstline, blankline: boolean; 
   line: array [lineindex] of char; 
   SR: ShiftRegister; 
   Convert: array [char] of setbits; 
 
procedure pulse( b: setbits); 
   { This algorithm follows Recommendation V41, see 
     'Data Transmission Over Telephone Network: Series V 
     Recommendations', International Telecommunication Union. 
     Geneva (1977). 
   } 
   var 
      i: regindex;
      e: setbits; 
   begin 
   for i := 15 downto 0 do 
      SR[i+1] := SR[i]; 
   e := SR[16]; 
   SR[0] := (b + e) - (b * e); 
   SR[5] := (SR[5] + e) - (SR[5] * e); 
   SR[12] := (SR[12] + e) - (SR[12] * e); 
   end; {pulse} 
 
procedure initialise; 
   var 
      i: regindex; 
      ch: char; 
   begin 
   for i := 0 to 16 do 
      SR[i] := [ ]; 
   for ch := chr(mincharvalue) to chr(maxcharvalue) do 
      Convert[ch] := [ ]; 
   Convert['a'] := [one]; 
   Convert['A'] := [one]; 
   Convert['b'] := [two]; 
   Convert['B'] := [two]; 
   Convert['c'] := [one,two]; 
   Convert['C'] := [one,two]; 
   Convert['d'] := [one,two,three,four,five,six]; 
   Convert['D'] := [one,two,three,four,five,six]; 
   Convert['e'] := [one,three]; 
   Convert['E'] := [one,three]; 
   Convert['f'] := [two,three]; 
   Convert['F'] := [two,three]; 
   Convert['g'] := [one,two,three]; 
   Convert['G'] := [one,two,three]; 
   Convert['h'] := [four]; 
   Convert['H'] := [four]; 
   Convert['i'] := [one,four]; 
   Convert['I'] := [one,four]; 
   Convert['j'] := [two,four]; 
   Convert['J'] := [two,four];
   Convert['k'] := [one,two,four]; 
   Convert['K'] := [one,two,four]; 
   Convert['l'] := [three,four]; 
   Convert['L'] := [three,four]; 
   Convert['m'] := [one,three,four]; 
   Convert['M'] := [one,three,four]; 
   Convert['n'] := [two,three,four]; 
   Convert['N'] := [two,three,four]; 
   Convert['o'] := [one,two,three,four]; 
   Convert['O'] := [one,two,three,four]; 
   Convert['p'] := [five]; 
   Convert['P'] := [five]; 
   Convert['q'] := [one,five]; 
   Convert['Q'] := [one,five]; 
   Convert['r'] := [two,five]; 
   Convert['R'] := [two,five]; 
   Convert['s'] := [one,two,five]; 
   Convert['S'] := [one,two,five]; 
   Convert['t'] := [three,five]; 
   Convert['T'] := [three,five];
   Convert['u'] := [one,three,five]; 
   Convert['U'] := [one,three,five]; 
   Convert['v'] := [two,three,five]; 
   Convert['V'] := [two,three,five]; 
   Convert['w'] := [one,two,three,five]; 
   Convert['W'] := [one,two,three,five]; 
   Convert['x'] := [four,five]; 
   Convert['X'] := [four,five]; 
   Convert['y'] := [one,four,five]; 
   Convert['Y'] := [one,four,five]; 
   Convert['z'] := [two,four,five]; 
   Convert['Z'] := [two,four,five]; 
   Convert['0'] := [one,two,four,five]; 
   Convert['1'] := [three,four,five]; 
   Convert['2'] := [one,three,four,five]; 
   Convert['3'] := [two,three,four,five]; 
   Convert['4'] := [one,two,three,four,five]; 
   Convert['5'] := [six]; 
   Convert['6'] := [one,six]; 
   Convert['7'] := [two,six];
   Convert['8'] := [one,two,six]; 
   Convert['9'] := [three,six]; 
   Convert['('] := [one,three,six]; 
   Convert[')'] := [two,three,six]; 
   Convert['<'] := [one,two,three,six]; 
   Convert['>'] := [four,six]; 
   Convert['+'] := [one,four,six]; 
   Convert['-'] := [two,four,six]; 
   Convert['*'] := [one,two,four,six]; 
   Convert['/'] := [three,four,six]; 
   Convert['='] := [one,three,four,six]; 
   Convert['.'] := [two,three,four,six]; 
   Convert[','] := [one,two,three,four,six]; 
   Convert[':'] := [five,six]; 
   Convert[';'] := [one,five,six]; 
   Convert['^'] := [two,five,six]; 
   Convert['@'] := [two,five,six]; 
   Convert[' '] := [one,two,five,six]; 
   Convert[''''] := [one,two,three,five,six];
   firstline := true; 
   lineno := 0; 
   errorlines := 0; 
   end; {initialise} 
 
procedure printx; 
   procedure printreginhex( b: bits); 
      const 
         fourzeros = '0000'; 
      type 
         bitstring = packed array[1..4] of char; 
      var 
         i: regindex; 
         subreg1,subreg2,subreg3,subreg4 : bitstring; 
      procedure prnt(subreg : bitstring); 
         const 
            hex0='0000';  hex1='0001';  hex2='0010'; 
            hex3='0011';  hex4='0100';  hex5='0101'; 
            hex6='0110';  hex7='0111';  hex8='1000'; 
            hex9='1001';  hexA='1010';  hexB='1011';
            hexC='1100';  hexD='1101';  hexE='1110'; 
            hexF='1111'; 
         begin 
            if subreg=hex0 then write('0') 
            else if subreg=hex1 then write('1') 
            else if subreg=hex2 then write('2') 
            else if subreg=hex3 then write('3') 
            else if subreg=hex4 then write('4') 
            else if subreg=hex5 then write('5') 
            else if subreg=hex6 then write('6') 
            else if subreg=hex7 then write('7') 
            else if subreg=hex8 then write('8') 
            else if subreg=hex9 then write('9') 
            else if subreg=hexA then write('A') 
            else if subreg=hexB then write('B') 
            else if subreg=hexC then write('C') 
            else if subreg=hexD then write('D') 
            else if subreg=hexE then write('E') 
            else if subreg=hexF then write('F') 
         end; {prnt}
      begin 
      subreg1 := fourzeros;  subreg2 := fourzeros; 
      subreg3 := fourzeros;  subreg4 := fourzeros; 
      for i := 0 to 3 do 
         if b in SR[i] then 
            subreg1[i+1] := '1'; 
      for i := 4 to 7 do 
         if b in SR[i] then 
            subreg2[i-3] := '1'; 
      for i := 8 to 11 do 
         if b in SR[i] then 
            subreg3[i-7] := '1'; 
      for i := 12 to 15 do 
         if b in SR[i] then 
            subreg4[i-11] := '1'; 
      prnt(subreg1); 
      prnt(subreg2); 
      prnt(subreg3); 
      prnt(subreg4);
      write( ' ' ); 
      end; {printreginhex} 
   begin 
   writeln( 'Check digits are' ); 
   printreginhex(one); 
   printreginhex(two); 
   printreginhex(three); 
   printreginhex(four); 
   printreginhex(five); 
   printreginhex(six); 
   writeln; 
   writeln( 'Total number of lines', lineno : 8); 
   if errorlines > 0 then 
      writeln( 'Total number of errors', errorlines : 7); 
   writeln 
   end; {printx} 
 
procedure readline; 
   { Ignores initial spaces, 
     Replaces brackets by longer alternatives,
     Checks characters after 'linelength' are spaces, 
     Set 'lpos' to ignore trailing spaces, 
     Set 'blankline' as necessary.} 
 
   { In V4.2, error messages are output only for the first overlength 
     line or the first line with non-spaces after column 72, plus any 
     lines in the first ten errors containing non Pascal characters 
     (to keep the CHECKTEXT output consistent with that given in 
     earlier releases). 
     The total number of lines with errors is given. 
     These changes have been made to allow the CHECKTEXT program to be 
     used for checking the output produced during validation runs. } 
 
   var 
      ch: char; 
      charsread: integer; 
   procedure sub(chx, ch1, ch2: char); 
      { Substitute ch1 and ch2 for chx } 
      begin 
      if ch = chx then
         begin 
         if lpos > 72 then 
            begin 
            if errorlines = 0 then 
               writeln(' Line too long, line no', lineno); 
            errorlines := errorlines + 1 
            end 
         else 
            begin 
            line[lpos-1] := ch1; 
            line[lpos] := ch2; 
            end; 
         lpos := lpos + 1; 
         charsread := charsread + 1 
         end; 
      end;  { sub } 
 
   begin 
   lineno := lineno + 1;
   if eoln(input) then 
      blankline := true 
   else 
      begin 
      ch := input^; 
      charsread := 0; 
      while (ch = ' ') and (not eoln(input)) do 
         begin 
         get(input); 
         charsread := charsread + 1; 
         ch := input^; 
         end; 
      if eoln(input) then 
         blankline := true 
      else 
         begin 
         blankline := false; 
         lpos := 1; 
         while not eoln(input) do 
            begin
            if lpos <= 72 then 
               line[lpos] := ch; 
            lpos := lpos + 1; 
            { Text to be deleted if curly brackets not supported} 
            sub( '{', '(', '*' ); 
            sub( '}', '*', ')' ); 
            { End of curly bracket text } 
            { Text to be deleted if square brackets not supported} 
            sub( '[', '(', '.' ); 
            sub( ']', '.', ')' ); 
            { End of square bracket text } 
            if (charsread > 72) and (ch <> ' ') then 
               begin 
               if errorlines = 0 then 
                  writeln( 'Non-spaces after col 72 on line', lineno ); 
               errorlines := errorlines + 1 
               end; 
            get(input); 
            charsread := charsread + 1; 
            ch := input^;
            end; 
         lpos := lpos - 1; 
         if lpos > 72 then 
            lpos := 72; 
         while line[lpos] = ' ' do 
            lpos := lpos - 1; 
         end; 
      end; 
   get(input); 
   end; {readline} 
 
procedure processline; 
   { Checks all characters are valid Pascal characters. 
     Call check for each character. } 
   var 
      i: lineindex; 
      j: setbits; 
   begin 
   for i := 1 to lpos do
      begin 
      if firstline then 
         write(line[i]); 
      j := Convert[line[i]]; 
      if j = [ ] then 
         begin 
         if errorlines < 10 then 
            writeln( 'Non Pascal Character =', line[i], 
                   'on line no', lineno); 
         errorlines := errorlines +1 
         end 
      else 
         pulse(j); 
      end; 
   if firstline then 
      writeln; 
   pulse([one,three,five,six]); 
   firstline := false; 
   end; {processline} 

begin 
initialise; 
while not eof(input) do 
   begin 
   readline; 
   if not blankline then 
      processline; 
   end; 
printx;
end.