Вывести в алфавитном порядке слова текста, в которых повторяется первая буква
Категория: Delphi/Pascal
2012-03-03 19:08:39
Дана строка, содержащая русский текст. Вывести в алфавитном порядке слова текста, в которых повторяется первая буква, в остальных словах удалить звонкие согласные и продублировать гласные буквы. (Звонкие согласные: бвгжздйлмнр)
code: #pascal
program PascalGuru; uses crt; label 1,2; var s,zs,zp,gl,slovo,l:string; i,j,p,n,nn:integer; m:array [1..80] of string; b:boolean; procedure exchange(var a,b:string); var c:string; begin c:=a; a:=b; b:=c; end; {------------------------------------------} begin write('Stroka: '); readln(s); zp:='!?*,.'; {все знаки препинания} zs:='бвгжздйлмнр'; gl:='аоуыэяеёюи'; {начало разбиения предложения на слова} p:=pos(' ',s); i:=0; repeat inc(i); slovo:=copy(s,1,p-1); if pos(slovo[length(slovo)],zp)<>0 then delete(slovo,length(slovo),1); m[i]:=slovo; delete(s,1,p); p:=pos(' ',s); until p=0; n:=i+1; m[n]:=s; {массив со словами} {--конец разбиения предложения на слова} {************сортировка по алфавиту**************************** } nn:=n; repeat b:=false; for j:=1 to nn-1 do BEGIN i:=1; l:=m[j]; s:=m[j+1]; While (I<=5)and(l[i]=s[i]) do inc(i); If i>5 then writeln('the same') else if ord(l[i])>ord(s[i]) then begin exchange(m[j+1],m[j]); b:=true; end; END; dec(nn); until not b; {************************************************************* } writeln; writeln('*Slova teksta, v kotoryh povtoryaetsya pervaya bukva:'); for i:=1 to n do {проход по массиву слов строки} begin s:=m[i]; b:=false; for j:=2 to length(s) do if s[1]=s[j] then b:=true; if b then writeln(s);{выводим} end; {--------------------------------------------------------------------} writeln; writeln('*Ostalinye slova (obnovlennye) teksta:'); for i:=1 to n do {проход по массиву слов строки} begin s:=m[i]; b:=false; for j:=2 to length(s) do if s[1]=s[j] then b:=true; if not b then begin {удаляем} 1: for j:=1 to length(s) do if pos(s[j],zs)<>0 then begin delete(s,j,1); goto 1; end; {дублируем} j:=1; repeat if pos(s[j],gl)<>0 then begin insert(s[j],s,j); inc(j,2); end else inc(j); until j>length(s); writeln(s);{выводим обновлённый} end; end; readln; end.
Поделиться: