Работает не идеально, отрезает не все суффиксы и игнорирует приставки. И насчет приставок правильно - алгоритм предназначен для индексации текстов с целью последующего поиска с учетом словоформ. А в русском языке наличие разных приставок у одного и того же корня образует такое же количество разных понятий, например разъезд, подъезд, выезд.
- Код: Выделить всё
Option Explicit
Private Const REFLEXIVE = "(с[яь])$"
Private Const ADJECTIVE = "(ее|ие|ые|ое|ими|ыми|ей|ий|ый|ой|ем|им|ым|ом|его|ого|ему|ому|их|ых|ую|юю|ая|яя|ою|ею)$"
Private Const NOUN = "(а|ев|ов|ие|ье|е|иями|ями|ами|еи|ии|и|ией|ей|ой|ий|й|иям|ям|ием|ем|ам|ом|о|у|ах|иях|ях|ы|ь|ию|ью|ю|ия|ья|я)$"
Private Const RVRE = "^(.*?[аеиоуыэюя])(.*)$"
Private Const DERIVATIONAL = "[^аеиоуыэюя][аеиоуыэюя]+[^аеиоуыэюя]+.*ость?"
Private Const PERFECTIVEGROUND = "(ив|ивши|ившись|ыв|ывши|ывшись)$|[ая](в|вши|вшись)$"
Private Const PARTICIPLE = "(ивш|ывш|ующ)$|[ая](ем|нн|вш|ющ|щ)$"
Private Const VERB = "(ила|ыла|ена|ейте|уйте|ите|или|ыли|ейх.й|ил|ыл|им|ым|ен|ило|ыло|ено|ят|ует|уют|ит|ыт|ены|ить|ыть|ишь|ую|ю)$|[ая](ла|на|ете|йте|ли|й|л|ем|н|ло|но|ет|ют|ны|ть|ешь|нно)$"
Dim objRegexp As New RegExp
Public Function StemWord(Word As String) As String
Dim p As MatchCollection
Dim start As String, prev As String
Dim rv As String
On Error GoTo errh
Word = Replace(Word, "ё", "е")
objRegexp.Pattern = RVRE
Set p = objRegexp.Execute(Word)
If p.Count = 0 Then
StemWord = Word
Exit Function
End If
start = p.Item(0).SubMatches.Item(0)
rv = p.Item(0).SubMatches.Item(1)
Do
prev = rv
If Len(rv) = 0 Then
StemWord = Word
Exit Function
End If
If Not subS(rv, PERFECTIVEGROUND, "") Then
Call subS(rv, REFLEXIVE, "")
If subS(rv, ADJECTIVE, "") Then
Call subS(rv, PARTICIPLE, "")
Else
If (Not subS(rv, VERB, "")) Then Call subS(rv, NOUN, "")
End If
End If
Call subS(rv, "(и)$", "")
objRegexp.Pattern = DERIVATIONAL
If objRegexp.Test(rv) Then Call subS(rv, "(ость?)$", "")
If (Not subS(rv, "(ь)$", "")) Then
Call subS(rv, "(ейше?)", "")
Call subS(rv, "(нн)$", "н")
End If
Loop Until prev = rv
StemWord = start & rv
Exit Function
errh:
frmMain.AddMessage meError, Err.Description, "StemWord"
End Function
Private Function subS(s1 As String, re As String, toA As String) As Boolean
Dim orig As String
Dim subPatterns As MatchCollection
orig = s1
objRegexp.Pattern = re
Set subPatterns = objRegexp.Execute(orig)
If subPatterns.Count > 0 Then
If subPatterns.Item(0).SubMatches.Item(0) <> "" Then
objRegexp.Pattern = subPatterns.Item(0).SubMatches.Item(0) & "$"
Else
If subPatterns.Item(0).SubMatches.Item(1) <> "" Then
objRegexp.Pattern = subPatterns.Item(0).SubMatches.Item(1) & "$"
Else
objRegexp.Pattern = "^$"
End If
End If
End If
s1 = objRegexp.Replace(s1, toA)
subS = orig <> s1
End Function
