IPB
ЛогинПароль:

> Прочтите прежде чем задавать вопрос!

1. Заголовок темы должен быть информативным. В противном случае тема удаляется ...
2. Все тексты программ должны помещаться в теги [code=pas] ... [/code], либо быть опубликованы на нашем PasteBin в режиме вечного хранения.
3. Прежде чем задавать вопрос, см. "FAQ", если там не нашли ответа, воспользуйтесь ПОИСКОМ, возможно такую задачу уже решали!
4. Не предлагайте свои решения на других языках, кроме Паскаля (исключение - только с согласия модератора).
5. НЕ используйте форум для личного общения, все что не относится к обсуждению темы - на PM!
6. Одна тема - один вопрос (задача)
7. Проверяйте программы перед тем, как разместить их на форуме!!!
8. Спрашивайте и отвечайте четко и по существу!!!

 
 Ответить  Открыть новую тему 
> Поиск рифмы, строки строки и еще раз строки
сообщение
Сообщение #1


Пионер
**

Группа: Пользователи
Сообщений: 51
Пол: Мужской
Реальное имя: Серж

Репутация: -  0  +


Из заданного словаря выбрать все слова, имеющие рифмы (рифма определяется по принципу, придуманному Незнайкой: два слова рифмуются, если последние слоги у них совпадают, например, “палка – селедка”).
Вот так я сделал. ток мне ее зарубили. сказали чтоб она слоги проверяла, по правилам великого и могучего.
Код

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.
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #2


Уникум
*******

Группа: Пользователи
Сообщений: 6 823
Пол: Мужской
Реальное имя: Лопáрь (Андрей)

Репутация: -  159  +


Цитата($rvr4vr @ 10.12.2006 21:21) *

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

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


--------------------
я - ветер, я северный холодный ветер
я час расставанья, я год возвращенья домой
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #3


Гость






Меня зарубили на том что она посчитала слва 'нет' и 'ответ' рифмой. хотя 'нет' это один слог. мне кажется слог должен начинаться с согласной буквы.
 К началу страницы 
+ Ответить 
сообщение
Сообщение #4


Пионер
**

Группа: Пользователи
Сообщений: 51
Пол: Мужской
Реальное имя: Серж

Репутация: -  0  +


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

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

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.

но она работала только с одной парой слов
например ответ-нет она отсеила, а совет-нет уже не захотела. я уже забодался может кто видит ошибку незашореным взглядом?
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #5


Уникум
*******

Группа: Пользователи
Сообщений: 6 823
Пол: Мужской
Реальное имя: Лопáрь (Андрей)

Репутация: -  159  +


Цитата($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 два раза при вводе..


--------------------
я - ветер, я северный холодный ветер
я час расставанья, я год возвращенья домой
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #6


Пионер
**

Группа: Пользователи
Сообщений: 51
Пол: Мужской
Реальное имя: Серж

Репутация: -  0  +


Ну я имел в виду последнии совподающии в цикле т.е. самые левые буквы. Действительно. Надо подмутить чтоб более трех не трогала. хм. что касается двойного нажатия Enter, есть предложения да такие что бы сильно менять прогу не пришлось?
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #7


Гость






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


Пионер
**

Группа: Пользователи
Сообщений: 51
Пол: Мужской
Реальное имя: Серж

Репутация: -  0  +


ВО! изящно и просто. респект. на счет исключения более трех символов в проверке на согласность.
то я так сделал:

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;


вроде работает, но чувствую что как миниум не оптимально.
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #9


Уникум
*******

Группа: Пользователи
Сообщений: 6 823
Пол: Мужской
Реальное имя: Лопáрь (Андрей)

Репутация: -  159  +


Цитата($rvr4vr @ 12.12.2006 14:53) *

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

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

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

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


--------------------
я - ветер, я северный холодный ветер
я час расставанья, я год возвращенья домой
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #10


Пионер
**

Группа: Пользователи
Сообщений: 51
Пол: Мужской
Реальное имя: Серж

Репутация: -  0  +


На счет шутки о Незнайке....это не прикол это натурально такое задание! 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
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #11


Пионер
**

Группа: Пользователи
Сообщений: 51
Пол: Мужской
Реальное имя: Серж

Репутация: -  0  +


а то у нас препод хоть и приколист (одна эта задача чего стоит))), но до кода докапывается будь здоров!
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #12


Гость






Вот это условие:
if (s>=2)and(s<3) then

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

If s = 2 then ...
не проще будет?
 К началу страницы 
+ Ответить 
сообщение
Сообщение #13


Пионер
**

Группа: Пользователи
Сообщений: 51
Пол: Мужской
Реальное имя: Серж

Репутация: -  0  +


Точно! volvo ты как всегда профи! ну раз больше ни чего не сделать то считаю тему исчерпаной. всем огромное спасибо! give_rose.gif
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #14


Гость






Цитата
ну раз больше ни чего не сделать
Заметь, я этого не говорил... Это - твое мнение... Сделать как раз можно, только я пока подожду, может кто другой напишет smile.gif Я ж не один на форуме...
 К началу страницы 
+ Ответить 
сообщение
Сообщение #15


Пионер
**

Группа: Пользователи
Сообщений: 51
Пол: Мужской
Реальное имя: Серж

Репутация: -  0  +


Нашел один партак! вот теперь слова в которых меньше 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;

 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #16


Пионер
**

Группа: Пользователи
Сообщений: 51
Пол: Мужской
Реальное имя: Серж

Репутация: -  0  +


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

volvo! по ходу ни кто ни чего не напишет, а я не вижу возможности что либо еще сделать. чувствую что можно, но как и что.... в общем не томи...
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #17


Гость






Ты там, насколько я понимаю, еще что-то исправлял? Выложи свою окончательную версию полностью на форум, я покажу, что с ней можно сделать, чтобы не получилось, что у тебя уже как-то по-другому, и мое исправление не будет работать... smile.gif
 К началу страницы 
+ Ответить 
сообщение
Сообщение #18


Пионер
**

Группа: Пользователи
Сообщений: 51
Пол: Мужской
Реальное имя: Серж

Репутация: -  0  +


Вот:
 
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.


 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #19


Гость






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

?
 К началу страницы 
+ Ответить 
сообщение
Сообщение #20


Пионер
**

Группа: Пользователи
Сообщений: 51
Пол: Мужской
Реальное имя: Серж

Репутация: -  0  +


Работает вроде. и выглядит красивее. ну все тогда. ща еще ее погоняю. но вроде все ОК. спасибо give_rose.gif
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 

 Ответить  Открыть новую тему 
1 чел. читают эту тему (гостей: 1, скрытых пользователей: 0)
Пользователей: 0

 





- Текстовая версия 22.09.2020 15:56
500Gb HDD, 6Gb RAM, 2 Cores, 7 EUR в месяц — такие хостинги правда бывают
Связь с администрацией: bu_gen в домене octagram.name