Перечислить все слова каждого предложения, которые состоят из тех же букв, что и первое слово данного предложения

var a:array[1..50] of string;
i,n,j,np,k,g,l:integer;
s,s1,s2,buf:string;
f:text;
begin
assign(f,'Night.txt');
reset(f);
while not eof(f) do begin
read(f,s);
write(s);
end;
writeln;
While Pos('.',s)>0 do
    begin
      s1:=Copy(s,1,Pos('.',s)-1);
      Delete(s,1,Pos('.',s));
      if s1<>'' then
      Begin
        inc(n);
        A[n]:=s1;
      End;
    End;
    For i:=1 to n do
     writeln(A[i]);
for i:=1 to n do begin
s1:=a[i];
for j:=1 to length (s1) do begin
if s1[j]<>'' then s2:=s2+s1[j]
else begin
np:=j;
end;
for l:= np + 1 to length(s1) do
if s1[l] <> ' ' then buf := buf + s1[l] else begin
if length(buf) < length(s2) then begin
for k:= 1 to length(buf) do begin
for g:= 1 to length(s2) do
            if buf[k] = s2[g] then begin
              writeln(buf);
              break;
            end;
          break;
        end;
        buf := '';
      end else begin
    for j := 1 to length(s2) do
        begin
          for g := 1 to length(buf) do
            if buf[g] = s2[j] then begin
              writeln(buf);
              break;
            end;
          break;
        end;
        buf := '';
      end;
    end;
    end;
    end;
    close(f);
end.

 const mnr=[' ',',','.','-','_','!','?',':',';'];
 Var A:array[1..30] of string;
    i,n,j,np,k,g,l:byte;
    s,s1,s2,buf,st:string;
    f:text;
    mnpr,mnbuf:set of char;
Begin
assign(f,'Night.txt');
reset(f);
while not eof(f) do begin
read(f,s);
write(s);
end;
writeln;
    While Pos('.',s)>0 do
    Begin
      s1:=Copy(s,1,Pos('.',s)-1);
      Delete(s,1,Pos('.',s));
      if s1<>'' then
      Begin
        inc(n);
        A[n]:=s1+'.';
      End;
    End;
    For i:=1 to n do begin
     writeln(A[i]);
     st:=st+a[i];
     end;
for i:=1 to n do begin
s1:=a[i];
for j:=1 to length (s1) do begin
if not (s1[j] in mnr) then s2:=s2+s1[j]
else
begin
np:=j;
break;
end;
end;
for k:=1 to length(s2) do begin 
if not(s2[k] in mnpr) then 
mnpr:=mnpr+[s2[k]];
end;
for l:= np + 1 to length(s1) do begin
if not(s1[l] in mnr) then begin
buf := buf + s1[l];
mnbuf:=mnbuf+[s1[l]];
end
else
begin
if mnpr=mnbuf then st:=st+buf+' ';
buf:='';
mnbuf:=[];
end;
end;
s2:='';
mnpr:=[];
end;
writeln;
write(st);
close(f);
end.