[RESOLVED] QuickSort Caseless

[Dragokas]

Hi,

I'd like a QuickSort for string array, allowing to ignore a letter case during the sorting.

I have this original one, a port by The Trick:

Private Sub QuickSort(j() As Variant, ByVal low As Long, ByVal high As Long)
    Dim i As Long, L As Long, m As String, wsp As String
    i = low: L = high: m = j((i + L) \ 2)
    Do Until i > L: Do While j(i) < m: i = i + 1: Loop: Do While j(L) > m: L = L - 1: Loop
        If (i <= L) Then wsp = j(i): j(i) = j(L): j(L) = wsp: i = i + 1: L = L - 1
    Loop
    If low < L Then QuickSort j, low, L
    If i < high Then QuickSort j, i, high
End Sub

I modified it in this way:

Option Explicit

Private Sub Form_Load()
    Dim data(): data = Array("write.exe", "winhlp32.exe", "VIXUNIN.EXE", "twunk_32.exe", "twain.dll", "Sysmon64.exe", _
    "splwow64.exe", "RtlExUpd.dll", "REGTLIB.EXE", "regedit.exe", "pyw.exe", "pyshellext.amd64.dll", "py.exe", "PSEXESVC.exe", _
    "notepad.exe", "hh.exe", "HelpPane.exe", "fveupdate.exe", "explorer.exe", "directx.sys", "cmd.exe", "bfsvc.exe", "AsTaskSched.dll")

    QuickSort_NoCase data, 0, UBound(data)

    Dim i As Long
    For i = 0 To UBound(data): Debug.Print data(i): Next
End Sub

Private Sub QuickSort_NoCase(j() As Variant, ByVal low As Long, ByVal high As Long)
    Dim i As Long, L As Long, m As String, wsp As String
    i = low: L = high: m = j((i + L) \ 2)
    Do Until i > L: Do While CompareStr_NoCase(j(i), m) = -1: i = i + 1: Loop: Do While CompareStr_NoCase(j(L), m) = 1: L = L - 1: Loop
        If (i <= L) Then wsp = j(i): j(i) = j(L): j(L) = wsp: i = i + 1: L = L - 1
    Loop
    If low < L Then QuickSort j, low, L
    If i < high Then QuickSort j, i, high
End Sub

' @return: 
' 0 = equal 
' -1 = less 
' 1 = greater 
'
Private Function CompareStr_NoCase(s1 As Variant, s2 As Variant) As Long
    Dim i As Long
    Dim ret As Long
    For i = 1 To Len(s1)
        ret = CompareChar_NoCase(Mid$(s1, i, 1), Mid$(s2, i, 1))
        If ret <> 0 Then
            CompareStr_NoCase = ret
            Exit For
        End If
    Next
End Function

' @return: 
' 0 = equal 
' -1 = less 
' 1 = greater 
'
Private Function CompareChar_NoCase(ByVal ch1 As String, ByVal ch2 As String) As Long
    ch1 = UCase$(ch1)
    ch2 = UCase$(ch2)
    If ch1 > ch2 Then
        CompareChar_NoCase = 1
    ElseIf ch1 <> ch2 Then
        CompareChar_NoCase = -1
    End If
End Function

But, something is working incorrectly in this algorithm.
The results are:

AsTaskSched.dll
HelpPane.exe
PSEXESVC.exe
bfsvc.exe
cmd.exe
directx.sys
explorer.exe
fveupdate.exe
hh.exe
notepad.exe
py.exe
pyshellext.amd64.dll
REGTLIB.EXE
RtlExUpd.dll
Sysmon64.exe
VIXUNIN.EXE
pyw.exe
regedit.exe
splwow64.exe
twain.dll
twunk_32.exe
winhlp32.exe
write.exe

Can you please, give a look?

[The trick]

You forgot to replace QuickSort to QuickSort_NoCase in QuickSort_NoCase. It's more faster to use StrComp.

[wqweto]

In QuickSort_NoCase you are recursively calling QuickSort, not QuickSort_NoCase

After the fix it works here as expected but the performance is dog-slow.

This one is using CompareStringW API and is faster

Option Explicit

Private Declare Function CompareStringW Lib "kernel32" (ByVal Locale As Long, ByVal dwCmpFlags As Long, ByVal lpString1 As Long, ByVal cchCount1 As Long, ByVal lpString2 As Long, ByVal cchCount2 As Long) As Long

Private Sub Form_Load()
    Dim data(): data = Array("write.exe", "winhlp32.exe", "VIXUNIN.EXE", "twunk_32.exe", "twain.dll", "Sysmon64.exe", _
    "splwow64.exe", "RtlExUpd.dll", "REGTLIB.EXE", "regedit.exe", "pyw.exe", "pyshellext.amd64.dll", "py.exe", "PSEXESVC.exe", _
    "notepad.exe", "hh.exe", "HelpPane.exe", "fveupdate.exe", "explorer.exe", "directx.sys", "cmd.exe", "bfsvc.exe", "AsTaskSched.dll")

    QuickSort_NoCase data, 0, UBound(data)

    Dim i As Long
    For i = 0 To UBound(data): Debug.Print data(i): Next
End Sub

