Из заданного словаря выбрать все слова, имеющие рифмы (рифма определяется по принципу, придуманному Незнайкой: два слова рифмуются, если последние слоги у них совпадают, например, “палка – селедка”).
Вот так я сделал. ток мне ее зарубили. сказали чтоб она слоги проверяла, по правилам великого и могучего.
Меня зарубили на том что она посчитала слва 'нет' и 'ответ' рифмой. хотя 'нет' это один слог. мне кажется слог должен начинаться с согласной буквы.
Так что надо как то модифицировать программку чтоб проверяла последнии одинаковые символы на согласность
я делал так.
uses crt;
const
ConsDOS:set of char=['Б','б','В','в','Г','г','Д','д',
'Ж','ж','З','з','К','к','Л','л','М','м','Н','н','П','п',
'Р','р','С','с','Т','т','Ф','ф','Х','х','Ц','ц','Ч','ч'];
Var
y,i,j,u,s:Byte;
ch:char;
m: array [1..50] of string;
Begin
clrscr;
writeln('Вывод на экран рифмующихся слов');
writeln('Для продолжения ввода слов нажмите Enter');
writeln('Для окончания ввода слов нажмите Esc');
j:=0;
y:=0;
repeat
j:=j+1;
write(j,'-ое слово ');
readln(m[j]);
ch:=readkey;
until ch=#27;
For i:=1 to j-1 do
For u:=i+1 to j do begin
s:=0;
while (s<Length(m[i]))and(s<Length(m[i]))and(m[i,Length(m[i])-s]=m[u,Length(m[u])-s]) do
s:=s+1;
if (s>=2)and(m[i,Length(m[i])-s+1] in ConsDOS) then begin
writeln(m[i],' - ',m[u]);
y:=y+1;
end;
end;
If y=0 then writeln('Слова не рифмуются');
readln;
END.
Ну я имел в виду последнии совподающии в цикле т.е. самые левые буквы. Действительно. Надо подмутить чтоб более трех не трогала. хм. что касается двойного нажатия Enter, есть предложения да такие что бы сильно менять прогу не пришлось?
...
j := 0;
repeat
inc(j);
write(j,'-ое слово ');
readln(m[j]);
until m[j] = '';
dec(j); { <--- J-ый элемент массива - пустая строка, исключаем из рассмотрения }
...
ВО! изящно и просто. респект. на счет исключения более трех символов в проверке на согласность.
то я так сделал:
For u:=i+1 to j do begin
s:=0;
while (s<Length(m[i]))and(s<Length(m[i]))and(m[i,Length(m[i])-s]=m[u,Length(m[u])-s]) do
s:=s+1;
if (s>=2)and(s<3) then
begin
if (m[i,Length(m[i])-s+1] in ConsDOS) then
begin
writeln(m[i],' - ',m[u]);
y:=y+1;
end
end
else begin
writeln(m[i],' - ',m[u]);
y:=y+1;
end;
end;
На счет шутки о Незнайке....это не прикол это натурально такое задание! и при чем тут ударение?! нам дан принцип этого рекомого Незнайки что слова считаются рифмой когда у нас последнии слоги совподают. остальное нас не волнует! а насчет неоптимальности, просто как то коряво смотрится это повторение два раза одного и тогоже куска,
if (m[i,Length(m[i])-s+1] in ConsDOS) then
begin
writeln(m[i],' - ',m[u]);
y:=y+1;
end
end
else begin
writeln(m[i],' - ',m[u]);
y:=y+1;
end;
а то у нас препод хоть и приколист (одна эта задача чего стоит))), но до кода докапывается будь здоров!
Вот это условие:
if (s>=2)and(s<3) then
If s = 2 then ...не проще будет?
Точно! volvo ты как всегда профи! ну раз больше ни чего не сделать то считаю тему исчерпаной. всем огромное спасибо!
Нашел один партак! вот теперь слова в которых меньше 2х совподающих символов не будут считаться рифмой
,,,
if (m[i,Length(m[i])-s+1] in ConsDOS) then
begin
writeln(m[i],' - ',m[u]);
y:=y+1;
end
end
else begin
if s>2 then {вот тут модифицировал}
begin
writeln(m[i],' - ',m[u]);
y:=y+1;
end;
end;
Ты там, насколько я понимаю, еще что-то исправлял? Выложи свою окончательную версию полностью на форум, я покажу, что с ней можно сделать, чтобы не получилось, что у тебя уже как-то по-другому, и мое исправление не будет работать...
Вот:
uses crt;
const
ConsDOS:set of char=['Б','б','В','в','Г','г','Д','д',
'Ж','ж','З','з','К','к','Л','л','М','м','Н','н','П','п',
'Р','р','С','с','Т','т','Ф','ф','Х','х','Ц','ц','Ч','ч'];
Var
y,i,j,u,s:Byte;
ch:char;
m: array [1..50] of string;
Begin
clrscr;
write('Вывод на экран рифмующихся слов');
gotoXY(15,25);
write('Для окончания ввода слов введите пустую строку');
j:=0;
y:=0;
gotoXY(1,2);
repeat
inc(j);
write(j,'-ое слово ');
readln(m[j]);
until m[j] = '';
dec(j);
For i:=1 to j-1 do
For u:=i+1 to j do begin
s:=0;
while (s<Length(m[i]))and(s<Length(m[i]))and(m[i,Length(m[i])-s]=m[u,Length(m[u])-s]) do
s:=s+1;
if s=2 then
begin
if (m[i,Length(m[i])-s+1] in ConsDOS) then
begin
writeln(m[i],' - ',m[u]);
y:=y+1;
end
end
else
if s>2 then
begin
writeln(m[i],' - ',m[u]);
y:=y+1;
end;
end;
If y=0 then writeln('Слова не рифмуются');
readln;
END.
Вот так не аналогично:
For i:=1 to j-1 do?
For u:=i+1 to j do begin
s:=0;
while (s<Length(m[i]))and(s<Length(m[i]))and(m[i,Length(m[i])-s]=m[u,Length(m[u])-s]) do s:=s+1;
if ((s = 2) and (m[i,Length(m[i])-s+1] in ConsDOS)) or (s > 2) then begin
writeln(m[i],' - ',m[u]);
y:=y+1;
end;
end;
Работает вроде. и выглядит красивее. ну все тогда. ща еще ее погоняю. но вроде все ОК. спасибо