Задача. Дан текст. Группы символов, разделенные пробелами (одним или несколькими) и не содержащиее пробела внутри себя, будем называть словами.
а) Для каждого из слов указать, сколько раз оно всречается среди всех слов, образованных символами данного текста.
б) Найти все слова, содержащие наибольшее количество гласных латинских букв (a, e, i, o, u).
в) Найти все слова, в которых доля букв a, b максимальна.
г) В тех словах, которые оканчиваются сочтетанием букв ing, заменить это окончание на ed.
Условия под а и б есть, помогите с в и г
вот код

Uses Crt;
const
max_word = 200; максимальное количество символов
Var word
: array[0..max_word] of string;
count
: array[0..max_word] of byte;
procedure add_word(s : string);
var
i
: byte;
begin
if s = ''
then
exit;
i := 0;
while word[i] <> '' do
begin
if s = word[i]
then
begin
inc(count[i]);
exit;
end;
inc(i);
end;
word [i]   := s;
count[i]   := 1;
word [i+1] := '';
end;
procedure make(text : string);
var
temp
: string;
i
: byte;
begin
word[0] := '';
temp    := '';
for i := 1 to length(text) do
begin
if text[i] = ' '
then
begin
add_word(temp);
temp := ' '
end;
temp := temp + text[i];
end;
add_word(temp);
end;
function calc: byte;
var
n,
i,
max : byte;
begin
n := 0;
max := 0;
while word[n] <> '' do
begin
count[n] := 0;
for i := 1 to length(word[n]) do
if word[n][i] in ['a', 'e', 'i', 'o', 'u']
then
inc(count[n]);
if count[n] > max
then
max := count[n];
inc(n);
end;
calc := max;
end;
Var
i, max
: byte;
text
: string;
Begin
ClrScr;
WriteLn ('Введите текст:'); readln(text); make(text);
i := 0;
while word[i] <> '' do begin
writeln( 'Слово ', word[i], ' встречается - ', count[i],
' раз(а)');
inc(i);
end;
readln;
max := calc;
if max <> 0
then
begin
writeln('Максимальное количиство латинских букв (a, e, i, o, u) ',
max, ' находится в слове :');
i := 0;
while word[i] <> '' do
begin
if count[i] = max
then
writeln('''', word[i], '''');
inc(i);
end;
end;
readln;
End.

Ну вот тебе набросок для г)

WriteLn ('Введите текст:'); readln(text);
make(text); { разбиваешь строку на слова - твоя же процедура }
i := 0;
while word[i] <> '' do begin
  p := pos('ing', word[i]);
  if (p > 0) and ((p + 3)=(length(word[i]) + 1)) then
    word[i] := copy(word[i], 1, pred(p)) + 'ed';
  inc(i);
end;
... { вывод на печать }

Спасибо за г осталось
ну а с б что делать?

б

Type
 TextType = array[1..20] of string;
 SlovaType = array[1..60]of string[10];

Procedure SepWord(A:TextType; TextLength:word; var S:SlovaType; var K:word);
Var
 r:set of char; sl:boolean; i,j:Integer; ss:string;
Begin
 K:=1; ss:='';
 sl:=false; r:=[',','.',' ',';',':','!','?','"','(',')','_','#'];
 For I:=1 to TextLength do
 begin
  For j:=1 to length(A[i]) do
  begin
   If (j=length(A[i])) and (length(a[i])>0) then begin ss:=ss+a[i,j]; sl:=false; s[k]:=ss; ss:='';INC(k); end else
   begin
    If (not(A[i,j] in r)) and (Sl=false) then begin  sl:=true; ss:=ss+a[i,j] end else
    begin
     If (not(A[i,j] in r)) and Sl then ss:=ss+a[i,j];
    end;
    If (A[i,j] in r) and sl then begin  sl:=false; s[k]:=ss; ss:='';INC(k); end;
   end
  end
 end
end;

Procedure  GetMGWord(S:SlovaType;  K:word; var ssl:SlovaType; var n:word);
var
 i,j:word;
 gl:set of char; ss,smax:word;
 sl:boolean;
begin
 gl:=['e','u','i','o','a']; ss:=0; smax:=0; N:=1;
 for i:=1 to k do
 begin
  for j:=1 to length(s[i]) do if s[i,j] in gl then Inc(ss);
  If ss>smax then smax:=ss; ss:=0;
 end;
 For i:=1 to k do
 begin
  for j:=1 to length(s[i]) do if s[i,j] in gl then Inc(ss);
  sl:=true;
  For j:=1 to length(s[i]) do If ORD(s[i,j])>123then sl:=false;
  If (ss=smax) and sl then begin ssl[n]:=s[i]; inc(n) end;
  ss:=0;
 end
