Сформировать текстовый файл, содержащий строки исходного файла, встречающиеся в нем один раз

var
  f1, f2 : text;
  s : string;
  ar : array [1..1000] of string;
  i, k : integer;
 
Procedure Toar(s : string);
var i : integer;
    f : boolean;
begin
  f := false;
  for i := 1 to k do
    if (s = ar[i])
    then begin
      f := true;
      break;
    end;
 
  if not f
  then begin
    k := k + 1;
    ar[k] := s;
  end;
end;
 
begin
  Assign(f1, '1.txt');
  Assign(f2, '2.txt');
  Reset(f1);
  Rewrite(f2);
 
  k := 0;
  writeln('Ishodniy:');
  while(not EoF(f1)) do begin
    readln(f1, s);
    writeln(s);
    Toar(s);
  end;
 
  writeln('Result:');
  for i := 1 to k do begin
    writeln(ar[i]);
    writeln(f2, ar[i]);
  end;
 
  close(f1);
  close(f2);
  readln;
end.

 ar : array [1..100] of string;

uses crt;
var
a:array[1..100] of string;
i:byte;
k1,k:integer;
f,r:text;
s:string;
procedure Preobrazowanie(var s:string);
var
i,k:integer;
fo,ro:text;
begin
assign(fo,'1.txt');
assign(ro,'2.txt');
reset(fo);
rewrite(ro);
k:=length(s);
while not Eof(fo) do
      for i:=1 to 0 do
      if (s=a[i]) then writeln(ro,a[i]);
      end;
begin
clrscr;
assign(f,'file.txt');
assign(r,'rez.txt');
reset(f);
rewrite(r);
k:=length(s);
while not Eof (f) do begin
readln(f,s);
writeln(s);
preobrazowanie(s);
end;
writeln('resultat');
for i:=1 to k do begin
writeln(a[i]);
writeln(r,a[i]);
end;
close(f);
close(r);
readln;
end.

uses crt;
procedure Preobrazowanie(var fo,ro:text;var n:integer);
var a:array[1..100] of string;
    i,j,k,p:integer;
begin
assign(fo,'1.txt');
assign(ro,'2.txt');
reset(fo);
rewrite(ro);
writeln('Исходный файл:');
k:=0;
while not Eof(fo) do
 begin
  k:=k+1;
  readln(fo,a[k]);
  writeln(a[k]);
 end;
close(fo);
n:=0;
for i:=1 to k do
 begin
  p:=0;
  j:=1;
  while(j<=k)and(p<2) do
   begin
    if a[j]=a[i] then p:=p+1;
    j:=j+1;
   end;
  if p=1 then
   begin
    n:=1;
    writeln(ro,a[i]);
   end;
 end;
close(ro);
end;
procedure NewFile(var ro:text;n:integer);
var s:string;
begin
reset(ro);
writeln('Итоговый файл');
if n=0 then write('Нет ни одной строки, встречающейся 1 раз')
else
 begin
  writeln('Строки, встречающиеся 1 раз');
  while not eof(ro) do
   begin
    readln(ro,s);
    writeln(s);
   end;
 end;
close(ro);
end;
 
var  f,r:text;
     n:integer;
begin
clrscr;
preobrazowanie(f,r,n);
NewFile(r,n);
readln;
end.