Skip to content

Instantly share code, notes, and snippets.

@wqweto

wqweto/Form1.twin

Last active November 28, 2025 20:54
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save wqweto/f72fbf39179d594a2bfc7c403e2f6b6f to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save wqweto/f72fbf39179d594a2bfc7c403e2f6b6f to your computer and use it in GitHub Desktop.
Download ZIP
QuickSort in TB
Raw
Form1.twin
[Description("")]
[FormDesignerId("70FFB010-72A5-4DC0-8DBC-4F33ED7EE0B0")]
[PredeclaredId]
Class Form1
Private DeclareWide Function StrCmpLogicalW Lib "shlwapi" (ByVal psz1 As String, ByVal psz2 As String) As Boolean
Sub New()
Dim a(0 To 1000000) As String
Dim lIdx As Long
Dim dblTimer As Double
Dim sPrev As String
Dim sElem As String
'--- generate random data
dblTimer = Timer
Randomize
For lIdx = 0 To UBound(a)
a(lIdx) = Space(50) & Rnd(10000)
Next
Debug.Print "Populated in " & Format$(Timer - dblTimer, "0.000")
'--- quick sort
dblTimer = Timer
QuickSortOverlay.QuickSort a
Debug.Print "Overlay Sorted in " & Format$(Timer - dblTimer, "0.000")
'--- check order
For Each sElem In a
If sElem < sPrev Then
MsgBox "Ooops!" & vbCrLf & vbCrLf & "sElem=" & sElem & ", sPrev=" & sPrev & ", lIdx=" & lIdx, vbCritical
Exit For
End If
sPrev = sElem
lIdx = lIdx + 1
Next
'--- natural sort
dblTimer = Timer
QuickSortString.QuickSort a ' , AddressOf CompLogical
Debug.Print "ASC sorted in " & Format$(Timer - dblTimer, "0.000")
End Sub
Private Function CompLogical(A As String, B As String) As Boolean
Return StrCmpLogicalW(A, B) < 0
End Function
End Class
Raw
QuickSort.twin
[ArrayBoundsChecks(False), IntegerOverflowChecks(False)]
Module QuickSortOverlay
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As LongPtr)
Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As LongPtr
Private Type SAFEARRAY1D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As LongPtr
cElements As Long
lLbound As Long
End Type
Public Sub QuickSort(B() As String)
Const PTR_SIZE As Long = LenB(Of LongPtr)
Dim uArray As SAFEARRAY1D
Dim A() As LongPtr
With uArray
.cDims = 1
.fFeatures = 1 ' FADF_AUTO
.cbElements = PTR_SIZE
.pvData = VarPtr(B(0))
.cElements = UBound(B) + 1
End With
Call CopyMemory(ByVal ArrPtr(A), VarPtr(uArray), PTR_SIZE)
pvQuickSortImpl A, B, LBound(A), UBound(A)
End Sub
Private Sub pvQuickSortImpl(A() As LongPtr, B() As String, ByVal lo As Long, ByVal hi As Long)
Dim lt As Long
Dim gt As Long
Do While lo < hi
pvQuickSortPartition A, B, lo, hi, lt, gt
pvQuickSortImpl A, B, lo, lt - 1
lo = gt + 1
Loop
End Sub
Private Sub pvQuickSortPartition(A() As LongPtr, B() As String, ByVal lo As Long, ByVal hi As Long, lt As Long, gt As Long)
Dim pivot As String
Dim eq As Long
Dim temp As LongPtr
pivot = B(lo + (hi - lo) \ 2)
lt = lo
eq = lo
gt = hi
Do While eq <= gt
If B(eq) < pivot Then
' Swap A(eq), A(lt)
temp = A(eq): A(eq) = A(lt): A(lt) = temp
lt = lt + 1
eq = eq + 1
ElseIf pivot < B(eq) Then
' Swap A(eq), A(gt)
temp = A(eq): A(eq) = A(gt): A(gt) = temp
gt = gt - 1
Else
eq = eq + 1
End If
Loop
End Sub
End Module
[ArrayBoundsChecks(False), IntegerOverflowChecks(False)]
Module QuickSortString
Private DeclareWide Sub CopyMemoryWide Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Delegate Function SortComparator (A As String, B As String) As Boolean
Private m_pfnComp As SortComparator
Public Sub QuickSort(A() As String, Optional pfnComp As SortComparator = vbNullPtr)
m_pfnComp = pfnComp
pvQuickSortImpl A, LBound(A), UBound(A)
End Sub
Private Sub pvQuickSortImpl(A() As String, ByVal lo As Long, ByVal hi As Long)
Dim lt As Long
Dim gt As Long
Do While lo < hi
If m_pfnComp = vbNullPtr Then
pvQuickSortPartitionFast A, lo, hi, lt, gt
Else
pvQuickSortPartitionCustom A, lo, hi, lt, gt, m_pfnComp
End If
pvQuickSortImpl A, lo, lt - 1
lo = gt + 1
Loop
End Sub
Private Sub pvQuickSortPartitionFast(A() As String, ByVal lo As Long, ByVal hi As Long, lt As Long, gt As Long)
Dim pivot As String
Dim eq As Long
Dim lPtr As LongPtr
pivot = A(lo + (hi - lo) \ 2)
lt = lo
eq = lo
gt = hi
Do While eq <= gt
If A(eq) < pivot Then
' Swap A(eq), A(lt)
lPtr = StrPtr(A(eq))
Call CopyMemoryWide(A(eq), StrPtr(A(lt)), LenB(Of LongPtr))
Call CopyMemoryWide(A(lt), lPtr, LenB(Of LongPtr))
lt = lt + 1
eq = eq + 1
ElseIf pivot < A(eq) Then
' Swap A(eq), A(gt)
lPtr = StrPtr(A(eq))
Call CopyMemoryWide(A(eq), StrPtr(A(gt)), LenB(Of LongPtr))
Call CopyMemoryWide(A(gt), lPtr, LenB(Of LongPtr))
gt = gt - 1
Else
eq = eq + 1
End If
Loop
End Sub
Private Sub pvQuickSortPartitionCustom(A() As String, ByVal lo As Long, ByVal hi As Long, lt As Long, gt As Long, pfnComp As SortComparator)
Dim pivot As String
Dim eq As Long
Dim lPtr As LongPtr
pivot = A(lo + (hi - lo) \ 2)
lt = lo
eq = lo
gt = hi
Do While eq <= gt
If pfnComp(A(eq), pivot) Then
' Swap A(eq), A(lt)
lPtr = StrPtr(A(eq))
Call CopyMemoryWide(A(eq), StrPtr(A(lt)), LenB(Of LongPtr))
Call CopyMemoryWide(A(lt), lPtr, LenB(Of LongPtr))
lt = lt + 1
eq = eq + 1
ElseIf pfnComp(pivot, A(eq)) Then
' Swap A(eq), A(gt)
lPtr = StrPtr(A(eq))
Call CopyMemoryWide(A(eq), StrPtr(A(gt)), LenB(Of LongPtr))
Call CopyMemoryWide(A(gt), lPtr, LenB(Of LongPtr))
gt = gt - 1
Else
eq = eq + 1
End If
Loop
End Sub
End Module
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment