Помощь - Поиск - Пользователи - Календарь
Полная версия: Поиск рифмы
Форум «Всё о Паскале» > Pascal, Object Pascal > Задачи
$rvr4vr
Из заданного словаря выбрать все слова, имеющие рифмы (рифма определяется по принципу, придуманному Незнайкой: два слова рифмуются, если последние слоги у них совпадают, например, “палка – селедка”).
Вот так я сделал. ток мне ее зарубили. сказали чтоб она слоги проверяла, по правилам великого и могучего.
Код

Program Rifma;
uses crt;
Var
y,i,j,k,u,n,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
   begin
    For u:=i+1 to j do
      begin
       k:=length(m[i]);
       n:=length(m[u]);
       s:=0;
       while m[i][k]=m[u][n] do
         begin
          k:=k-1;
          s:=s+1;
          n:=n-1;
         end;
       If s>=2
        then begin
             writeln(m[i],' - ',m[u]);
             y:=y+1;
             end;
      end;
   end;
If y=0
  then writeln('Слова не рифмуются');
readln;
END.
Lapp
Цитата($rvr4vr @ 10.12.2006 21:21) *

сказали чтоб она слоги проверяла, по правилам великого и могучего.

А алгоритмируемый способ нахождения слогов в великом и могучем известен? Лично мне нет.. Я всегда определял это на слух, и как заставить программу делать это - я не знаю. То есть понятно, что в слоге должна быть одна гласная, но этого же мало!
Слово "портрет" надо делить так: "порт-рет". Но как объяснить программе, что не "пор-трет"? Я не такой большой знаток русского, чтоб придумать общее правило.. sad.gif
Дашь правило - будет прога! smile.gif
Гость
Меня зарубили на том что она посчитала слва 'нет' и 'ответ' рифмой. хотя 'нет' это один слог. мне кажется слог должен начинаться с согласной буквы.
$rvr4vr
Так что надо как то модифицировать программку чтоб проверяла последнии одинаковые символы на согласность

я делал так.
Код

Program Rifma;
uses crt;
Var
y,i,j,k,u,n,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
   begin
    For u:=i+1 to j do
      begin
       k:=length(m[i]);
       n:=length(m[u]);
       s:=0;
       while m[i][k]=m[u][n] do
         begin
          k:=k-1;
          s:=s+1;
          n:=n-1;
         end;
       if m[i][k] in [<тут множество согласных>] then
        If s>=2
         then begin
                  writeln(m[i],' - ',m[u]);
                  y:=y+1;
               end;
      end;
   end;
If y=0
  then writeln('Слова не рифмуются');
readln;
END.

но она работала только с одной парой слов
например ответ-нет она отсеила, а совет-нет уже не захотела. я уже забодался может кто видит ошибку незашореным взглядом?
Lapp
Цитата($rvr4vr @ 11.12.2006 23:29) *

чтоб проверяла последнии одинаковые символы на согласность

Ты на самом деле проверяешь на согласность не последний одинаковый, а следующий за ним (слева). Ведь ты увеличиваешь k, если k-тые и n-ный символы равны.
Вот исправленный вариант. Помимо прочего, я убрал использование лишних переменных k и n, которые вносили путаницу. Если тебя пугает длина строк проверок, то лучше сохрани строки в временных переменных (типа a:=m[i]; b:=m[u] ), чтоб не тянуть за собой индексы
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.

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

PS
раздражает необходимость нажимать Enter два раза при вводе..
$rvr4vr
Ну я имел в виду последнии совподающии в цикле т.е. самые левые буквы. Действительно. Надо подмутить чтоб более трех не трогала. хм. что касается двойного нажатия Enter, есть предложения да такие что бы сильно менять прогу не пришлось?
volvo
Цитата
что касается двойного нажатия Enter, есть предложения да такие что бы сильно менять прогу не пришлось?
Есть предложение вводить слова до пустой строки:
...
j := 0;
repeat
inc(j);
write(j,'-ое слово ');
readln(m[j]);
until m[j] = '';
dec(j); { <--- J-ый элемент массива - пустая строка, исключаем из рассмотрения }
...
$rvr4vr
ВО! изящно и просто. респект. на счет исключения более трех символов в проверке на согласность.
то я так сделал:

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;


вроде работает, но чувствую что как миниум не оптимально.
Lapp
Цитата($rvr4vr @ 12.12.2006 14:53) *

вроде работает, но чувствую что как миниум не оптимально.

Ну ты даешь.. Это типа шестое чувство? я имею в виду оптимальность.. smile.gif)))
Если серьезно, то я никак не пойму уровень серьезности, который ты тут предполагаешь.. Начал ты с шутки про Незнайку, а потом потянул одеяло на алгоритм определения слогов (!), и о каком "оптимуме" тут может идти речь - известно только Всевышнему..

Конечно, это не рифма! ты не учитываешь, например, что слово может заканчиваться гласную и две согласных: мост-хвост-рост-прост..
Или даже на гласную и три согласных:

"В осцилограмме Александр
узнал любимый им меандр"
smile.gif
И, наконец, ты совершенно не учитываешь ударение! Какая же тут, извините, рифма?.. blink.gif
$rvr4vr
На счет шутки о Незнайке....это не прикол это натурально такое задание! lol.gif и при чем тут ударение?! нам дан принцип этого рекомого Незнайки что слова считаются рифмой когда у нас последнии слоги совподают. остальное нас не волнует! yes2.gif а насчет неоптимальности, просто как то коряво смотрится это повторение два раза одного и тогоже куска,

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;


вот я и спрашиваю может как то изящнее сделать можно? blink.gif
$rvr4vr
а то у нас препод хоть и приколист (одна эта задача чего стоит))), но до кода докапывается будь здоров!
volvo
Вот это условие:
if (s>=2)and(s<3) then

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

If s = 2 then ...
не проще будет?
$rvr4vr
Точно! volvo ты как всегда профи! ну раз больше ни чего не сделать то считаю тему исчерпаной. всем огромное спасибо! give_rose.gif
volvo
Цитата
ну раз больше ни чего не сделать
Заметь, я этого не говорил... Это - твое мнение... Сделать как раз можно, только я пока подожду, может кто другой напишет smile.gif Я ж не один на форуме...
$rvr4vr
Нашел один партак! вот теперь слова в которых меньше 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;

$rvr4vr
Цитата
Сделать как раз можно, только я пока подожду, может кто другой напишет

volvo! по ходу ни кто ни чего не напишет, а я не вижу возможности что либо еще сделать. чувствую что можно, но как и что.... в общем не томи...
volvo
Ты там, насколько я понимаю, еще что-то исправлял? Выложи свою окончательную версию полностью на форум, я покажу, что с ней можно сделать, чтобы не получилось, что у тебя уже как-то по-другому, и мое исправление не будет работать... smile.gif
$rvr4vr
Вот:
 
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.


volvo
Вот так не аналогично:
  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;

?
$rvr4vr
Работает вроде. и выглядит красивее. ну все тогда. ща еще ее погоняю. но вроде все ОК. спасибо give_rose.gif
Это текстовая версия — только основной контент. Для просмотра полной версии этой страницы, пожалуйста, нажмите сюда.