[RESOLVED] How do I LexicoGraphically Sort a Array of Arrays in vb6

[sspoke]

Hello,

What i'm trying to do is sort lexicographically (abc order, well in my case in incremental byte order).
I got very confused when I attempted to do this myself.

This is the code how I attempted its a complete disaster.
First of all it has process the array of bytes as a multidimensional array even though it's just 1 array.
Secondly it has to pick the first byte of each row in the array I assume sort all that in a increasing number.
Save the indexes of the already sorted first byte of each row.
Then do this to the second byte in the first row keeping in mind that if a match actually occurs it also has to remain sorted most importantly using the first byte of each row. Very confusing task thats why I ask for help.


Here is a example of how it suppose to work say you got this data.
6 4 4 2 9 3 1 7 4 1 3 3 9 4 1 3 3 8 3 1

the data will has to be represented by a square because its a array of arrays
so like this
6 4 4 2 9
3 1 7 4 1
3 3 9 4 1
3 3 8 3 1

Then the lexico sort should result in a list that looks like this

1,3,2,0

because if you sort it properly it should look like this

3 1 7 4 1
3 3 8 3 1
3 3 9 4 1
6 4 4 2 9

Function SortArrayOfArraysLexicoGraphically(data() As Byte) As Byte()
Dim lexicoGraphicalIndexes() As Byte

Dim dataSize As Long
dataSize = UBound(data) + 1
Dim squareRoot As Byte
sqaureRoot = Sqr(dataSize)
ReDim lexicoGraphicalIndexes(sqaureRoot - 1)

Dim j As Long
Dim i As Long
Dim isSorted As Boolean
isSorted = False

Do While Not isSorted
    isSorted = True
    j = 0
    For i = 0 To UBound(data) Step sqaureRoot 'This loops by columns down
        If i = (dataSize - sqaureRoot) Then 'last row
            Exit For
        End If
        
        'If first row, first byte > next row, first byte then
        If data(i) > data(i + sqaureRoot) Then
            lexicoGraphicalIndexes(j + 1) = j
            lexicoGraphicalIndexes(j) = j + 1
            i = i + sqaureRoot 'skip next one it's already sorted.
            j = j + 1
            isSorted = False
        ElseIf data(i) = data(i + sqaureRoot) Then
        
        Else
            lexicoGraphicalIndexes(j) = j
        End If
        j = j + 1
    Next i
Loop

'returns a byte array of sorted indexes.
SortArrayOfArraysLexicoGraphically = lexicoGraphicalIndexes
End Function

[Doogle]

Since the Array is not very large, you could try the loved and hated Swap Sort

Option Explicit

Dim myArray(3, 4) As Byte

Private Sub Command_Click()
Dim intI As Integer
Dim intJ As Integer
Dim intK As Integer
Dim boChange As Boolean
Dim bytTemp(4) As Byte
For intI = 4 To 0 Step -1
    Do
        boChange = False
        Do
            If myArray(intJ, intI) > myArray(intJ + 1, intI) Then
                For intK = 0 To 4
                    bytTemp(intK) = myArray(intJ, intK)
                Next intK
                For intK = 0 To 4
                    myArray(intJ, intK) = myArray(intJ + 1, intK)
                Next intK
                For intK = 0 To 4
                    myArray(intJ + 1, intK) = bytTemp(intK)
                Next intK
                boChange = True
            End If
            intJ = intJ + 1
        Loop Until intJ > UBound(myArray, 1) - 1
        intJ = 0
    Loop Until boChange = False
Next intI
For intI = 0 To 3
    For intJ = 0 To 4
        Debug.Print myArray(intI, intJ); " ";
    Next intJ
    Debug.Print
Next intI
End Sub

Private Sub Form_Load()
myArray(0, 0) = 6
myArray(0, 1) = 4
myArray(0, 2) = 4
myArray(0, 3) = 2
myArray(0, 4) = 9
myArray(1, 0) = 3
myArray(1, 1) = 1
myArray(1, 2) = 7
myArray(1, 3) = 4
myArray(1, 4) = 1
myArray(2, 0) = 3
myArray(2, 1) = 1
myArray(2, 2) = 7
myArray(2, 3) = 4
myArray(2, 4) = 2
myArray(3, 0) = 3
myArray(3, 1) = 3
myArray(3, 2) = 8
myArray(3, 3) = 3
myArray(3, 4) = 1
End Sub

