VBA – Longest Palindromic Subsequence Algorithm with Excel – GIF

Posted on August 7, 2019 by

After writing about the longest palindromic substring, now it is time to see the longest palindromic subsequence. What is the difference? Pretty much, if we take the word abracadabra:

the longest substring is ada in abracadabra
the longest subsequence is one of the following 3:
- abadaba – in abracadabra
- abaaaba – in abracadabra
- abacada – in abracadabra

So, it is quite obvious that we have some kind of an interesting problem again, which could be solved with Excel. In order to solve it with a nice complexity, we are only going to find the lenght of the longest subsequence and display its starting and ending index. Thus for OPABRACADABRAK this would be the resulting picture:

So, let’s start with the algorithm:

Sub Main()
      
    Dim theWord As String: theWord = "OPABRACADABRAK"
    Dim length As Long: length = Len(theWord)
    Dim maxLength As Long: maxLength = 1
    Dim startAt As Long: startAt = 1
    
    ClearTable
    EditTheTable length
    WriteTheWord theWord
    
    ReDim matrix(length - 1, length - 1) As Long
    
    'For 1:
    Dim i As Long
    For i = LBound(matrix) To UBound(matrix)
        tblMatrix.Cells(i + 1, i + 1).Interior.Color = vbYellow
        tblMatrix.Cells(i + 1, i + 1) = 1
    Next
    
    'For 2:
    For i = LBound(matrix) + 1 To UBound(matrix)
        If (Mid(theWord, i, 1) = Mid(theWord, i + 1, 1)) Then
            maxLength = 2
            startAt = i
            tblMatrix.Cells(i, i + 1).Interior.Color = vbYellow
            tblMatrix.Cells(i, i + 1) = 2
        Else
            tblMatrix.Cells(i, i + 1) = 1
        End If
    Next
    
    'For >2:
    Dim k As Long
    For k = 3 To length
        Dim startingIndex As Long
        For startingIndex = 1 To length - k + 1
            Dim endingIndex As Long: endingIndex = startingIndex + k - 1
            
                With tblMatrix
                    .Cells(length + 3, 1) = Mid(theWord, startingIndex, 1)
                    .Cells(length + 3, 2) = Mid(theWord, endingIndex, 1)
                    .Cells(length + 3, 1).Interior.Color = vbRed
                    .Cells(length + 3, 2).Interior.Color = vbRed
                End With
                
                Dim myCell As Range
                Set myCell = tblMatrix.Cells(startingIndex, endingIndex)
                myCell.Select
                                              
                If Mid(theWord, startingIndex, 1) = Mid(theWord, endingIndex, 1) Then
                    myCell.Interior.Color = vbYellow
                    myCell = myCell.Offset(1, -1) + 2
                    maxLength = k
                    startAt = startingIndex
                Else
                    myCell = WorksheetFunction.Max(myCell.Offset(0, -1), myCell.Offset(1, 0))
                End If
        Next startingIndex
    Next k
    
    With tblMatrix
        .Range(.Cells(length + 2, startAt), .Cells(length + 2, startAt + maxLength - 1)).Interior.Color = vbYellow
    End With
    
End Sub

Sub EditTheTable(length As Long)
    
    tblMatrix.Cells.Delete
    Dim i As Long
    For i = 1 To length
        tblMatrix.Columns(i).ColumnWidth = 3.14
    Next
    
End Sub

Sub ClearTable()
    tblMatrix.Cells.Clear
End Sub

Sub WriteTheWord(theWord As String)
    
    Dim row As Long
    Dim col As Long
    Dim sizeCounter As Long
    
    For row = 1 To Len(theWord) + 2
        If row <> Len(theWord) + 1 Then
        For col = 1 To Len(theWord)
            sizeCounter = sizeCounter + 1
            tblMatrix.Cells(row, col) = Mid(theWord, sizeCounter, 1)
        Next
        End If
        sizeCounter = 0
    Next
        
End Sub

Sub Main()

Dim theWord As String: theWord = "OPABRACADABRAK"

Dim length As Long: length = Len(theWord)

Dim maxLength As Long: maxLength = 1

Dim startAt As Long: startAt = 1

ClearTable

EditTheTable length

WriteTheWord theWord

ReDim matrix(length - 1, length - 1) As Long

