VPF::Нахождение корня слова - Форум программистов

ДЫМ

Дата 3.9.2006, 21:35 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 224
Регистрация: 6.1.2004

Репутация: 8
Всего: 8

Мне нужна функция нахождения корня русского слова (для поиска похожих слов). Я поискал в сети информацию по этой теме, нашел пример в Delphi World, который мне не очень нравится и вот этот код на PHP.

Код


<?php
class Lingua_Stem_Ru 
{
    var $VERSION = "0.02";
    var $Stem_Caching = 0;
    var $Stem_Cache = array();
    var $VOWEL = '/аеиоуыэюя/';
    var $PERFECTIVEGROUND = '/((ив|ивши|ившись|ыв|ывши|ывшись)|((?<=[ая])(в|вши|вшись)))$/';
    var $REFLEXIVE = '/(с[яь])$/';
    var $ADJECTIVE = '/(ее|ие|ые|ое|ими|ыми|ей|ий|ый|ой|ем|им|ым|ом|его|ого|ему|ому|их|ых|ую|юю|ая|яя|ою|ею)$/';
    var $PARTICIPLE = '/((ивш|ывш|ующ)|((?<=[ая])(ем|нн|вш|ющ|щ)))$/';
    var $VERB = '/((ила|ыла|ена|ейте|уйте|ите|или|ыли|ей|уй|ил|ыл|им|ым|ен|ило|ыло|ено|ят|ует|уют|ит|ыт|ены|ить|ыть|ишь|ую|ю)|((?<=[ая])(ла|на|ете|йте|ли|й|л|ем|н|ло|но|ет|ют|ны|ть|ешь|нно)))$/';
    var $NOUN = '/(а|ев|ов|ие|ье|е|иями|ями|ами|еи|ии|и|ией|ей|ой|ий|й|иям|ям|ием|ем|ам|ом|о|у|ах|иях|ях|ы|ь|ию|ью|ю|ия|ья|я)$/';
    var $RVRE = '/^(.*?[аеиоуыэюя])(.*)$/';
    var $DERIVATIONAL = '/[^аеиоуыэюя][аеиоуыэюя]+[^аеиоуыэюя]+[аеиоуыэюя].*(?<=о)сть?$/';

    function s(&$s, $re, $to)
    {
        $orig = $s;
        $s = preg_replace($re, $to, $s);
        return $orig !== $s;
    }

    function m($s, $re)
    {
        return preg_match($re, $s);
    }

    function stem_word($word) 
    {
        $word = strtolower($word);
        $word = strtr($word, 'ё', 'е');
        # Check against cache of stemmed words
        if ($this->Stem_Caching && isset($this->Stem_Cache[$word])) {
            return $this->Stem_Cache[$word];
        }
        $stem = $word;
        do {
          if (!preg_match($this->RVRE, $word, $p)) break;
          $start = $p[1];
          $RV = $p[2];
          if (!$RV) break;

          # Step 1
          if (!$this->s($RV, $this->PERFECTIVEGROUND, '')) {
              $this->s($RV, $this->REFLEXIVE, '');

              if ($this->s($RV, $this->ADJECTIVE, '')) {
                  $this->s($RV, $this->PARTICIPLE, '');
              } else {
                  if (!$this->s($RV, $this->VERB, ''))
                      $this->s($RV, $this->NOUN, '');
              }
          }

          # Step 2
          $this->s($RV, '/и$/', '');

          # Step 3
          if ($this->m($RV, $this->DERIVATIONAL))
              $this->s($RV, '/ость?$/', '');

          # Step 4
          if (!$this->s($RV, '/ь$/', '')) {
              $this->s($RV, '/ейше?/', '');
              $this->s($RV, '/нн$/', 'н'); 
          }

          $stem = $start.$RV;
        } while(false);
        if ($this->Stem_Caching) $this->Stem_Cache[$word] = $stem;
        return $stem;
    }

    function stem_caching($parm_ref) 
    {
        $caching_level = @$parm_ref['-level'];
        if ($caching_level) {
            if (!$this->m($caching_level, '/^[012]$/')) {
                die(__CLASS__ . "::stem_caching() - Legal values are '0','1' or '2'. '$caching_level' is not a legal value");
            }
            $this->Stem_Caching = $caching_level;
        }
        return $this->Stem_Caching;
    }

    function clear_stem_cache() 
    {
        $this->Stem_Cache = array();
    }
}
?>

Пример использования:
$stemmer = new Lingua_Stem_Ru();
echo $stemmer->stem_word('Котеровыми');

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

Fedia

Дата 4.9.2006, 07:05 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 465
Регистрация: 2.8.2006
Где: первым встречаю р ассвет

Репутация: 8
Всего: 13

ДЫМ, вот эту функцию не находил ?

Код


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;

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

--------------------

Накануне решающей битвы
Я иду, и надеждою зыбкой
Озаряется эта дорога,
Я мечтаю увидеть улыбку
На лице победившего Бога…

ДЫМ

Дата 4.9.2006, 20:48 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 224
Регистрация: 6.1.2004

Репутация: 8
Всего: 8

Цитата(Fedia @ 4.9.2006, 07:05

)

ДЫМ, вот эту функцию не находил ?

Да, это функция из Delphi World.

Цитата(Fedia @ 4.9.2006, 07:05

)

Правда она вроде не точно работает, но возможно если забить в нее константы из твоего примера (т.к. там более полный набор)

В том то и дело, что просто так добавить константы без существенной переделки кода не получится, а переделывать уж больно не хочется. Неужели нет здесь знатока PHP, функция то небольшая, помогите, пожалуйста.

1 Пользователей читают эту тему (1 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Общие вопросы \| Следующая тема »