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

Previous  Top  Next

    
 

Автор: ___Nikolay

Code:

// Поиск по корню слова

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;

 

©Drkb::00859

http://delphiworld.narod.ru/

DelphiWorld 6.0