home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / Extended_R208147912007.psc / clsPhoneme.cls < prev    next >
Text File  |  2006-08-03  |  4KB  |  146 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "clsPhoneme"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = False
  10.  
  11. Option Explicit
  12.  
  13. '// Please see the accompanying documentation for the algorithms
  14.  
  15. '// Returns the 4 letter soundex for an english word
  16. Private Function Soundex(argWord As String)
  17. Dim workStr As String, i As Long, replaceMask(5) As Boolean
  18.  
  19.     '// Capitalize it to remove ambiguity
  20.     argWord = UCase$(argWord)
  21.     
  22.     '// 1. Retain the first letter of the string
  23.     workStr = Left$(argWord, 1)
  24.     
  25.     '// 2. Replacement
  26.     '   [a, e, h, i, o, u, w, y] = 0
  27.     '   [b, f, p, v] = 1
  28.     '   [c, g, j, k, q, s, x, z] = 2
  29.     '   [d, t] = 3
  30.     '   [l] = 4
  31.     '   [m, n] = 5
  32.     '   [r] = 6
  33.     
  34.     For i = 2 To Len(argWord)
  35.         Select Case Mid$(argWord, i, 1)
  36.             Case "B", "F", "P", "V"
  37.                 If replaceMask(0) = False Then
  38.                     workStr = workStr & Chr$(49) '// 1
  39.                     replaceMask(0) = True
  40.                 End If
  41.                 
  42.             Case "C", "G", "J", "K", "Q", "S", "X", "Z"
  43.                 If replaceMask(1) = False Then
  44.                     workStr = workStr & Chr$(50) '// 2
  45.                     replaceMask(1) = True
  46.                 End If
  47.             
  48.             Case "D", "T"
  49.                 If replaceMask(2) = False Then
  50.                     workStr = workStr & Chr$(51) '// 3
  51.                     replaceMask(2) = True
  52.                 End If
  53.             
  54.             Case "L"
  55.                 If replaceMask(3) = False Then
  56.                     workStr = workStr & Chr$(52) '// 4
  57.                     replaceMask(3) = True
  58.                 End If
  59.             
  60.             Case "M", "N"
  61.                 If replaceMask(4) = False Then
  62.                     workStr = workStr & Chr$(53) '// 5
  63.                     replaceMask(4) = True
  64.                 End If
  65.                 
  66.             Case "R"
  67.                 If replaceMask(5) = False Then
  68.                     workStr = workStr & Chr$(56) '// 6
  69.                     replaceMask(5) = True
  70.                 End If
  71.             
  72.             '// A, E, H, I, O, U, W, Y do nothing
  73.         End Select
  74.     Next i
  75.     
  76.     '// 5. Return the first four bytes padded with 0.
  77.     If Len(workStr) > 4 Then
  78.         Soundex = Left$(workStr, 4)
  79.     Else
  80.         Soundex = workStr & Space$(4 - Len(workStr))
  81.     End If
  82. End Function
  83.  
  84. '// Returns the Minimum of 3 numbers
  85. Private Function min3(ByVal n1 As Long, ByVal n2 As Long, ByVal n3 As Long) As Long
  86.     min3 = n1
  87.     If n2 < min3 Then min3 = n2
  88.     If n3 < min3 Then min3 = n3
  89. End Function
  90.  
  91. '// Returns the Levenshtein Distance between 2 strings.
  92. Private Function LevenshteinDistance(argStr1 As String, argStr2 As String) As Long
  93. Dim m As Long, n As Long
  94. Dim editMatrix() As Long, i As Long, j As Long, cost As Long
  95. Dim str1_i As String, str2_j As String
  96. Dim p() As Long, q() As Long, r As Long
  97. Dim x As Long, y As Long
  98.  
  99.     n = Len(argStr1)
  100.     m = Len(argStr2)
  101.     
  102.     'If (n = 0) Or (m = 0) Then Exit Function
  103.     ReDim editMatrix(n, m) As Long
  104.     
  105.     
  106.     For i = 0 To n
  107.         editMatrix(i, 0) = i
  108.     Next
  109.     
  110.     For j = 0 To m
  111.         editMatrix(0, j) = j
  112.     Next
  113.     
  114.     For i = 1 To n
  115.         str1_i = Mid$(argStr1, i, 1)
  116.         For j = 1 To m
  117.             str2_j = Mid$(argStr2, j, 1)
  118.             If str1_i = str2_j Then
  119.                 cost = 0
  120.             Else
  121.                 cost = 1
  122.             End If
  123.             
  124.             editMatrix(i, j) = min3(editMatrix(i - 1, j) + 1, editMatrix(i, j - 1) + 1, editMatrix(i - 1, j - 1) + cost)
  125.         Next j
  126.     Next i
  127.             
  128.     LevenshteinDistance = editMatrix(n, m)
  129.     Erase editMatrix
  130. End Function
  131.  
  132.  
  133. Public Function GetSoundexWord(ByVal inputStr As String) As String
  134.     If inputStr <> vbNullString Then GetSoundexWord = Soundex(inputStr)
  135. End Function
  136.  
  137. Public Function GetLevenshteinDistance(ByVal inputStr1 As String, ByVal inputStr2 As String) As Long
  138.     If inputStr1 = vbNullString Then
  139.         GetLevenshteinDistance = Len(inputStr2)
  140.     ElseIf inputStr2 = vbNullString Then
  141.         GetLevenshteinDistance = Len(inputStr1)
  142.     Else
  143.         GetLevenshteinDistance = LevenshteinDistance(inputStr1, inputStr2)
  144.     End If
  145. End Function
  146.