Определить корень слова (для поиска похожих слов)

Delphi , Синтаксис , Текст и Строки

// Поиск по корню слова
function RootOfWord(s: string): string;
label
  start;
const
  sGlas = 'аеёиоуыэюяaeiou'; // With english letters
  sSoglas = 'бвгджзйклмнпрстфхцчшщъь';
  sCompletions1 = 'й ь s';
  sCompletions2 = 'ам ям ом ем ин ём ся ет ит ут ют ат ят ыв ив ев ан ян ов ев ог ег ир ер ых ок ющ ущ er ed';
  sCompletions3 = 'енн овл евл ённ анн ост ест';
  sAttachments1 = 'в с';
  sAttachments2 = 'на за ис из до по вы во со';
  sAttachments3 = 'при рас пре про под';
  sAttachments4 = 'пере';
var
  sResult: string;
  i, iCnt, iGlasCount, iCheckCount: integer;
begin
  sResult := AnsiLowerCase(Trim(s));
  iCheckCount := 0;

  start:
  // "ся"
  if Length(sResult) > 3 then
    if sResult[Length(sResult) - 1] + sResult[Length(sResult)] = 'ся' then
      Delete(sResult, Length(sResult) - 1, 2);

  (*  E N G L I S H  *)

  // "ing"
  if Length(sResult) > 4 then
    if sResult[Length(sResult) - 2] + sResult[Length(sResult) - 1] + sResult[Length(sResult)] = 'ing' then
      Delete(sResult, Length(sResult) - 2, 3);

  // --

  // Гласные
  if Length(sResult) > 3 then
  begin
    iGlasCount := 0;
    for i := Length(sResult) downto 1 do
      if Pos(sResult[i], sGlas) <> 0 then // Если последний символ - гласная
        inc(iGlasCount)
      else
        break;
    if iGlasCount <> 0 then
    begin
      iGlasCount := iGlasCount - 1;
      Delete(sResult, Length(sResult) - iGlasCount, iGlasCount + 1);
    end;
  end;

  // Окончания
  if Length(sResult) > 3 then
    if Pos(sResult[Length(sResult)], sCompletions1) <> 0 then
      Delete(sResult, Length(sResult), 1);

  // "ся"
  if Length(sResult) > 3 then
    if sResult[Length(sResult) - 1] + sResult[Length(sResult)] = 'ся' then
      Delete(sResult, Length(sResult) - 1, 2);

  if Length(sResult) > 3 then
    while Pos(sResult[Length(sResult) - 2] + sResult[Length(sResult) - 1] +
      sResult[Length(sResult)], sCompletions3) <> 0 do
    begin
      if Length(sResult) > 3 then
        Delete(sResult, Length(sResult) - 1, 3)
      else
        break;
    end;

  if Length(sResult) > 3 then
    while Pos(sResult[Length(sResult) - 1] + sResult[Length(sResult)], sCompletions2) <> 0 do
    begin
      if Length(sResult) > 3 then
        Delete(sResult, Length(sResult) - 1, 2)
      else
        break;
    end;

  // Гласные
  if Length(sResult) > 3 then
  begin
    iGlasCount := 0;
    for i := Length(sResult) downto 1 do
      if Pos(sResult[i], sGlas) <> 0 then // Если последний символ - гласная
        inc(iGlasCount)
      else
        break;
    if iGlasCount <> 0 then
    begin
      iGlasCount := iGlasCount - 1;
      Delete(sResult, Length(sResult) - iGlasCount, iGlasCount + 1);
    end;
  end;

  // Приставки
  iCnt := 4;
  if Length(sResult) > iCnt then
    if Pos(Copy(sResult, 1, iCnt), sAttachments4) <> 0 then
      Delete(sResult, 1, iCnt);

  iCnt := 3;
  if Length(sResult) > iCnt then
    if Pos(Copy(sResult, 1, iCnt), sAttachments3) <> 0 then
      Delete(sResult, 1, iCnt);

  iCnt := 2;
  if Length(sResult) > iCnt then
    if Pos(Copy(sResult, 1, iCnt), sAttachments2) <> 0 then
      Delete(sResult, 1, iCnt);

  iCnt := 1;
  if Length(sResult) > iCnt then
    if Pos(Copy(sResult, 1, iCnt), sAttachments1) <> 0 then
      Delete(sResult, 1, iCnt);

  inc(iCheckCount);
  if iCheckCount < 2 then
    goto start;

  Result := sResult;
end;

Перевод контента на русский язык:

Приведен код функции Delphi под именем RootOfWord, которая предназначена для извлечения корня слова, что может быть полезно при поиске схожих слов. Функция принимает строковый ввод и применяет различные проверки и манипуляции для удаления префиксов, суффиксов и определенных комбинаций букв, чтобы получить корень.

Разбивка кода:

1. Первая секция определяет константы для согласных (sGlas), сочетаний гласного и согласного (sSoglas) и списки общих суффиксов и префиксов (sCompletions1, sCompletions2, sAttachments1, и т.д.).

2. Функция начинается с конвертации входной строки в нижний регистр и удаления любых leading или trailing пробелов.

3. Затем функция проверяет конкретные суффиксы и префиксы и удаляет их, если они найдены. Включают:

4. Удаление "ся" из конца слова.
5. Удаление английских суффиксов, таких как "ing".

6. Удаление общих русских суффиксов, таких как "-ам", "-ом", "-ем", и т.д.

7. Функция затем проверяет сочетания гласного и согласного и удаляет их, если они найдены, что помогает уменьшить слово до его корня.

8. Затем функция применяет дополнительные проверки для удаления более суффиксов и префиксов:

9. Проверка общих русских суффиксов, таких как "-енн", "-овл", и т.д.

10. Удаление любых оставшихся сочетаний гласного и согласного.

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

12. Финальный результат возвращается как корень слова.

Некоторые предложения по улучшению:

• Рассмотрите добавление комментариев для объяснения каждого раздела кода.
• Используйте более описательные имена переменных, чтобы сделать код более понятным.
• Вам может потребоваться добавить обработку ошибок в случае пустой или null входной строки.
• Вместо использования оператора goto, рассмотрите разбиение функции на более маленькие подфункции для лучшей читаемости и поддержки.

Вот упрощенная версия кода:

function RootOfWord(s: string): string;
begin
  s := AnsiLowerCase(Trim(s));

  while Pos('ся', s) > 0 do
    Delete(s, Length(s) - 1, 2);

  while Pos('ing', s) > 0 do
    Delete(s, Length(s) - 2, 3);

  // Другие проверки...

  Result := s;
end;

Эта версия удаляет оператор goto и объединяет некоторые проверки в одиночный цикл. Однако она все еще выполняет необходимые проверки для извлечения корня слова.

Определение корня слова для поиска похожих слов: функция RootOfWord в Delphi.

Комментарии и вопросы

Получайте свежие новости и обновления по Object Pascal, Delphi и Lazarus прямо в свой смартфон. Подпишитесь на наш Telegram-канал delphi_kansoftware и будьте в курсе последних тенденций в разработке под Linux, Windows, Android и iOS

:: Главная :: Текст и Строки ::