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

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
11.12.2006 8:56
Цитата($rvr4vr @ 10.12.2006 21:21) *

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

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

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

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

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
12.12.2006 18:28
Цитата($rvr4vr @ 12.12.2006 14:53) *

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

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

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

"В осцилограмме Александр
узнал любимый им меандр"
smile.gif
И, наконец, ты совершенно не учитываешь ударение! Какая же тут, извините, рифма?.. blink.gif
$rvr4vr
12.12.2006 18:35
На счет шутки о Незнайке....это не прикол это натурально такое задание! 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
12.12.2006 19:01
а то у нас препод хоть и приколист (одна эта задача чего стоит))), но до кода докапывается будь здоров!
volvo
12.12.2006 19:04
Вот это условие:
if (s>=2)and(s<3) then

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

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

volvo! по ходу ни кто ни чего не напишет, а я не вижу возможности что либо еще сделать. чувствую что можно, но как и что.... в общем не томи...
volvo
13.12.2006 21:51
Ты там, насколько я понимаю, еще что-то исправлял? Выложи свою окончательную версию полностью на форум, я покажу, что с ней можно сделать, чтобы не получилось, что у тебя уже как-то по-другому, и мое исправление не будет работать... smile.gif
$rvr4vr
13.12.2006 22:12
Вот:
 
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
13.12.2006 22:26
Вот так не аналогично:
  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
13.12.2006 22:37
Работает вроде. и выглядит красивее. ну все тогда. ща еще ее погоняю. но вроде все ОК. спасибо give_rose.gif
Это текстовая версия — только основной контент. Для просмотра полной версии этой страницы, пожалуйста, нажмите сюда.