[sspoke]

Wow Doogle thanks a bunch, you made it easier to see how it works with those multi-dimensional arrays. But I have to avoid multi-dimensional arrays since the data comes in as 1 byte array. But I fixed that problem. Here is the fixed code. Works pretty damn fast whats wrong with the traditional swap method why is it hated?.

Still one little problem I modify the data directly with this function which isn't really that bad I have to modify the data anyways but I have to keep track of the original row indexes before the data was modified.

The easy way to fix this only way I see is to make 2 copies of the data before function is executed keep original data and after function is executed in another array then compare both arrays by their rows/columns to see which match and the new indexes can be found like that.

But is there a way I could put in those indexes while its in the sorting process?
I look at it and it doesn't sort it right away the same rows can move around many times so I don't know how to generate the indexes from one run or atleast the the same as the main loop.

Here is what I got. which works so far.

Function SortArrayOfArraysLexicoGraphically(ByRef data() As Byte) As Byte()
Dim lexicoGraphicalIndexes() As Byte

Dim dataSize As Long
dataSize = UBound(data) + 1
Dim squareRootMinusOne As Byte
Dim squareRoot As Byte
squareRoot = Sqr(dataSize)
squareRootMinusOne = squareRoot - 1

ReDim lexicoGraphicalIndexes(squareRootMinusOne)

Dim columnStart As Integer
Dim row As Integer
Dim column As Integer
Dim boChange As Boolean
Dim bytTemp() As Byte
ReDim bytTemp(squareRoot)

'start column from the last element from the row and go backwards to first element in that row.
For columnStart = squareRootMinusOne To 0 Step -1
    Do
        boChange = False
        Do
             If data((row * squareRoot) + columnStart) > data(((row + 1) * squareRoot) + columnStart) Then
                'Copies row to temporary array
                For column = 0 To squareRootMinusOne
                    bytTemp(column) = data((row * squareRoot) + column)
                Next column
                'Copies the next row to current row
                For column = 0 To squareRootMinusOne
                    data((row * squareRoot) + column) = data(((row + 1) * squareRoot) + column)
                Next column
                'Replaces the next row with the temporary array (was current row)
                For column = 0 To squareRootMinusOne
                    data(((row + 1) * squareRoot) + column) = bytTemp(column)
                Next column
                boChange = True
            End If
            row = row + 1
        Loop Until row > squareRootMinusOne - 1
        row = 0
    Loop Until boChange = False
Next columnStart

'returns a byte array of sorted indexes.
SortArrayOfArraysLexicoGraphically = lexicoGraphicalIndexes
End Function

thanks again, I'll add to your reputation

[Doogle]

If you can manipulate the data easily, one method might be to add an extra item to each virtual row which represents the original Index.
eg 6 4 4 2 9 0 3 1 7 4 1 1 3 3 9 4 1 2 3 3 8 3 1 3 and exclude it from the sort.

So, in my original code, the initial intI For / Next loop would stay the same but the intK loops would go from 1 to 5 so the original index would 'hang on' the end of each virtual row. Other than that, as you say, the simplest way would be to hold a copy of the original sequence.

