Results 1 to 6 of 6

Thread: [RESOLVED] QuickSort Caseless

  1. #1

    Thread Starter
    Member Dragokas's Avatar
    Join Date
    Aug 2015
    Location
    Ukraine
    Posts
    641

    Resolved [RESOLVED] QuickSort Caseless

    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:

    Code:
    
    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:
    Code:
    
    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?
    Malware analyst, VirusNet developer, HiJackThis Fork author || my CodeBank works

  2. #2

  3. #3
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Posts
    2,713

    Re: QuickSort Caseless

    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

    Code:
    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>

  4. #4

    Thread Starter
    Member Dragokas's Avatar
    Join Date
    Aug 2015
    Location
    Ukraine
    Posts
    641

    Re: QuickSort Caseless

    Quote Originally Posted by The trick View Post
    You forgot to replace QuickSort to QuickSort_NoCase in QuickSort_NoCase
    OMG

    Thanks, The trick and wqweto for solution and optimization!
    Malware analyst, VirusNet developer, HiJackThis Fork author || my CodeBank works

  5. #5

    Thread Starter
    Member Dragokas's Avatar
    Join Date
    Aug 2015
    Location
    Ukraine
    Posts
    641

    Re: [RESOLVED] QuickSort Caseless

    ----
    Last edited by Dragokas; Jan 21st, 2021 at 06:44 PM.
    Malware analyst, VirusNet developer, HiJackThis Fork author || my CodeBank works

  6. #6

    Thread Starter
    Member Dragokas's Avatar
    Join Date
    Aug 2015
    Location
    Ukraine
    Posts
    641

    Re: [RESOLVED] QuickSort Caseless

    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

    Code:
    
    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
    
    Last edited by Dragokas; Jan 22nd, 2021 at 03:33 PM.
    Malware analyst, VirusNet developer, HiJackThis Fork author || my CodeBank works

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width