end;

Var
 Text:texttype;
 slova,ssl:slovatype;
 i:byte;
 k,n:word;
Begin
 i:=1;
 writeln('Введите текст (окончаниетекста- строкас символом#) '); 
repeat
  readln(text[i]);
  If POS('#',text[i])=0 then inc(i);
 Until POS('#',text[i])<>0;
 SepWord(text,i,slova,k);
 GetMGWord(slova,k,ssl,n);
 
 For i:=1 to n do writeln(ssl[i]);
end.

бэбэп.. может я чот не догоняю , так не проще ? :

uses crt;
const
    limits=[#0..#32,'.',',',';','!','?'];
    chars=['a','e','u','i','o'];

var
   s,result:string;
   i,j,bword,count,max:integer;

Begin
   clrscr;

   write('s='); readln(s);

   i:=1; max:=0; result:='';
   while(i<=length(s)) do
    begin

       while(i<=length(s))and(s[i] in limits) do
        inc(i);

       if(i<=length(s)) then
        begin
           bword:=i;
           while(i<=length(s))and(not(s[i] in limits)) do
            inc(i);
           count:=0;
           for j:=bword to i-1 do
            if s[i] in chars then
             inc(count);

           if (max=0)or(count>max) then
            result:=copy(s,bword,i-bword);

        end;
    end;

    writeln('Result=',result);
    readln;
end.

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

бррр может надо заполнитьмассив из слов, в которых содержания заданных гласных превышает общее колво букв ?

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

Максимальное кол-во гласных юукв может содержать скольку огодно слов...

Не проще, и на то есть причины....
у нас в группе у каждого было задание , в общем- это разбить текст на слова, а далее у каждого свое, так вот человекам 5-ым я помог сделать программы, и в них мне приходилось менять всего 5-6 строчек, а теперь подумай, как изменить твою программу под другое задание?
Мне не важно сколько строчек кода займет программа, мне важно сколько времени я буду ее делать и насколько просто будет ее сопровождать!
Если надо, еще и эффективность учитываю...

чтобы реализовать в моей программе массив слов, надо добавить 2 строчки ;)
так что я неочень понял в чем проблема.

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

ясли я не прав, объясните как моджет быть несколько максимумов ?

Вот тебе список слов, в которых доля букв 'a' и 'b' максимальна:
'bbqwer', 'aasdf', 'aamnbv' (не правда ли, буквы 'a' и 'b' встречаются в этих словах чаще, чем все остальные?)

все, понял, прошу прощения, был не прав.

дабы исправиться могу предложить вот такой вариант, если я правильно наконецто понял задание, то вот :

uses crt;
const
    limits=[#0..#32,'.',',',';','!','?'];
    chars=['a','e','u','i','o'];

var
   s:string;
   result:array[1..20] of string;
   i,j,k,l,bword,count,count1:integer;
   flag:boolean;

Begin
   clrscr;

   write('s='); readln(s);

   i:=1; l:=0;
   while(i<=length(s)) do
    begin

       while(i<=length(s))and(s[i] in limits) do
        inc(i);

       if(i<=length(s)) then
        begin

           bword:=i;
           while(i<=length(s))and(not(s[i] in limits)) do
            inc(i);

           count:=0;
           for j:=bword to i-1 do
            if s[j] in chars then
             inc(count);

           j:=bword; flag:=false;
           while(j<=i-2)and(not(flag)) do
            begin
               flag:=false; count1:=1;
               k:=j+1;
               while(k<=i-1) do
                begin
                   if (not(s[j] in chars))and(s[j]=s[k]) then
                 inc(count1);
                 inc(k);
                end;
               if count1>count then
                flag:=true
               else
                inc(j);
            end;

           if not flag then
            begin
               inc(l);
               result[l]:=copy(s,bword,i-bword);
            end;
        end;
    end;

    writeln;
    if l<>0 then
    for i:=1 to l do
     write(result[i],'  ')
    else writeln('No');
    readln;
end.

то-то же

Ты не понял, яимел ввобще другие задания, просто восновекоторых лежит
разбиение текста на слова, яимею ввиду сразу весь КЛАСС задач.

p.s. ну а теперь ты тоже скажешь что в твоей проге проще разобраться?

Огромное СПАСИБО!!