Паскаль. Задача на строку

[Robocopp]

Вводится непустая строка из строчных русских букв.Отдельные слова в ней разделены запятыми.Вывести на печать в алфавитном порядке звонкие согласные которые входят хотя бы в одно нечетное слово и не входят хотя бы в одно четное

USES crt;

CONST
zs : set of char = ['Ў','ў','Ј','¤','¦','§','«','¬','*' ,'а'];


VAR
st : string[79];
d, n, k, i : integer;
sl, mnechet, mchet, vm : set of char;
chet : boolean;
c : char;

BEGIN
clrscr;
st:=' Ў®а®§¤*, Ў®а®**, ¦Ёа*д, ЎҐбᮤҐа¦**ЁҐ, ¦*а*';
writeln('‚ўҐ¤ЁвҐ бва®Єг, а*§¤Ґ«пп б«®ў* §*Їпвл¬Ё');
readln(st);
writeln;
d:=LENGTH(st);
while (d>0) and (st[d]=' ') do
d:=d-1;
if d=0 then
write('ЂЌЋЊЂ‹€џ: бва®Є* Їгбв*п')
else
begin
chet:=true;
mnechet:=[];
mchet:=[];
n:=1;
while n<=d do
begin
while st[n]=' ' do
n:=n+1;
k:=POS(',',COPY(st,n,d-n+1));
if k=0 then
k:=d
else
k:=k+n-1-1;

{

k:=n;
while (k<=d) and (st[k]<>',') do
k:=k+1;
k:=k-1;
}
chet:=not chet;
sl:=[];
for i:=n to k do
sl:=sl+[ st ];
if chet then
mchet:=mchet+(zs-sl)
else
mnechet:=mnechet+(zs*sl);
n:=k+2;
end;
vm:=mchet*mnechet;
writeln('‡‚ЋЌЉ€… ‘Ћѓ‹Ђ‘Ќ›…, ЉЋ’Ћђ›… ‚•Ћ„џ’ •Ћ’џ Ѓ› ‚ Ћ„ЌЋ Ќ…—…’ЌЋ… ‘‹Ћ‚Ћ');
writeln('€ Ќ… ‚•Ћ„џ’ •Ћ’џ Ѓ› ‚ Ћ„ЌЋ —…’ЌЋ…:');
if vm=[] then
write('таких букв нет')
else
for c:='Ў' to 'а' do
if c IN vm then
write(c,' ');
end;

readln;
END.

 

[Vladimir_S]

Вводится непустая строка из строчных русских букв.Отдельные слова в ней разделены запятыми.Вывести на печать в алфавитном порядке звонкие согласные которые входят хотя бы в одно нечетное слово и не входят хотя бы в одно четное

И что? Вроде как работает нормально.

 

[Robocopp]

Нужна помощь.

Здравствуйте!
Я следил за вашим диалогом с pashasnuff. Так как у меня похожая задача. Мне помогли сделать ее. Но она сделана с помощью массива, а задание состоит сделать ее с помощью множеств. Не могли мне помочь выполнить это задание с помощью множеств. Я понимаю, что с помощью массивов сделать ее намного легче. Но преподаватель требует что бы сделали ее с помощью множеств.

Задание:
Вводится непустая строка из строчных букв(не более 79 символов). Отдельные слова в ней разделены запятыми(слева и справа от запятой могут быть пробелы). Вывести на печать в алфавитном порядке. Гласные, которые не входят более, чем в одно слово.

Вот код:
program stroki;
{uses crt;{Подключение модуля работы с экраном. Есть о обычном Паскале}
label 3;

procedure vvod(var sp:string; var lp:integer);
begin
writeln('Введите строку слов, разделенных запятыми:');
readln(sp);
sp:=sp+'.';
lp:=length(sp);
writeln;
end;

procedure tek_slovo(sp:string;lp:integer;var ip:integer;var s1p:string;var l1p:integer);
begin
s1p:='';
while (sp[ip]<>',')and (sp[ip]<>'.')and (sp[ip]<>' ')do
begin
s1p:=s1p+sp[ip];
l1p:=length(s1p);
inc(ip);
end;
end;

var s,s1,s2,s3:string;
l,l1,i,j,k,b:integer;
a: array[1..20] of string [20];
begin
3: {clrscr;{очистка экрана. Есть в обычном Паскале}
writeln('Меню:');
writeln('Слова в алфавитном порядке - 1');
writeln('Уникальные символы строки - 2');
writeln('Выход из программы - 0');
writeln('Выберите номер пункта меню:');
readln(k);

case k of
1:begin
vvod(s,l);
i:=0;
b:=0;
writeln('Cлова в алфавитном порядке');
while i<=l-1 do
begin
inc(i);
{Выделение текущего слова}
if (s<>' ')then
begin
{в s1 - текущее слово}
tek_slovo(s,l,i,s1,l1);
inc(b); {b:=b+1}
a:=s1;
end;
end;
{сортировка массива слов (массив А)методом "пузырька"}
for i:=1 to b-1 do
for j:=i+1 to b do
if a>a[j] then
begin
s2:=a; a:=a[j]; a[j]:=s2;
end;
s3:='';
{слова в алфавитном порядке}
for j:=1 to b do
s3:=s3+a[j]+', ';
writeln (s3);
goto 3;
end;
2:begin
vvod(s,l);
i:=0;
s3:='';
writeln('Гласные, которые не входят более, чем в одно слово');
while i<=l-1 do
begin
inc(i);
{Выделение текущего слова}
if (s<>' ')then
begin
tek_slovo(s,l,i,s1,l1);
s2:=s; {Вспомогательная строка}
{Удаление текущего выделенного слова из вспомогательной строки}
delete(s2,i-l1,l1);
{Если очередная буква выделенного текущего слова ни разу не входит во
вспомогательную строку без него и не входит в результирующую строку,
содержащую уникальные символы, то она заносится в результирующую строку s3}
for j:=1 to l1 do
if (pos(s1[j],s2)=0) and (pos(s1[j],s3)=0)then s3:=s3+' ' +s1[j];

end;
end;
{Уникальные символы}
writeln (s3);
goto 3;
end; {1}
0:exit;
end;{case}
end.

 

[Vladimir_S]

Я следил за вашим диалогом с pashasnuff. Так как у меня похожая задача. Мне помогли сделать ее. Но она сделана с помощью массива, а задание состоит сделать ее с помощью множеств. Не могли мне помочь выполнить это задание с помощью множеств?

А надо было не "следить", а вникать! Потому что там решение дано именно через множества, а поскольку, как Вы сами утверждаете, задачи "похожи", то и флаг Вам в руки! Или опять "напишите мне "от и до", а я тупо скатаю"?

 

[Vladimir_S]

А вообще - ладно, :dobriy:. Да и задачка уж больно забавная. Держите:

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.