Type
ustring=array[1..129] of string;
CLat=array[1..129] of byte;
Const
MesU1_1='V predlogenii est povtornie lat-ie simvoli,';
MesU1_2='predlogenie uporadocheno po ubivaniy kol-va lat-ih bukv v slovah.';
MesU2_1='V predlogenii net povtornih lat-ih bukv.';
MesU2_2='Kol-vo slov palindromov - ';
var
s: string;
m: ustring;
n: byte;

Procedure UnPack(s: string; var m: ustring; var n: byte);
Const
LetM=['a'..'z','A'..'Z'];
var
i: byte;
L: integer;
begin
L := Length(s);
n := 1;

for i := 1 to 129 do m[i] := '';

i := 1;
while (i<=L) do
begin
if (s[i] in LetM) then
m[n] := m[n] + s[i]
else
if m[n] <> '' then
Inc(n);
Inc(i);
end;
{if not(s[L-1] in LetM) then Dec(n);}
end;

function LatDouble(var m: ustring; n: byte): boolean;
Const
Lat=['a'..'z','A'..'Z'];
Var
k,L,i,j: byte;
begin
LatDouble := false;
k := 0;
for i := 1 to n do
begin
L := Length(m[i]);
k := 0;
for j := 1 to L do
begin
if m[i][j] in Lat then Inc(k);
if k>1 then
begin
LatDouble := true;
exit;
end;
end;
end;
end;

procedure SortU(var m: ustring; n: byte);
Const
Lat=['a'..'z','A'..'Z'];
var
c: CLat;
k,j,L,b: byte;
buf: string;
begin
for k := 1 to n do
begin
L := Length(m[k]);
c[k] := 0;
for j := 1 to L do
begin
if m[k][j] in Lat then Inc(c[k]);
end;
end;

for k := 1 to n do
for j := 1 to n-1 do
begin
if c[j]<c[j+1] then
begin
buf := m[j];
b := c[j];
m[j] := m[j+1];
c[j] := c[j+1];
m[j+1] := buf;
c[j+1] := b;
end;
end;
end;

function IsPal(s: string): boolean;
var
s1: string;
L,i: byte;
begin
L := Length(s);
if L=1 then
begin
IsPal := true;
exit;
end;
for i := 1 to Trunc(L) do
begin
s1[i] := s[L-i];
end;
IsPal := (s1=s);
end;

function StrPal(var m: ustring; n: byte): byte;
var
k,i: byte;
begin
k := 0;
StrPal := 0;
for i := 1 to n do
if IsPal(m[i]) then Inc(k);
StrPal := k;
end;

procedure PrintP(var m: ustring; n: byte);
var
i: byte;
begin
for i := 1 to n do
begin
write(m[i],' ');
end;
writeln;
end;