'For 1:

Dim i As Long

For i = LBound(matrix) To UBound(matrix)

tblMatrix.Cells(i + 1, i + 1).Interior.Color = vbYellow

tblMatrix.Cells(i + 1, i + 1) = 1

'For 2:

For i = LBound(matrix) + 1 To UBound(matrix)

If (Mid(theWord, i, 1) = Mid(theWord, i + 1, 1)) Then

maxLength = 2

startAt = i

tblMatrix.Cells(i, i + 1).Interior.Color = vbYellow

tblMatrix.Cells(i, i + 1) = 2

Else

tblMatrix.Cells(i, i + 1) = 1

End If

'For >2:

Dim k As Long

For k = 3 To length

Dim startingIndex As Long

For startingIndex = 1 To length - k + 1

Dim endingIndex As Long: endingIndex = startingIndex + k - 1

With tblMatrix

.Cells(length + 3, 1) = Mid(theWord, startingIndex, 1)

.Cells(length + 3, 2) = Mid(theWord, endingIndex, 1)

.Cells(length + 3, 1).Interior.Color = vbRed

.Cells(length + 3, 2).Interior.Color = vbRed

End With

Dim myCell As Range

Set myCell = tblMatrix.Cells(startingIndex, endingIndex)

myCell.Select

If Mid(theWord, startingIndex, 1) = Mid(theWord, endingIndex, 1) Then

myCell.Interior.Color = vbYellow

myCell = myCell.Offset(1, -1) + 2

maxLength = k

startAt = startingIndex

Else

myCell = WorksheetFunction.Max(myCell.Offset(0, -1), myCell.Offset(1, 0))

End If

Next startingIndex

Next k

With tblMatrix

.Range(.Cells(length + 2, startAt), .Cells(length + 2, startAt + maxLength - 1)).Interior.Color = vbYellow

End With

End Sub

Sub EditTheTable(length As Long)

tblMatrix.Cells.Delete

Dim i As Long

For i = 1 To length

tblMatrix.Columns(i).ColumnWidth = 3.14

End Sub

Sub ClearTable()

tblMatrix.Cells.Clear

End Sub

Sub WriteTheWord(theWord As String)

Dim row As Long

Dim col As Long

Dim sizeCounter As Long

For row = 1 To Len(theWord) + 2

If row <> Len(theWord) + 1 Then

For col = 1 To Len(theWord)

sizeCounter = sizeCounter + 1

tblMatrix.Cells(row, col) = Mid(theWord, sizeCounter, 1)

End If

sizeCounter = 0

End Sub

This time, the yellow color is used only for visualisation and not into the calculations, as it was in the longest palindromic substring. The first loops parts of both algorithms are pretty much the same – they check the diagonal and simply write the values of 1 in there (in the palindromic substring it was a boolean value). Then a check for the length of 2 is made and if it was correct, then 2 is written, otherwise 1:

Then the algorithms become a bit different. The current one is a typical greedy algorithm that does the following:

Compares values at the starting and the ending index of the researched string. If they are the same, then it increases the value from the left diagonal with 2. Otherwise it gives the maximal value of between the lower and the left cell:

                If Mid(theWord, startingIndex, 1) = Mid(theWord, endingIndex, 1) Then
                    myCell.Interior.Color = vbYellow
                    myCell = myCell.Offset(1, -1) + 2
                    maxLength = k
                    startAt = startingIndex
                Else
                    myCell = WorksheetFunction.Max(myCell.Offset(0, -1), myCell.Offset(1, 0))
                End If

If Mid(theWord, startingIndex, 1) = Mid(theWord, endingIndex, 1) Then

myCell.Interior.Color = vbYellow

myCell = myCell.Offset(1, -1) + 2

maxLength = k

startAt = startingIndex

Else

myCell = WorksheetFunction.Max(myCell.Offset(0, -1), myCell.Offset(1, 0))

End If

The algorithm “in action” looks like this:

The GitHub code is here – https://github.com/Vitosh/VBA/blob/master/LongestPalindromicSubsequence.vb

Enjoy!

Tagged with: algorithm, Excel, Longest, Palindromic, subsequence, VBA

VBA – Longest Palindromic Subsequence Algorithm with Excel – GIF

Related posts: