Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

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

01.01.2007

Автор: ___Nikolay

// Поиск по корню слова
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;

https://delphiworld.narod.ru/

DelphiWorld 6.0