Поиск рифмы, строки строки и еще раз строки Опции

[$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]

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

я делал так.

Код

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]

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

Ты на самом деле проверяешь на согласность не последний одинаковый, а следующий за ним (слева). Ведь ты увеличиваешь 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]

На счет шутки о Незнайке....это не прикол это натурально такое задание! и при чем тут ударение?! нам дан принцип этого рекомого Незнайки что слова считаются рифмой когда у нас последнии слоги совподают. остальное нас не волнует! а насчет неоптимальности, просто как то коряво смотрится это повторение два раза одного и тогоже куска,

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;

вот я и спрашиваю может как то изящнее сделать можно?

[$rvr4vr]

а то у нас препод хоть и приколист (одна эта задача чего стоит))), но до кода докапывается будь здоров!

[volvo]

Вот это условие:

if (s>=2)and(s<3) then

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

If s = 2 then ...

не проще будет?

[$rvr4vr]

Точно! volvo ты как всегда профи! ну раз больше ни чего не сделать то считаю тему исчерпаной. всем огромное спасибо!

[volvo]

ну раз больше ни чего не сделать

Заметь, я этого не говорил... Это - твое мнение... Сделать как раз можно, только я пока подожду, может кто другой напишет Я ж не один на форуме...

[$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]

Ты там, насколько я понимаю, еще что-то исправлял? Выложи свою окончательную версию полностью на форум, я покажу, что с ней можно сделать, чтобы не получилось, что у тебя уже как-то по-другому, и мое исправление не будет работать...

[$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]

Работает вроде. и выглядит красивее. ну все тогда. ща еще ее погоняю. но вроде все ОК. спасибо