Array Chain Sort Macros

[Theo Gottwald]

Sorting magic! 🔮✨ Chain can handle a variety of arrays: numbers, strings, custom data types, or objects. 🎛� We currently support up to 4 arrays out-of-the-box, but the macro is ready to grow with your needs. 📈
Feeling the need for more than 4? Reach out before the edit window closes! 🏃💨
P.S. The 4-array sort is tried and tested, but don't hesitate to test the waters further. 🧪👍

#SortingSolutions #ArrayMagic #CodingLife #MacroMagic #DevCommunity #TechTools #CodeNewbies ✨🙌🧑�💻👩�💻🔢📊🔄

Code Select Expand

'ArrayChainSortMacros.inc
'Public domain, use at own risk. SDurham

#If Not %Def(%ArrayChainSortMacros231211)
    %ArrayChainSortMacros231211 = 1

    'Chain Sort:
    'sort a chain of arrays
    'fist array acts as the index
    'arrays must be same size
    'COMPAREMACRO must support first array's data type
    'one-based index

    'this compare macro will handle number and string types
    'need to write a custom macro for objects and UDTs
    'string comparison will be case sensitive
    'need to write a custom for anything else
    '   A < B : return < 0
    '   A = B : return = 0
    '   A > B : return > 0
    Macro Function ChainSimpleCompare(A,B)
        MacroTemp result
        Local result As Long
        If A < B Then
            result = -1
        ElseIf A > B Then
            result = 1
        Else
            result = 0
        End If
    End Macro = result

    'swap two values
    Macro ChainSortSwap(A,B,VARKIND)
        MacroTemp temp
        Local temp As VARKIND
        temp = A : A = B : B = temp
    End Macro

    'chain sort 2 arrays
    Macro ChainSort2(COMPAREMACRO,A1,TYPE1,A2,TYPE2)
        MacroTemp i, j, leftIndex, rightIndex, counter, compare, value
        Register i As Long : Register j As Long : Local leftIndex, rightIndex, counter, compare As Long : Local value As TYPE1
        If UBound(A1) > 1 And UBound(A2) = UBound(A1) Then
            leftIndex = 1 : rightIndex = UBound(A1) : counter = 1
            !PUSH leftIndex
            !PUSH rightIndex
            While counter
                Decr counter
                !POP rightIndex
                !POP leftIndex
                i = leftIndex : j = rightIndex : value = A1((i + j) \ 2)
                While i <= j
                    compare = COMPAREMACRO(A1(i),value)
                    While compare < 0
                        Incr i
                        compare = COMPAREMACRO(A1(i),value)
                    Wend
                    compare = COMPAREMACRO(A1(j),value)
                    While compare > 0
                        Decr j
                        compare = COMPAREMACRO(A1(j),value)
                    Wend
                    If i <= j Then
                        If i <> j Then
                            ChainSortSwap(A1(i),A1(j),TYPE1)
                            ChainSortSwap(A2(i),A2(j),TYPE2)
                        End If
                        Incr i : Decr j
                    End If
                Wend
                If leftIndex < j Then
                    !PUSH leftIndex
                    !PUSH j
                    Incr counter
                End If
                If i < rightIndex Then
                    !PUSH i
                    !PUSH rightIndex
                    Incr counter
                End If
            Wend
        End If
    End Macro

    'chain sort 3 arrays
    Macro ChainSort3(COMPAREMACRO,A1,TYPE1,A2,TYPE2,A3,TYPE3)
        MacroTemp i, j, leftIndex, rightIndex, counter, compare, value
        Register i As Long : Register j As Long : Local leftIndex, rightIndex, counter, compare As Long : Local value As TYPE1
        If UBound(A1) > 1 And UBound(A2) = UBound(A1) And UBound(A3) = UBound(A1) Then
            leftIndex = 1 : rightIndex = UBound(A1) : counter = 1
            !PUSH leftIndex
            !PUSH rightIndex
            While counter
                Decr counter
                !POP rightIndex
                !POP leftIndex
                i = leftIndex : j = rightIndex : value = A1((i + j) \ 2)
                While i <= j
                    compare = COMPAREMACRO(A1(i),value)
                    While compare < 0
                        Incr i
                        compare = COMPAREMACRO(A1(i),value)
                    Wend
                    compare = COMPAREMACRO(A1(j),value)
                    While compare > 0
                        Decr j
                        compare = COMPAREMACRO(A1(j),value)
                    Wend
                    If i <= j Then
                        If i <> j Then
                            ChainSortSwap(A1(i),A1(j),TYPE1)
                            ChainSortSwap(A2(i),A2(j),TYPE2)
                            ChainSortSwap(A3(i),A3(j),TYPE3)
                        End If
                        Incr i : Decr j
                    End If
                Wend
                If leftIndex < j Then
                    !PUSH leftIndex
                    !PUSH j
                    Incr counter
                End If
                If i < rightIndex Then
                    !PUSH i
                    !PUSH rightIndex
                    Incr counter
                End If
            Wend
        End If
    End Macro

    'chain sort 4 arrays
    Macro ChainSort4(COMPAREMACRO,A1,TYPE1,A2,TYPE2,A3,TYPE3,A4,TYPE4)
        MacroTemp i, j, leftIndex, rightIndex, counter, compare, value
        Register i As Long : Register j As Long : Local leftIndex, rightIndex, counter, compare As Long : Local value As TYPE1
        If UBound(A1) > 1 And UBound(A2) = UBound(A1) And UBound(A3) = UBound(A1) And UBound(A4) = UBound(A1) Then
            leftIndex = 1 : rightIndex = UBound(A1) : counter = 1
            !PUSH leftIndex
            !PUSH rightIndex
            While counter
                Decr counter
                !POP rightIndex
                !POP leftIndex
                i = leftIndex : j = rightIndex : value = A1((i + j) \ 2)
                While i <= j
                    compare = COMPAREMACRO(A1(i),value)
                    While compare < 0
                        Incr i
                        compare = COMPAREMACRO(A1(i),value)
                    Wend
                    compare = COMPAREMACRO(A1(j),value)
                    While compare > 0
                        Decr j
                        compare = COMPAREMACRO(A1(j),value)
                    Wend
                    If i <= j Then
                        If i <> j Then
                            ChainSortSwap(A1(i),A1(j),TYPE1)
                            ChainSortSwap(A2(i),A2(j),TYPE2)
                            ChainSortSwap(A3(i),A3(j),TYPE3)
                            ChainSortSwap(A4(i),A4(j),TYPE4)
                        End If
                        Incr i : Decr j
                    End If
                Wend
                If leftIndex < j Then
                    !PUSH leftIndex
                    !PUSH j
                    Incr counter
                End If
                If i < rightIndex Then
                    !PUSH i
                    !PUSH rightIndex
                    Incr counter
                End If
            Wend
        End If
    End Macro