As for the pros and cons of a Swap Sort, it's just one of those things that some people love to hate; I personally don't have any issues with it for small amounts of data. I'm not a Computer Scientist so I don't have the luxury of having been taught 101 different ways to sort data efficiently (mind you there are some excellent examples in the Code Bank, although I don't remember seeing one that deals with multi dimensional arrays).

I was considering a different approach for your particular problem which would only be possible if the amount of data was 'really' small (a maximum of 9 numbers per virtual row) and the data didn't have leading zeros; which was to concatinate the numbers into Longs so you ended up with 4 numbers, sort them numerically and then 'split' the numbers back to individual bytes. Perhaps an extension of that idea would be to concatinate the numbers into strings, sort them and split them back again.

EDIT: An example using the "concatinate into a String" idea with an 'index' on the end.

Option Explicit
Private bytData() As Variant

Private Sub Command_Click()
Dim intSorted() As Integer
Dim intI As Integer
intSorted = LexoSort
For intI = 0 To UBound(intSorted)
    Debug.Print intSorted(intI); " ";
Next intI
Debug.Print
End Sub

Private Sub Form_Load()
bytData = Array(CByte(6), CByte(4), CByte(4), CByte(2), CByte(9), _
                CByte(3), CByte(1), CByte(7), CByte(4), CByte(1), _
                CByte(3), CByte(3), CByte(9), CByte(4), CByte(1), _
                CByte(3), CByte(3), CByte(8), CByte(3), CByte(1))
End Sub

Private Function LexoSort() As Integer()
Dim intLexo() As Integer
Dim strNumbers() As String
Dim strTemp As String
Dim strData As String
Dim intI As Integer
Dim intJ As Integer
Dim intCount As Integer
Dim boSwap As Boolean
ReDim strNumbers(UBound(bytData) \ 5)
For intI = 0 To UBound(bytData) Step 5
    For intJ = intI To intI + 4
        strNumbers(intCount) = strNumbers(intCount) & CStr(bytData(intJ))
    Next intJ
    strNumbers(intCount) = strNumbers(intCount) & CStr(intCount)
    intCount = intCount + 1
Next intI
Do
    intI = 0
    boSwap = False
    Do
        If Mid$(strNumbers(intI), 1, 5) > Mid$(strNumbers(intI + 1), 1, 5) Then
            strTemp = strNumbers(intI + 1)
            strNumbers(intI + 1) = strNumbers(intI)
            strNumbers(intI) = strTemp
            boSwap = True
        End If
        intI = intI + 1
    Loop Until intI = UBound(strNumbers)
Loop Until boSwap = False
ReDim intLexo(UBound(strNumbers))
For intI = 0 To UBound(strNumbers)
    intLexo(intI) = Val((Mid$(strNumbers(intI), 6)))
Next intI
LexoSort = intLexo()
End Function

[sspoke]

Ya I like the idea of adding a extra element to the data and ignoring it completely. The whole converting bytes to strings seems slow to me.. I will actually have rows which are as big as 256 elements so a total of 65536 bytes at time to sort. This function will be used alot sure I'll probably switch to C code when i'm finished. I remember the difficulties I had with speed when I didn't know about byte array's and did everything with strings. Although it does seem like you are using less loops with the string idea

Here is the final version that returns the indexes in a array as well.. was actually pretty simple just sort it with the backwards sort together it sorts the indexes the same as the real data.

Function SortArrayOfArraysLexicoGraphically(ByRef data() As Byte) As Byte()
Dim lexicoGraphicalIndexes() As Byte

Dim dataSize As Long
dataSize = UBound(data) + 1
Dim squareRootMinusOne As Byte
Dim squareRoot As Byte
squareRoot = Sqr(dataSize)
squareRootMinusOne = squareRoot - 1

ReDim lexicoGraphicalIndexes(squareRootMinusOne)

Dim columnStart As Long
Dim row As Long
Dim column As Long
Dim boChange As Boolean
Dim bytTemp() As Byte
ReDim bytTemp(squareRoot)
'data(i + SqaureRoot)

For columnStart = 0 To UBound(lexicoGraphicalIndexes)
    lexicoGraphicalIndexes(columnStart) = columnStart
Next columnStart

'start column from the last element from the row and go backwards to first element in that row.
For columnStart = squareRootMinusOne To 0 Step -1
    Do
        boChange = False
        Do
             If data((row * squareRoot) + columnStart) > data(((row + 1) * squareRoot) + columnStart) Then
                'Copies row to temporary array
                For column = 0 To squareRootMinusOne
                    bytTemp(column) = data((row * squareRoot) + column)
                Next column
                'Copies the next row to current row
                For column = 0 To squareRootMinusOne
                    data((row * squareRoot) + column) = data(((row + 1) * squareRoot) + column)
                Next column
                'Replaces the next row with the temporary array (was current row)
                For column = 0 To squareRootMinusOne
                    data(((row + 1) * squareRoot) + column) = bytTemp(column)
                Next column
                lexicoGraphicalIndexes = SwapBytes(lexicoGraphicalIndexes, row, row + 1)
                
                Dim i As Long
                Dim s As String
                s = ""
                For i = 0 To UBound(lexicoGraphicalIndexes)
                    s = s & lexicoGraphicalIndexes(i) & " "
                Next i
                Debug.Print s
                Debug.Print " "
                
                boChange = True
            End If
            row = row + 1
        Loop Until row > squareRootMinusOne - 1
        row = 0
    Loop Until boChange = False
Next columnStart

'returns a byte array of sorted indexes.
SortArrayOfArraysLexicoGraphically = lexicoGraphicalIndexes
End Function

Public Function SwapBytes(data() As Byte, firstIndex As Long, secondIndex As Long) As Byte()
    Dim tmpFirstByte As Byte
    tmpFirstByte = data(firstIndex) 
    data(firstIndex) = data(secondIndex)
    data(secondIndex) = tmpFirstByte
    SwapBytes = data
End Function

Code is EXTREMELY SLOW and I mean it takes 30 seconds just to iterate the main For loop once and if you run up to 256 bytes per block it can take up to 15 minutes.

This one below is still very SLOW but atleast a little better. Removes those 4 inner loops

Function SortArrayOfArraysLexicoGraphically(ByRef data() As Byte) As Byte()
Dim lexicoGraphicalIndexes() As Byte

Dim dataSize As Long
dataSize = UBound(data) + 1
Dim squareRootMinusOne As Integer
Dim squareRoot As Integer
squareRoot = Sqr(dataSize)
squareRootMinusOne = squareRoot - 1

ReDim lexicoGraphicalIndexes(squareRootMinusOne)

Dim columnStart As Long
Dim row As Long
Dim column As Long
Dim boChange As Boolean

For columnStart = 0 To UBound(lexicoGraphicalIndexes)
    lexicoGraphicalIndexes(columnStart) = columnStart
Next columnStart

'start column from the last element from the row and go backwards to first element in that row.
For columnStart = squareRootMinusOne To 0 Step -1
    Do
        boChange = False
        Do
             If data((row * squareRoot) + columnStart) > data(((row + 1) * squareRoot) + columnStart) Then
                
                'Swaps a full row byte by byte.
                For column = 0 To squareRootMinusOne
                    Call SwapBytes(data, (row * squareRoot) + column, ((row + 1) * squareRoot) + column)
                Next column
                Call SwapBytes(lexicoGraphicalIndexes, row, row + 1)
                boChange = True
            End If
            row = row + 1
        Loop Until row > squareRootMinusOne - 1
        row = 0
    Loop Until boChange = False
    DoEvents
    Debug.Print columnStart
Next columnStart

'returns a byte array of sorted indexes.
SortArrayOfArraysLexicoGraphically = lexicoGraphicalIndexes
End Function

Turns out the one above takes 30 minutes to run if the array is 256 x 256 in size. The one below uses CopyMemory and takes only 1 second for the whole process.

Function SortArrayOfArraysLexicoGraphically(ByRef data() As Byte) As Byte()

    Dim lexicoGraphicalIndexes() As Byte
    Dim dataSize As Long
    Dim squareRootMinusOne As Integer
    Dim squareRoot As Integer
    Dim columnStart As Long
    Dim row As Long
    Dim column As Long
    Dim rowSwapped As Boolean

    dataSize = UBound(data) + 1
    squareRoot = Sqr(dataSize)
    Dim tmpRow() As Byte
    ReDim tmpRow(squareRoot - 1)
    squareRootMinusOne = squareRoot - 1
    ReDim lexicoGraphicalIndexes(squareRootMinusOne)

    For columnStart = 0 To UBound(lexicoGraphicalIndexes)
        lexicoGraphicalIndexes(columnStart) = columnStart
    Next columnStart

    'start column from the last element from the row and go backwards to first element in that row.
    For columnStart = squareRootMinusOne To 0 Step -1
        Do
            rowSwapped = False
            Do
                If data((row * squareRoot) + columnStart) > data(((row + 1) * squareRoot) + columnStart) Then
                    'Swaps a full row in a few copies.
                    'Copies full row to tmpRow
                    CopyMemory tmpRow(0), ByVal VarPtr(data((row * squareRoot))), squareRoot
                    'Replace first row with second row.
                    CopyMemory data((row * squareRoot)), data(((row + 1) * squareRoot)), squareRoot
                    'Replace second row with tmpRow
                    CopyMemory data(((row + 1) * squareRoot)), ByVal VarPtr(tmpRow(0)), squareRoot

                    Call SwapBytes(lexicoGraphicalIndexes, row, row + 1)
                    rowSwapped = True
                End If
                row = row + 1
            Loop Until row > squareRootMinusOne - 1
            row = 0
        Loop Until rowSwapped = False
    Next columnStart

    'returns a byte array of sorted indexes.
    SortArrayOfArraysLexicoGraphically = lexicoGraphicalIndexes
End Function