Программа вывода последовательности цифр в порядке увеличения частоты их встречаемости

program Lab3;
 
uses
  crt;
 
const
  FILE1 = 'C:\Users\user\Desktop\Lab3\fname1.txt';
  FILE2 = 'C:\Users\user\Desktop\Lab3\fname2.txt';
 
type
  mas = array[1..10] of integer;
  matr = array[1..10] of mas;
 
procedure About;
begin
  writeln('Л***');
  writeln('В***');
  writeln;
  
  writeln('Г***');
  writeln('К***');
  writeln;
  
  writeln('Задание.');
  writeln('Требуется написать программу, которая для каждой строки исходного файла');
  writeln('будет выводить в результирующий файл последовательность цифр из входной');
  writeln('последовательности в порядке увеличения частоты их встречаемости.');
  writeln('Примечание.');
  writeln('* Каждая цифра при этом должна быть распечатана один раз.');
  writeln('* Если какие-то цифры встречаются одинаковое число раз,');
  writeln('то они выводятся по возрастанию.');
  writeln('Например.');
  writeln('Пусть в одной из строк исходного файла содержатся следующие символы:');
  writeln('123**24#32');
  writeln('В результирующем файле должно быть:');
  writeln('1432');
end;
 
//----
procedure Alg;
var
    s :string;
    d, p :array[0 .. 1000] of longint;
    i, c, j :longint;
begin
    read(s);
 
    for i := 1 to length(s) do
        inc(d[ord(s[i]) - 48]);
 
    for i := 0 to 9 do
        p[i] := i;
 
    for i := 1 to 100 do
        for j := 0 to 8 do
            if (d[p[j]] > d[p[j + 1]]) then begin
                c := p[j];
                p[j] := p[j + 1];
                p[j + 1] := c;
            end;
 
    for i := 0 to 9 do
        if (d[p[i]] <> 0) then 
            write(p[i]);
        
end;
//--- нашёл в интернете
  
procedure FileToFile(var f1, f2: text);
var
  s, t: string;
begin
  reset(f1); rewrite(f2); // открываем файл 1, перезаписываем файл 2
  while not eof(f1) do // подсчитываем количество символов
  begin               
    readln(f1, s);    
    if (s <> '') then Alg(s, t)
    else (t := '');
    writeln(f2, t);
    end;
    close(f1); close(f2);
    end;
    
procedure FileNew(var fname1, fname2: string; f1, f2: text);
begin
  writeln('Введите имя исходного файла:'); // запрашиваем C:\Users\user\Desktop\Lab3\fname1.txt
  readln(fname1);
  fname1 := FILE1;
  if FileExists(fname1) then
  begin
    writeln('Введите имя результирующего файла'); // запрашиваем C:\Users\user\Desktop\Lab3\fname2.txt
    readln(fname2);
    fname2 := FILE2;
    assign(f1, fname1); assign(f2, fname2); 
    FileToFile(f1, f2);
  end
  else writeln('Файл с таким именем не существует.');
  close(f1); close(f2); // закрываем файл
  readln;
end;
 
var
  fname1, fname2: string; f1, f2: text; 
 
begin
  About;
  FileNew(fname1, fname2, f1, f2);
end.

var
  s: String;
  b, c: array [0..9] of Integer;
  i, p, q, t: Integer;
begin
  while not EoF do begin
    ReadLn(s);
    for i:=0 to 9 do b[i]:=i;
    for i:=0 to 9 do c[i]:=0;
    for i:=1 to Length(s) do
      if s[i] in ['0'..'9'] then Inc(c[Ord(s[i])-Ord('0')]);
    q:=High(b);
    repeat
      p:=q; q:=0;
      for i:=0 to p-1 do
        if (c[i+1]<c[i]) or (c[i+1]=c[i]) and (b[i+1]<b[i]) then begin
          q:=i;
          t:=b[i]; b[i]:=b[i+1]; b[i+1]:=t;
          t:=c[i]; c[i]:=c[i+1]; c[i+1]:=t;
        end;
    until q=0;
    for i:=0 to 9 do if c[i]<>0 then Write(b[i]); WriteLn;
  end;
end.