#EndIf '%ArrayChainSortMacros231211�


Code Select Expand

'ChainSort4.bas
#Option LargeMem32
#Compile Exe
#Dim All

#Include Once "ArrayChainSortMacros.inc"

Macro DoSetUp__
    Global gh As Long
    Global gOutFile As String
    gh = FreeFile
    gOutFile = Exe.Path$ + Exe.Name$ + ".txt"
    Kill gOutFile
    Open gOutFile For Append As gh
    Randomize
End Macro
Macro DoClose__
    Close gh
    Sleep 1
    Local hprocess&
    hprocess& = Shell("notepad.exe " + gOutFile, 1)
End Macro

Type UdtT
    X As Long
End Type

Macro UdtCompare(a,b) = Switch&(a.X < b.X, -1, a.X > b.X, 1) 'else match

Class ObjC
    Instance Value_ As Ext
    Interface ObjI : Inherit IUnknown
        Property Get Value() As Ext
            Property = Value_
        End Property
        Property Set Value(ByVal value As Ext)
            Value_ = value
        End Property
    End Interface
End Class

Macro Function ObjCompare(a,b)
    MacroTemp compare
    Local compare As Long
    If IsObject(a) And IsObject(b) Then
        compare = Switch&(a.Value < b.Value, -1, a.Value > b.Value, 1) 'else match
    End If
