Тестовые файлы(Паскаль)

[newcome]

Здравствуйте,помогите пожалуйста доработать программу.
Задание следующее:
В исходном текстовом файле записаны строки, содержащие текст на английском языке. Требуется написать программу, которая будет проводить частотный анализ текста и последовательно выводить в результирующий файл только букву и через пробел символ * в количестве, равном количеству повторений этой буквы в тексте (в каждой строке результирующего файла информация об одной букве, другие символы не учитываются). Сведения о буквах, которые в тексте отсутствуют, на экран выводиться не должны. Сами буквы должны выводиться в алфавитном порядке.
Например, для текста:
It is science
в результирующем файле должно быть:
C **
E **
I ***
N *
S**
T *

сам код:

   program lab7;
type     mas=array['a'..'z'] of integer;
procedure alg(s:string;var a:mas);
      var i:byte;c:char;
      begin
      for c:='a' to 'z' do a[c]:=0;
      for i:=1 to length(s) do
          begin
          if s[i] in ['a'..'z'] then a[s[i]]:=a[s[i]]+1;
          end;
      end;
Procedure FiletoFile(var f1,f2:text);
    var s:string;var a:mas;c:char;k:integer;
    begin
    reset(f1);
    rewrite(f2);
    while not eof(f1) do
       begin
       readln(f1,s);
       if s<>'' then
          begin
          alg(s,a);
          for c:='a' to 'z' do
             if a[c]>0 then begin
          write(f2,c,' ');
          for k:=1 to a[c] do write(f2,'*');
          writeln
          end
          else writeln(f2,#13);
     end;
  end;
end;
var f1,f2:text; fname1,fname2: string;
begin

writeln('Введите имя исходного файла');
     readln(fname1);
     if FileExists(fname1) then
        begin
        writeln('Введите имя результирующего файла');
        readln(fname2);
        assign(f1,fname1);
        assign(f2,fname2);
        FileToFile(f1,f2);
        close(f1);
        close(f2);
        end
     else writeln('файл не существует');
end.

проблема в том,что у меня для каждой строки выводит одинаковые буквы
Например я написал:
aaaaa
aaaaaaaa
У меня выводит:
a *****
a ********
На самом деле мне нужно чтобы выводило(складывало буквы со всех строк) и было вот так:
a *************

[Serge_Bliznykov]

уберите обнуление массива из процедуры alg.

procedure alg(s:string;var a:mas);
      var i:byte;c:char;
begin
    for c:='a' to 'z' do a[c]:=0;
      for i:=1 to length(s) do
....

вот, так попробуйте:

procedure alg(s: string; var a: mas);
var i: byte;
begin
  for i := 1 to length(s) do
  begin
    if s[i] in ['a'..'z'] then a[s[i]] := a[s[i]] + 1;
  end;
end;

procedure FiletoFile(var f1, f2: text);
var s: string; var a: mas; c: char; k: integer;
begin
  reset(f1);
  rewrite(f2);

    //обнулим массив
  for c := 'a' to 'z' do a[c] := 0;

  while not eof(f1) do
  begin
    readln(f1, s);
    alg(s, a);
  end;

  // сохраним результаты массива подсчёта в выходной файл
  for c := 'a' to 'z' do
    if a[c] > 0 then begin
      write(f2, c, ' ');
      for k := 1 to a[c] do write(f2, '*');
      writeln(f2, #13);
    end;
end;

p.s. Если пользуйтесь всякими извращениями в виде PascalABC - то обязательно это указывайте!