Pascal/Turbo Pascal - Como hago este ejercicio de cadenas?

Dada una cadena de caracteres formada por varias palabras y separadas por espacios en blanco. Escribir un algoritmo que:

a) Muestre, separadas por una coma, las palabras que contengan, una misma vocal tres o mas veces. Además mostrar el total de palabras que cumplan con esa condición.
b) Reemplace, con igual cantidad de asteriscos (*), todas las palabras que contengan una subcadena dada e imprima la nueva cadena. En caso de no existir, debe enviar un mensaje indicando que no existe la subcadena dada.

(* algoritmo que:
a) Muestre,separadas
por una coma, las
palabras que
contengan, una misma
vocal tres o mas
veces.Además mostrar
el total de palabras
que cumplan con esa
condición.
Realizado por:

Armando Jose Fuenmayor
[email protected]

*)



program ff;
uses crt;
var
S , frase : string ;
vo : integer ;
(*****************************)
(* Retorna la posicion del *)
(* primer espacios en blanco *)
(* que consigue *)
(*****************************)
function bustab(cad:String): integer ;
var
g : Integer;
begin
g := Pos(' ', cad);
bustab:= g ;
end;


(***************************)
(* Elimina los espacios en *)
(* blanco y deja solo uno *)
(***************************)
function ggg(cad:string):string ;
var
y, i : Integer;
tem , t: string ;
begin
t := '';
tem := cad+' ';

for i:=1 to length(tem)-1 do
begin
if (tem[i] <> ' ') then
begin
y := i ;
inc(y);
if (tem[y] <> ' ') then
t := t + tem[i]
else
t := t + tem[i] + ' ';
end
else
begin
continue;
end;
end;
ggg := t;
end;

(*************************)
(* Retorna el numeros de *)
(* palabras *)
(*************************)
function cuentapalabra(cad:String): integer ;
var
tem : string ;
y, i : integer ;
begin

tem := ggg(cad)+' ';
y := 0;

for i:=1 to length(tem)-1 do
begin
if (tem[i] = ' ') then
begin
inc(y);
end;
end;
cuentapalabra:= y ;
end;

(***************************)
(* retorna verdadero si la *)
(* palabra tiene mas o igual a 3 *)
(* de una misma vocal *)
(*********************************)

function zzz(cad: string) : boolean;
var
ca, ce, ci,
co, cu, y: integer;
begin
ca := 0;
ce := 0;
ci := 0;
co := 0;
cu := 0;
if length(cad) < 3 then
begin
zzz := false;
break ;
end
else
begin
for y := 1 to length(cad) do
begin
case cad[y] of
'a','A' : begin
inc(ca);
case ca of
3 : begin
zzz := true;
break ;
end;
end;
end;
'e','E' : begin
inc(ce);
case ce of
3 : begin
zzz := true;
break ;
end;
end;
end;
'i','I' : begin
inc(ci);
case ci of
3 : begin
zzz := true;
break ;
end;
end;
end;

'o','O' : begin
inc(co);
case co of
3 : begin
zzz := true;
break ;
end;
end;
end;
'u','U' : begin
inc(cu);
case cu of
3 : begin
zzz := true;
break ;
end;
end;
end;
end;
end;

end;
end;

procedure
procesar(cad : string;
var convo:integer; var fff:string);

var
aux, aux1, tem, t, S : string ; convocal,
npal , y: integer ;
caracter : char ;


begin

tem := ggg(cad)+' ' ;
t := '';
aux := '' ;
aux1 := '' ;
convocal := 0 ;
for y := 1 to length(tem)-1 do
begin
if (tem[y] <> ' ') then
begin
t := t + tem[y] ;
aux:= aux + tem[y] ;
end
else
begin

if zzz(aux) then
begin
inc(convocal);
aux1 := aux1 + aux + ',';
aux := '';
end
else
begin
aux := '';
end;
end;
end ;

convo := convocal;
fff := aux1 ;
end;

begin
clrscr;
S := ' iiiii ooooo aa ii ee eeeeehh caracas';
writeLn('cadena original ');
writeln(S);
writeLn();
writeLn();


procesar(S,vo,frase);


if ( vo = 0) then
begin
writeln(' no hay palabmas de tres vocales Iguales ');


end
else
begin
writeln('N de palabras = ', vo);

writeln;
writeln;
writeln(frase);

end;

end.

(*
b) Reemplace, con
igual cantidad de
asteriscos '*'
todas las palabras
que contengan
una subcadena dada
e imprima la nueva
cadena. En caso de no
existir, debe enviar
un mensaje indicando
que no existe la
subcadena dada.
*)



uses crt;
var
cadesud, S : string;


function buscar(sudcad,cad:String): integer ;
var
g : Integer;
begin
g := Pos(sudcad, cad);
buscar := g ;
end;

function asterisco(sudcad,cad:string):string ;
var
a, b, i : Integer;
t: string ;
begin
a := buscar(sudcad , cad);
b := a+length(sudcad)-1;
t := '';

for i:=1 to length(cad) do
begin
if (i >=a) and (i <=b) then
begin
t := t + '*'
end
else
begin
t := t + cad[i] ;
end;
end;
asterisco := t;
end;


function mensaje(sudcad,cad:string):string ;
const
pa = 'No existe la subcadena ';
var
n : Integer;
a : string ;
begin
n := buscar(sudcad , cad);
if (n = 0) then
begin
mensaje := pa + sudcad;
break ;
end
else
begin
repeat
a:= asterisco(sudcad , cad);
cad := a;
until buscar(sudcad,cad) = 0;
end;

mensaje := a;
end;

procedure bbb;
var
res : string ;
begin
res := 'S';
while (res = 'S') do
begin
writeln('ingrese la cadena: ');
readln(s);
writeln('ingrese subcadena a buscar: ');
readln(cadesud);
clrscr;
writeln('Cadena: ', S);
writeln(' ', mensaje(cadesud,S));



writeln('Desea introducir otra sudcadena [S/N]');

readln(res);
clrscr;
res := upcase(res);

end;

end;


begin
clrscr();
bbb;




end.