End Macro = compare

Macro LongCompare(a,b) = Switch&(a < b, -1, a > b, 1)

Macro StringCompare(a, b) = Switch&(UCase$(a) < UCase$(b), -1, UCase$(a) > UCase$(b), 1)

Function PBMain() As Long
    Local i As Long
    Local UdtArr() As UdtT
    Local ObjArr() As ObjI
    Local LngArr() As Long
    Local StrArr() As String
    Local e As Ext

    DoSetUp__

    Print# gh, ""
    Print# gh, "add values"
    ReDim UdtArr(1 To 5)
    ReDim ObjArr(1 To 5)
    ReDim LngArr(1 To 5)
    ReDim StrArr(1 To 5)
    For i = 1 To 5
        UdtArr(i).X = i
        ObjArr(i) = Class "ObjC"
        e = Rnd(300, 400)
        ObjArr(i).Value = e
        LngArr(i) = Rnd(100, 200)
        StrArr(i) = RandomString()
    Next i
    Print# gh, ""
    Print# gh, "--- display initial state ---"
    For i = 1 To 5
        Print# gh, "udt = " + Format$(UdtArr(i).X) + "   obj = " + Format$(ObjArr(i).Value) + "   long = " + Format$(LngArr(i)) + "   string = " + $Dq + StrArr(i) + $Dq
    Next i

    Print# gh, ""
    Print# gh, "sort on object array"
    ChainSort4(ObjCompare,ObjArr,ObjI,UdtArr,UdtT,LngArr,Long,StrArr,String)
    Print# gh, ""
    Print# gh, "--- sorted on object array ---"
    For i = 1 To 5
        Print# gh, "udt = " + Format$(UdtArr(i).X) + "   obj = " + Format$(ObjArr(i).Value) + "   long = " + Format$(LngArr(i)) + "   string = " + $Dq + StrArr(i) + $Dq
    Next i

    Print# gh, ""
    Print# gh, "sort on long array"
    ChainSort4(LongCompare,LngArr,Long,ObjArr,ObjI,UdtArr,UdtT,StrArr,String)
    Print# gh, ""
    Print# gh, "--- sorted on long array ---"
    For i = 1 To 5
        Print# gh, "udt = " + Format$(UdtArr(i).X) + "   obj = " + Format$(ObjArr(i).Value) + "   long = " + Format$(LngArr(i)) + "   string = " + $Dq + StrArr(i) + $Dq
    Next i

    Print# gh, ""
    Print# gh, "sort on string array UCase"
    ChainSort4(StringCompare,StrArr,String,LngArr,Long,ObjArr,ObjI,UdtArr,UdtT)
    Print# gh, ""
    Print# gh, "--- sorted on string array ---"
    For i = 1 To 5
        Print# gh, "udt = " + Format$(UdtArr(i).X) + "   obj = " + Format$(ObjArr(i).Value) + "   long = " + Format$(LngArr(i)) + "   string = " + $Dq + StrArr(i) + $Dq
    Next i

    Print# gh, ""
    Print# gh, "sort on udt array"
    ChainSort4(UdtCompare,UdtArr,UdtT,StrArr,String,LngArr,Long,ObjArr,ObjI)
    Print# gh, ""
    Print# gh, "--- sorted on udt array ---"
    For i = 1 To 5
        Print# gh, "udt = " + Format$(UdtArr(i).X) + "   obj = " + Format$(ObjArr(i).Value) + "   long = " + Format$(LngArr(i)) + "   string = " + $Dq + StrArr(i) + $Dq
    Next i

    Print# gh, ""
    Print# gh, ""

    DoClose__
End Function

Function RandomString() As String
    Register i As Long
    Local s As String
    For i = 1 To Rnd(5, 10)
        Select Case As Const Rnd(1, 2)
            Case 1 : s += Chr$(Rnd(65, 90))
            Case 2 : s += Chr$(Rnd(97, 122))
        End Select
    Next i
    Function = s
End Function