begin
Write('Vvedite predlogenie: ');
Readln(s);
UnPack(s,m,n);
if n<>0 then
if LatDouble(m,n) then
begin
SortU(m,n);
writeln(MesU1_1,#13#10,MesU1_2);
PrintP(m,n);
end
else
begin
write(MesU2_1,#13#10,MesU2_2);
writeln(StrPal(m,n));
end;
End.

program p3;
Type
   ustring=array[1..129] of string;
   LatS=array[1..26] of byte;
var
   s: string;
   m: ustring;
   n: byte;

Procedure UnPack(s: string; var m: ustring; var n: byte);
Const
   LetM=['a'..'z','A'..'Z'];
var
   i: byte;
   L: integer;
begin
   L := Length(s);
   n := 1;
   for i := 1 to 129 do m[i] := '';
   i := 1;
   while (i<=L) do
   begin
     if (s[i] in LetM) then
       m[n] := m[n] + s[i]
     else
       if m[n] <> '' then
       begin Inc(n); end;
     Inc(i);
   end;
{  if not(s[L-1] in LetM) then Dec(n);}
end;

function PovC(s: string): boolean;
Const
   LetM=['A'..'Z'];
var
   sm: LatS;
   i: byte;
   x: char;
begin
   PovC := false;
   for i := 1 to 26 do
   sm[i] := 0;
   for i := 1 to Length(s) do
   begin
     x := UpCase(s[i]);
     if (x in LetM) then Inc(sm[Ord(x)-64]);
     if sm[Ord(x)-64]>1 then
     begin
       PovC := true;
       exit;
     end;
   end;
end;

function PovtC(var m: ustring; n: byte): boolean;
Var
   i: byte;
begin
   PovtC := false;
   for i := 1 to n do
     if PovC(m[i]) then
     begin
       PovtC := true;
       exit;
     end;
end;

procedure SortU(var m: ustring; n: byte);
Const
   Lat=['a'..'z','A'..'Z'];
var
   k,j: byte;
   buf: string;
begin
   for k := 1 to n do
   for j := 1 to n-1 do
   begin
     if Change(m[j],m[j+1]) then
     begin
       buf := m[j];
       m[j] := m[j+1];
       m[j+1] := buf;
     end;
   end;
end;

program p3;
uses crt;
Type
   ustring=array[1..129] of string;
   LatS=array[1..26] of byte;
Const
   M_S=['A'..'Z'];
var
   s: string;
   m: ustring;
   n: byte;

Procedure UnPack(s: string; var m: ustring; var n: byte);
Const
   LetM=['a'..'z','A'..'Z'];
var
   i: byte;
   L: integer;
begin
   L := Length(s);
   n := 1;
   for i := 1 to 129 do m[i] := '';
   i := 1;
   while (i<=L) do
   begin
     if (s[i] in LetM) then
       m[n] := m[n] + s[i]
     else
       if m[n] <> '' then
       begin Inc(n); end;
     Inc(i);
   end;
{  if not(s[L-1] in LetM) then Dec(n);}
end;

function PovC(s: string): boolean;
Const
   LetM=['A'..'Z'];
var
   sm: LatS;
   i: byte;
   x: char;
begin
   PovC := false;
   for i := 1 to 26 do
   sm[i] := 0;
   for i := 1 to Length(s) do
   begin
     x := UpCase(s[i]);
     if (x in LetM) then Inc(sm[Ord(x)-64]);
     if sm[Ord(x)-64]>1 then
     begin
       PovC := true;
       exit;
     end;
   end;
end;

function PovtC(var m: ustring; n: byte): boolean;
Var
   i: byte;
begin
   PovtC := false;
   for i := 1 to n do
     if PovC(m[i]) then
     begin
       PovtC := true;
       exit;
     end;
end;

function Change(s1: string; s2: string): boolean;
var
   s: string;
   i: byte;
begin
   Change := false;
   s := s1;
   if s1>s2 then s := s2;
   for i := 1 to Length(s) do
   begin
     if Ord(s1[i])<Ord(s2[i]) then
     begin
       Change := true;
       exit;
     end;
   end;
   if s2>s1 then Change := true;
end;

procedure SortU(var m: ustring; n: byte);
Const
   Lat=['a'..'z','A'..'Z'];
var
   k,j: byte;
   buf: string;
begin
   for k := 1 to n do
   for j := 1 to n-1 do
   begin
     if Change(m[j],m[j+1]) then
     begin
       buf := m[j];
       m[j] := m[j+1];
       m[j+1] := buf;
     end;
   end;
end;

function S_in_S(var m: ustring; n: word): boolean;
var
   i,j: byte;
begin
   S_in_S := true;
   for i := 1 to n do
   for j := 1 to Length(m[i]) do
   begin
     if not(m[i][j] in M_S) then
     begin
       S_in_S := false;
       exit;
     end;
   end;
end;

function IncS(s: string; c: char): boolean;
var
    i: integer;
    n: byte;
begin
    n := Length(s);
    for i := 1 to n do
       if (s[i]=c) then
       begin
          IncS := true;
          Exit;
       end;
end;

function IncSm(m: ustring; c: char; n: byte): byte;
var
    i: integer;
    k: byte;
begin
    for i := 1 to n do
       if IncS(m[i],c) then Inc(k);
    IncSm := k;
end;

procedure PrintP(var m: ustring; n: byte);
var
   i: byte;
begin
   for i := 1 to n do
   begin
     write(m[i],' ');
   end;
   writeln;
end;

begin
  clrscr;
   Write('Vvedite predlogenie: ');
   Readln(s);
   UnPack(s,m,n);
   if n<>0 then
     if PovtC(m,n) then
     begin
       SortU(m,n);
       PrintP(m,n);
     end
     else if S_in_S(m,n) then
     begin
       SortU(m,n);
       PrintP(m,n);
     end
     else  
     writeln('4uCLO CLOB C "e" ', IncSm(m,'e',n));
     readkey;
End.

Uses CRT;
Const
      A: String = 'cde  fghtr   ops  ab';
      B: String = 'x';
Type
     ARR = Array[1..16] of String[16];
Var
    s: String;
    i, j, count: byte;
    mas: ARR;
    temp: string[16];

    flag1, flag2: Boolean;
    countE: Byte;

Procedure DelSpaces(var s: String);
Var i: Byte;
Begin
{Убираем лишние пробелы}
i := 0;
While (i < length(s)) do
       Begin
       if (s[i] = ' ') and (s[i+1] = ' ') then Delete(s, i, 1)
                    else Inc(i);
       End;
End;

Procedure WordsSplit(var s: String; var count: Byte);
Var j: Byte;
Begin
j := 1;
{Разделяем строку на слова}
For i := 1 to length(s) do
     Begin
     If (s[i] = ' ') then
        Begin
        Inc(count);
        mas[count] := Copy(s, j, i-j);
        j := i+1;
        End;
     End;
inc(count);
mas[count] := Copy(s, j, length(s)-j+1);
{Конец разделения на слова}
End;

Function CheckAtoB(B: String; A: String): Boolean;
Var i: Byte;
     flag: Boolean;
Begin
{Проверяем, входит ли какой-нибудь символ A в множество B}
flag := False;
For i := 1 to length(B) do
     Begin
     if (Pos(B[i],s) <> 0) then
        Begin
        flag := true;
        Writeln(#13#10,'В множестве А найден символ ',B[i]);
        break;
        End;
     End;
{Закончили проверку}
CheckAtoB := flag;
End;

Function CheckDublChar(A: String): Boolean;
Var i, j: Byte;
     flag: Boolean;
Begin
flag := False;
For i := 1 to length(A)-1 do
     Begin
     if (flag) then Break;
     For j := i+1 to length(A) do
         if (A[i] = A[j]) and (A[i] <> ' ') then
            Begin
            flag := true;
            Writeln('Найдены повторяющиеся символы: ',s[i], ' ', s[j]);
            Break;
            End;
     End;
CheckDublChar := flag;
End;

Function LeftRight(s1, s2: String): Boolean;
Var i: Byte;
Begin
For i := 1 to length(s1) do
     Begin
     if (s1[i] = s2[i]) then Continue
        else
        If (s1[i] < s2[i]) then
             Begin
             LeftRight := False;
             Exit;
             End
        else
            Begin
            LeftRight := True;
            Exit;
            End;
     End;
End;

Procedure SortWords(var mas: ARR);
Var i, j: Byte;
     t: String[16];
Begin
For i := 1 to count-1 do
     For j := i to count do
         Begin
         if (LeftRight(mas[i], mas[j])) then
            Begin
            t := mas[i];
            mas[i] := mas[j];
            mas[j] := t;
            End;
         End;
End;

Begin
s := A;
ClrScr;
DelSpaces(s); {Удаляем пробелы}
WordsSplit(s, count); {Разделяем на слова}
Writeln('Строка: ', s); {Выводим строку}
Writeln('Массив слов: '); {Выводим массив слов}
For i := 1 to count do Writeln(i,' ',mas[i]);

flag1 := CheckAtoB(B, s); {Входит ли символ из Б в А}

{Проверяем на повторяющиеся символы}
if (flag1 = false) then
    flag2 := CheckDublChar(s);

{Если повторяющихся символов нет, то сортируем слова}
if (flag1 or flag2 = false) then
    Begin
    SortWords(mas);
    Writeln('Массив слов после сортировки: ');
    For i := 1 to count do
        Writeln(i,' ',mas[i]);
    End;

{УСЛОВИЕ 2 - во сколько слов входит буква "e"}
For i := 1 to count do
     if ((Pos('e', mas[i]) > 0) or (Pos('E',mas[i]) > 0)) then inc(countE);
Writeln('Буква "e" входит в ',countE,' слов');
ReadKey;
End.