L
Luciano Paulino da Silva
[snip]
Dear John,
Perfect, it is exactly this! It sounds good. After that we could think
other algorithms (rules).
Thanks in advance,
Luciano- Hide quoted text -
DearLuciano,
See if this works for you. As before, it uses Main() as the driver
sub, so you should delete all of my old code or create a new workbook
and put this in a new code module so as
to avoid possible name conflicts. I've tried it on a number of strings
and it seems to work as intended, but you should give it a full
battery of tests as well in case I overlooked something.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim palindromes As Object
Dim centers As Variant
Dim SearchString As String
Dim PalinCount As Long
Dim anchor As Range
Sub Initialize()
'initializes module-level variables
'centers contains, for each possible
'center of a palindrome (which may fall
'between two characters), the indices and
'length of the largest palindrome centered there.
'For arithmetical convience, centers will
'be represented by integers between 3 and
'2n-1. palindromes will be a dictionary
'object to store found palindromes and
'their frequencies
Dim i As Long, j As Long, k As Long, n As Long
Set palindromes = CreateObject("Scripting.Dictionary")
Set anchor = Range("A3")
SearchString = Range("A1").Value
n = Len(SearchString)
PalinCount = 0
ReDim centers(3 To 2 * n - 1, 1 To 3)
For i = 3 To 2 * n - 1
If i Mod 2 = 0 Then
'searching for palindromes like BAB
j = i / 2 - 1
k = j + 2
Else
'searching for palindromes like BAAB
j = Int(i / 2)
k = j + 1
End If
Do While j >= 1 And k <= n And _
Mid(SearchString, IIf(j > 0, j, 1), 1) = _
Mid(SearchString, k, 1)
'(kludge for lack of short-cicuit evaluation in VBA)
j = j - 1
k = k + 1
Loop
'last pass through the loop caused trouble, so correct:
j = j + 1
k = k - 1
'(this has weird effect of making j > k (j = k+1)
'if center cuts between two characters but no
'palindrome was found. Nevertheless, this gives
'correct length of 0 in this case, so ok)
centers(i, 1) = k - j + 1 'length
centers(i, 2) = j
centers(i, 3) = k
Next i
End Sub
Sub FindLargest(j As Long, k As Long)
'finds largest palindrome in range j-k
'after finding leftmost such
'it recursively calls itself on left and right remainders,
'printing the string if needed between calls
Dim i As Long, MinI As Long, MaxI As Long
Dim delta As Long
Dim MaxLen As Long, MaxStart As Long, MaxEnd As Long
Dim NewJ As Long, NewK As Long
Dim palindrome As String
MinI = 2 * j + 1
MaxI = 2 * k - 1
For i = MinI To MaxI
If centers(i, 1) > 1 Then
'first contract radius of palindrome
'to make it fit in j-k if needed
If centers(i, 2) < j Or centers(i, 3) > k Then
delta = j - centers(i, 2)
If delta < centers(i, 3) - k Then
delta = centers(i, 3) - k
End If
centers(i, 2) = centers(i, 2) + delta
centers(i, 3) = centers(i, 3) - delta
centers(i, 1) = centers(i, 3) - centers(i, 2) +1
End If
If centers(i, 1) > MaxLen Then
MaxLen = centers(i, 1)
MaxStart = centers(i, 2)
MaxEnd = centers(i, 3)
End If
End If
Next i
If MaxLen <= 1 Then Exit Sub
'else
'first process any string remaining to left
NewK = MaxStart - 1
NewJ = j
If NewK - NewJ > 0 Then FindLargest NewJ, NewK
'process current node
palindrome = Mid(SearchString, MaxStart, MaxLen)
If Not palindromes.Exists(palindrome) Then
'found new palindrome - display it
PalinCount = PalinCount + 1
anchor.Offset(PalinCount) = palindrome
palindromes.Add palindrome, 1
Else
palindromes.Item(palindrome) = palindromes.Item(palindrome) + 1
End If
'now process any remaining right substring
NewJ = MaxEnd + 1
NewK = k
If NewK - NewJ > 0 Then FindLargest NewJ, NewK
End Sub
Sub Main()
Dim i As Long, palindrome As String
If Len(Range("A1").Value) < 2 Then
MsgBox "A string of length > 1 must be entered in A1"
Exit Sub
End If
Initialize
anchor.CurrentRegion.ClearContents
FindLargest 1, Len(SearchString)
If palindromes.count = 0 Then
anchor.Value = "No palindromes found"
Else
anchor.Value = "Palindrome"
anchor.Offset(0, 1) = "Frequency"
anchor.Offset(0, 2) = "Length"
For i = 1 To PalinCount
palindrome = anchor.Offset(i).Value
anchor.Offset(i, 1).Value = _
palindromes.Item(palindrome)
anchor.Offset(i, 2).Value = Len(palindrome)
Next i
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Hope this works for you.
-John
Dear John,
I have performed some tests and it sounds good. I just did not
understand well the initialize module. I will perform an additional
battery of tests and tell you. Do you have an idea about how could we
perform similar test for serach repeats?
Thanks in advance,
Luciano