Private Sub QuickSort_NoCase(j() As Variant, ByVal low As Long, ByVal high As Long)
    Dim i As Long, L As Long, m As String, wsp As String
    i = low: L = high: m = j((i + L) \ 2)
    Do Until i > L: Do While CompareStr_NoCase(j(i), m) = -1: i = i + 1: Loop: Do While CompareStr_NoCase(j(L), m) = 1: L = L - 1: Loop
        If (i <= L) Then wsp = j(i): j(i) = j(L): j(L) = wsp: i = i + 1: L = L - 1
    Loop
    If low < L Then QuickSort_NoCase j, low, L
    If i < high Then QuickSort_NoCase j, i, high
End Sub

' @return:
' 0 = equal
' -1 = less
' 1 = greater
'
Private Function CompareStr_NoCase(ByVal s1 As String, ByVal s2 As String) As Long
    Const LOCALE_USER_DEFAULT           As Long = &H400
    Const NORM_IGNORECASE               As Long = 1
    Const CSTR_EQUAL                    As Long = 2
    
    CompareStr_NoCase = (CompareStringW(LOCALE_USER_DEFAULT, NORM_IGNORECASE, _
        StrPtr(s1), Len(s1), StrPtr(s2), Len(s2)) - CSTR_EQUAL)
End Function

Edit: The Trick beat me to it and using StrComp is better when you have strings. Use CompareStringW API only if you have raw pointers to the strings you have to compare.

cheers,
</wqw>

[Dragokas]

You forgot to replace QuickSort to QuickSort_NoCase in QuickSort_NoCase

OMG

Thanks, The trick and wqweto for solution and optimization!

[Dragokas]

----

[Dragokas]

To finish the topic, here is a max performance-optimized version, enhanced with some The Trick suggestions in PM + wqweto example.
Only pointers manipulation.

2 functions:
- QuickSort_NoCaseV() - for Variant/String()
- QuickSort_NoCase() - for String()

Require DEXWERX vb6.tlb

Option Explicit

Private Declare Function CompareStringW Lib "kernel32" (ByVal Locale As Long, ByVal dwCmpFlags As Long, ByVal lpString1 As Long, ByVal cchCount1 As Long, ByVal lpString2 As Long, ByVal cchCount2 As Long) As Long
Private Declare Function PutMem4 Lib "msvbvm60.dll" (ByVal Addr As Long, ByVal NewVal As Long) As Long

Const LOCALE_USER_DEFAULT           As Long = &H400
Const NORM_IGNORECASE               As Long = 1
Const CSTR_LESS_THAN                As Long = 1
Const CSTR_GREATER_THAN             As Long = 3

' For Variant/String() only! 
' Sorts array case insensitive. 
'
Public Sub QuickSort_NoCaseV(j() As Variant, ByVal low As Long, ByVal high As Long)
    Dim i As Long, L As Long, pM As Long, cM As Long, wsp As Long, pVA As Long
    i = low: L = high: wsp = (i + L) \ 2: pM = StrPtr(j(wsp)): cM = Len(j(wsp))
    pVA = Deref(AryPtr(j) + 12) 'SAFEARRAY.pvData => VARIANT 
    Do Until i > L
        Do While CompareStringW(LOCALE_USER_DEFAULT, NORM_IGNORECASE, StrPtr(j(i)), Len(j(i)), pM, cM) = CSTR_LESS_THAN: i = i + 1: Loop
        Do While CompareStringW(LOCALE_USER_DEFAULT, NORM_IGNORECASE, StrPtr(j(L)), Len(j(L)), pM, cM) = CSTR_GREATER_THAN: L = L - 1: Loop
        If (i <= L) Then
            wsp = StrPtr(j(L))
            PutMem4 ByVal (pVA + 16 * L + 8), StrPtr(j(i))
            PutMem4 ByVal (pVA + 16 * i + 8), wsp
            i = i + 1: L = L - 1
        End If
    Loop
    If low < L Then QuickSort_NoCaseV j, low, L
    If i < high Then QuickSort_NoCaseV j, i, high
End Sub

' For String() 
' Sorts array case insensitive. 
'
Public Sub QuickSort_NoCase(j() As String, ByVal low As Long, ByVal high As Long)
    Dim i As Long, L As Long, pM As Long, cM As Long, wsp As Long, pSA As Long
    i = low: L = high: wsp = (i + L) \ 2: pM = StrPtr(j(wsp)): cM = Len(j(wsp))
    pSA = Deref(AryPtr(j) + 12) 'SAFEARRAY.pvData => BSTR 
    Do Until i > L
        Do While CompareStringW(LOCALE_USER_DEFAULT, NORM_IGNORECASE, StrPtr(j(i)), Len(j(i)), pM, cM) = CSTR_LESS_THAN: i = i + 1: Loop
        Do While CompareStringW(LOCALE_USER_DEFAULT, NORM_IGNORECASE, StrPtr(j(L)), Len(j(L)), pM, cM) = CSTR_GREATER_THAN: L = L - 1: Loop
        If (i <= L) Then
            wsp = StrPtr(j(L))
            PutMem4 ByVal (pSA + 4 * L), StrPtr(j(i))
            PutMem4 ByVal (pSA + 4 * i), wsp
            i = i + 1: L = L - 1
        End If
    Loop
    If low < L Then QuickSort_NoCase j, low, L
    If i < high Then QuickSort_NoCase j, i, high
End Sub