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 ✨🙌🧑�💻👩�💻🔢📊🔄
'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�
'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