Оставить в файле только первые 3 вхождения символа *

type 
fs=file of char;

uses crt;
type tyfile=file of char;
procedure First(var f1:tyfile);
var i,j,k,p:integer;
    a,b:char;
begin
{считаем *}
reset(f1);
k:=0;p:=0;
for i:=0 to filesize(f1)-1 do
 begin
  seek(f1,i);
  read(f1,a);
  if (a='*')and(k<=3)then k:=k+1;{считаем}
  if (k>3)and(p=0) then p:=i;{если уже больше трех, но первый раз, лишнии *}
 end;
close(f1);
if p=0 then write('В файле не более 3х символов *')
else
 begin
  reset(f1);
  i:=p;k:=0;
  while i<filesize(f1)-2-k do
   begin
    seek(f1,i);
    read(f1,a);
    if a='*' then
     begin
      k:=k+1; {считаем лишние}
      for j:=i to filesize(f1)-2 do{идем вперед}
       begin
        seek(f1,j+1);{переставляем - сдвигаем - записи вверх на 1(удаляем)}
        read(f1,b);
        seek(f1,j);
        write(f1,b);
       end
     end
    else i:=i+1;{если нет вперед}
   end;
  seek(f1,filesize(f1)-1-k);{проверяем последнюю, она сдвинулась на k вверх}
  read(f1,a);
  if a='*' then k:=k+1;
  seek(f1,filesize(f1)-1-k);{встаем в последнюю не удаленную запись}
  truncate(f1);{обрезаем файл}
  close(f1);
  writeln('Удаление символов *, входящих более 3 раз:');
  reset(f1);
  while not eof(f1) do
   begin
    read(f1,a);
    write(a);
   end;
  close(f1);
 end;
end;
var  f:tyfile;
     a:char;
     n,i:integer;
begin
clrscr;
assign(f,'simbol');
rewrite(f);
write('Сколько символов ввести в файл n=');
readln(n);
writeln('Введите в файл символы, в том числе *');
for i:=1 to n do
 begin
  readln(a);
  write(f,a);
 end;
clrscr;
writeln('Исходный файл:');
reset(f);
while not eof(f) do
 begin
  read(f,a);
  write(a);
 end;
writeln;
close(f);
First(f);
readln
end.