А вообще - ладно,
. Да и задачка уж больно забавная. Держите:
Код:
Type
SC=Set of Char;
Const
Sonants:SC=['б','в','г','д','ж','з','л','м','н','р'];
Var
W:Array[1..40] of SC;
S:String;
C:Char;
i,j,N,L:integer;
Found:SC;
b1,b2:boolean;
Begin
Writeln('Введите строку:');
Readln(S);
L:=Length(S);
Writeln;
j:=1;
i:=0;
Repeat
W[j]:=[];
repeat
Inc(i);
If (S[i]<>',') and (i<L) and (S[i] in Sonants) and not (S[i] in W[j]) then
W[j]:=W[j]+[S[i]];
until (S[i]=',') or (i=L);
if i<L then Inc(j);
Until i=L;
N:=j;
Found:=[];
for C:='б' to 'р' do
begin
b1:=false;
for j:=1 to N do
if (j mod 2)=1 then
if C in W[j] then b1:=true;
if b1 then
begin
b2:=false;
for j:=1 to N do
if (j mod 2)=0 then
if not (C in W[j]) then b2:=true;
end;
if b1 and b2 and not (C in Found) then Found:=Found+[C];
end;
If Found=[] then
Writeln('Таких букв нет!')
else
begin
Writeln('Результат:');
for C:='б' to 'р' do
if C in Found then write(C+' ');
end;
Readln
End.