home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / MBUG / MBUG017.ARC / WORDC1.PAS < prev    next >
Pascal/Delphi Source File  |  1979-12-31  |  4KB  |  180 lines
  1. Program Lettercount;
  2.  
  3. Const
  4.   Name_length = 14;
  5.   Bufsize = 250;
  6.   Bufbytesize = 32000;
  7.   maxwordlen = 20;
  8.  
  9. Type
  10.   upper =  'A'..'Z';
  11.   lower =  'a'..'z';
  12.   frequecies = 0..maxint;
  13.   ucase = array[upper] of frequecies;
  14.   lcase = array[lower] of frequecies;
  15.   Name= String[Name_length];
  16.   charindex = 1..maxwordlen;
  17.   counttype = 1..maxint;
  18.   wordtype = array[charindex] of char;
  19.   pointer = ^entrytype;
  20.   entrytype = record
  21.     left,right : pointer;
  22.     word : wordtype;
  23.     count : counttype;
  24.   end;
  25.  
  26. var
  27.   Filename :name;
  28.   Master_file : file;
  29.   New_file :text;
  30.   buffer :array[1..bufbytesize] of byte;
  31.   Rec_to_read,
  32.   Remaining,I : integer;
  33.   No_Error : Boolean;
  34.   ch:char;
  35.   unumber:ucase ;
  36.   lnumber:lcase;
  37.   Lettercount:integer;
  38.   wordtree : pointer;
  39.   nextword : wordtype;
  40.   letters : set of char;
  41.   alphabet : set of char;
  42.   uppercase: set of upper;
  43.   lowercase: set of lower;
  44.  
  45. Function Exist(Filename:name):boolean;
  46. var
  47.   fil:file;
  48. begin
  49.   assign(fil,filename);
  50.   {$I-} reset(fil) {$I+};
  51.   if IOresult <>0 then exist := false else exist:=true;
  52. end;
  53.  
  54. Procedure Construct;
  55. begin
  56.   for ch := 'A' to 'Z' do unumber[ch]:=0;
  57.   for ch := 'a' to 'z' do lnumber[ch]:=0;
  58.   lettercount:=0;
  59.   No_error:=true;
  60.   remaining:=filesize(Master_file);
  61.   while (remaining >0) and No_error do begin
  62.     if bufsize <= remaining then
  63.       rec_to_read := bufsize
  64.     else
  65.       rec_to_read := remaining;
  66.     {$I-} blockread(Master_file,buffer,rec_to_read) {$I+};
  67.     if IOresult <>0 then No_error :=false;
  68.     for i := 1 to Rec_to_read*128 do begin
  69.       ch := chr(buffer[i]);
  70.       if ch in ['A'..'Z'] then begin
  71.         unumber[ch] := unumber[ch]+1;
  72.         lettercount :=lettercount+1;
  73.       end;
  74.       if ch in ['a'..'z'] then begin
  75.         lnumber[ch] := lnumber[ch]+1;
  76.         lettercount := lettercount+1;
  77.       end;
  78.     end;
  79.     remaining := remaining - Rec_to_read;
  80.   end;
  81. end;
  82.  
  83.  
  84. Procedure Readword(var packedword : wordtype);
  85. const
  86.   blank = ' ';
  87. var
  88.   buffer :array[charindex] of char;
  89.   charcount:0..maxwordlen;
  90.   ch:char;
  91. begin
  92.     if not eof(New_file) then
  93.     repeat
  94.       read(New_file,ch)
  95.     until eof(New_file) or (ch in letters);
  96.     if not eof(New_file) then begin
  97.         charcount:=0;
  98.         while ch in letters do begin
  99.           if charcount <maxwordlen then begin
  100.             charcount := charcount +1;
  101.             buffer[charcount] := ch;
  102.           end;{then}
  103.           if eof(New_file) then ch:=blank
  104.           else read(New_file,ch)
  105.         end;
  106.       for charcount := charcount +1 to maxwordlen do
  107.         buffer[charcount] := blank;
  108.   end;{while}
  109. end;
  110.  
  111. Procedure printword(packedword : wordtype);
  112. const
  113.   blank =' ';
  114. var
  115.   buffer : array[charindex] of char;
  116.   charpos : 1..maxwordlen;
  117. begin
  118.   for charpos :=1 to maxwordlen do
  119.     write(buffer[charpos]);
  120. end;
  121.  
  122. Procedure makentry(var tree:pointer; entry: wordtype);
  123. begin
  124.   if tree=nil then begin
  125.     new(tree);
  126.     with tree^ do begin
  127.       word := entry;
  128.       count :=1;
  129.       left := nil;
  130.       right := nil;
  131.     end;{with}
  132.   end
  133.   else with tree^ do
  134.     if entry < word then makentry(left,entry)
  135.     else if entry > word then makentry(right,entry)
  136.     else count := count +1;
  137. end;
  138.  
  139. Procedure printtree(tree:pointer);
  140. begin
  141.   if tree <> nil then
  142.     with tree^ do begin
  143.     printtree(left);
  144.     printword(word);
  145.     writeln(count);
  146.     printtree(right);
  147.   end;
  148. end;
  149.  
  150. begin
  151.   clrscr;
  152.   alphabet := ['A'..'Z']+['a'..'z'];
  153.   letters :=['A'..'Z','a'..'z'];
  154.   writeln('This program will count and tell you how many different letters');
  155.   writeln('are in a passage of text. It will list the letters and how many');
  156.   writeln('they occurr. Please enter the name of file to be read. ');
  157.   repeat
  158.   write('File Name >');
  159.   readln(filename);
  160.   until exist(filename);
  161.   assign(Master_file,filename);
  162.   reset(Master_file);
  163.   construct;
  164.   i:=0;
  165.   for ch := 'a' to 'z' do begin
  166.     write(ch:10,'=',lnumber[ch]:4);
  167.     i:=i+1;
  168.     if i mod 4 = 0 then writeln;
  169.   end;
  170.   writeln;writeln;
  171.   i:=0;
  172.   for ch :='A' to 'Z' do begin
  173.     write(ch:10,'=',unumber[ch]:4);
  174.     i:=i+1;
  175.     if i mod 4 = 0 then writeln;
  176.   end;
  177.   writeln;writeln;
  178.   writeln('Total letters in ',filename,' =',lettercount:6);
  179. end.
  180.