Attribute VB_Name = "mdlDiff"
Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)

Private Type tElem
    row As Long
    col As Long
End Type

Private Type tQueue
    Count As Long
    Head As Long
    Tail As Long
    aElems() As tElem
End Type

Dim Queue As tQueue
Dim Mat() As Long

Dim aT1() As Integer
Dim aT2() As Integer
Dim Len1 As Long
Dim Len2 As Long

Function TextDiff(s1, s2) As Double
Dim df As Double
Len1 = Len(s1)
Len2 = Len(s2)
If Len1 = 0 And Len2 = 0 Then TextDiff = 1: Exit Function
If Len1 = 0 Or Len2 = 0 Then Exit Function
ReDim aT1(1 To Len1)
ReDim aT2(1 To Len2)
CopyMemory VarPtr(aT1(1)), StrPtr(s1), LenB(s1)
CopyMemory VarPtr(aT2(1)), StrPtr(s2), LenB(s2)
'df = Diff(1, 1, 0)
'TextDiff = (Len1 + Len2 - df) / (Len1 + Len2)
'TextDiff = DiffBfs
TextDiff = DiffBack
End Function

Private Function DiffDfs(ByVal row As Long, ByVal col As Long, ByVal score As Long) As Long
Dim lowest As Long, n As Long
lowest = Len1 + Len2
If row > Len2 Then DiffDfs = score + Len1 + 1 - col: Exit Function
If col > Len1 Then DiffDfs = score + Len2 + 1 - row: Exit Function
If aT1(col) = aT2(row) Then lowest = DiffDfs(row + 1, col + 1, score)
n = DiffDfs(row + 1, col, score + 1)
If n < lowest Then lowest = n
n = DiffDfs(row, col + 1, score + 1)
If n < lowest Then lowest = n
DiffDfs = lowest
End Function

Private Function DiffBfs() As Double
Dim elem As tElem
Dim inc As Long
Dim score As Long, mn As Double, mx As Double
ReDim Mat(1 To Len2, 1 To Len1)
ReDim Queue.aElems(1 To Len1 * Len2)
Queue.Count = 0
score = Len1 + Len2
Enqueue 1, 1, 0, score
Do While Queue.Count
    elem = Dequeue
    inc = Mat(elem.row, elem.col) + 1
    If aT1(elem.col) = aT2(elem.row) Then Enqueue elem.row + 1, elem.col + 1, inc, score
    Enqueue elem.row, elem.col + 1, inc, score
    Enqueue elem.row + 1, elem.col, inc, score
Loop
'Debug.Print score;
mx = Len1 + Len2
If Len2 < Len1 Then mn = Len2 Else mn = Len1
score = score - mn
mx = mx - mn
DiffBfs = (mx - score) / mx
End Function

Private Sub Enqueue(ByVal row As Long, ByVal col As Long, ByVal score As Long, ByRef total As Long)
Dim n As Long
If row > Len2 Then
    n = score + Len1 + 1 - col
    If n < total Then total = n
    Exit Sub
End If
If col > Len1 Then
    n = score + Len2 + 1 - row
    If n < total Then total = n
    Exit Sub
End If
If Queue.Count = 0 Then Queue.Head = 1: Queue.Tail = 0
If Mat(row, col) Then If Mat(row, col) <= score Then Exit Sub
Mat(row, col) = score
Queue.Count = Queue.Count + 1
Queue.Tail = Queue.Tail + 1
Queue.aElems(Queue.Tail).row = row
Queue.aElems(Queue.Tail).col = col
End Sub

Private Function Dequeue() As tElem
If Queue.Count = 0 Then Exit Function
Dequeue = Queue.aElems(Queue.Head)
Queue.Head = Queue.Head + 1
Queue.Count = Queue.Count - 1
End Function

Private Function DiffBack() As Double
Dim row As Long, col As Long, r As Long, c As Long
Dim score As Long, n As Long, dest As Long, mn As Double, mx As Double
ReDim Mat(1 To Len2, 1 To Len1)
r = Len2
c = Len1
If aT1(c) = aT2(r) Then Mat(r, c) = 1 Else Mat(r, c) = 2
Do While r > 1 Or c > 1
    If r > 1 Then
        row = r - 1
        col = Len1
        If aT1(col) = aT2(row) Then score = Len2 + 1 - row Else score = Len2 + 2 - row
        n = Mat(row + 1, col) + 1
        If score > n Then score = n
        Mat(row, col) = score
        dest = Len1 - (Len2 - row) + 1
        If dest < 1 Then dest = 1
        For col = col - 1 To dest Step -1
            BestScore row, col
        Next
        r = r - 1
    End If
    If c > 1 Then
        col = c - 1
        row = Len2
        If aT1(col) = aT2(row) Then score = Len1 + 1 - col Else score = Len1 + 2 - col
        n = Mat(row, col + 1) + 1
        If score > n Then score = n
        Mat(row, col) = score
        dest = Len2 - (Len1 - col) + 1
        If dest < 1 Then dest = 1
        For row = row - 1 To dest Step -1
            BestScore row, col
        Next
        c = c - 1
    End If
    If r > 0 And c > 0 Then BestScore r, c
Loop
score = Mat(1, 1)
mx = Len1 + Len2
If Len2 < Len1 Then mn = Len2 Else mn = Len1
score = score - mn
mx = mx - mn
DiffBack = (mx - score) / mx
End Function

Private Function BestScore(ByVal row As Long, ByVal col As Long) As Long
Dim score As Long
Dim n As Long
score = Mat(row + 1, col) + 1
n = Mat(row, col + 1) + 1
If n < score Then score = n
If aT1(col) = aT2(row) Then n = Mat(row + 1, col + 1) + 1: If n < score Then score = n
Mat(row, col) = score
End Function