Need a sorting routine

[TerryRitchie]

@TerryRitchie A working example for you:

Code: (Select All)

Screen _NewImage(800, 600, 32)

Type DATATYPE
    a As Integer
    b As Integer
    c As Integer
End Type

Const Limit = 1000000 'one million defalt limit

ReDim SortedList(1 To Limit) As DATATYPE

For i = 1 To Limit
    SortedList(i).a = Int(Rnd * 32767) + 1
    SortedList(i).b = Int(Rnd * 32767) + 1
    SortedList(i).c = Int(Rnd * 32767) + 1
Next

For i = 1 To 30
    Print SortedList(i).a, SortedList(i).b, SortedList(i).c
Next
Sleep

FakeSort SortedList()
Print
Print "=== Sorted ==="
Print
For i = 1 To 30
    Print SortedList(i).a, SortedList(i).b, SortedList(i).c
Next


Sub FakeSort (Array() As DATATYPE)
    Dim S(1 To 32767) As String
    Dim TempArray(1 To Limit) As DATATYPE
    For i = 1 To Limit 'build the sorted index in a single pass
        S(Array(i).a) = S(Array(i).a) + MKL$(i)
    Next

    Count = 0
    For i = 1 To 32767
        For J = 1 To Len(S(i)) Step 4 'we stored our index as long values
            Count = Count + 1
            t$ = Mid$(S(i), J, 4)
            index = CVL(t$)
            TempArray(Count) = Array(index)
        Next
    Next

    For i = 1 To Limit
        Array(i) = TempArray(i)
    Next
End Sub

This is a very interesting approach. When I set the limit to 32767 I get speeds on average of .040 seconds which, while blazingly fast, unfortunately is still ~4 times slower than the Qsort routine mdijkens posted at .012 seconds for 32767 indexes.

[SMcNeill]

Part of the bottleneck for my routine comes from converting to string to store the index and then reading it back.  (But, it's a working example of using an array inside an array, which everyone has been talking about for the past month in the other post...)  If we didn't have to worry about tracking the other 2 elements in your custom type, all we'd have to do is count the values instead of storing them and there wouldn't be any type of string conversion involved in the process.  As it is, QB64's string overhead is slowing us down to the point where Qsort is faster this time around. 

[TerryRitchie]

Part of the bottleneck for my routine comes from converting to string to store the index and then reading it back.  (But, it's a working example of using an array inside an array, which everyone has been talking about for the past month in the other post...)  If we didn't have to worry about tracking the other 2 elements in your custom type, all we'd have to do is count the values instead of storing them and there wouldn't be any type of string conversion involved in the process.  As it is, QB64's string overhead is slowing us down to the point where Qsort is faster this time around. 

It's still a fascinating sorting routine and one that is easy to understand and use where speed isn't so crucial. My understanding of sorting never evolved beyond the good old bubble sort so seeing these other methods of sorting like yours is a real eye opener.

[SMcNeill]

It's still a fascinating sorting routine and one that is easy to understand and use where speed isn't so crucial. My understanding of sorting never evolved beyond the good old bubble sort so seeing these other methods of sorting like yours is a real eye opener.

Note that if you use this method properly, it's going to end up being quite a bit faster than Qsort in many situations.  The bottleneck above, is as I mentioned -- QB64's string routines are relatively slow by nature.  Here's a nice example for you, which just uses a plain array of integer values to sort:

Code: (Select All)

Screen _NewImage(800, 600, 32)
Const limit = 1000000
Dim Shared SortedList(1 To limit) As Integer
Dim Shared SortedList2(1 To limit) As Integer
Dim m As _MEM
m = _Mem(SortedList2())



For i = 1 To limit
    SortedList(i) = Rnd * 32000
    SortedList2(i) = SortedList(i) 'a copy for exact results on the second sort
Next
DisplayList

Sleep

t## = Timer
QSort 1, limit
t1## = Timer
DisplayList
Sleep


t2## = Timer
Sort m
t3## = Timer
DisplayList2

Print
Print "For "; limit; "elements:"
Print Using "###.##### seconds to Qsort"; t1## - t##
Print Using "###.##### seconds to MemSort"; t3## - t2##

Sub DisplayList
    Print
    For i = 1 To 100
        Print SortedList(i),
    Next
    Print
End Sub

Sub DisplayList2
    Print
    For i = 1 To 100
        Print SortedList2(i),
    Next
    Print
End Sub




Sub QSort (leftN As Long, rightN As Long)
    Dim pivot As Long, leftNIdx As Long, rightNIdx As Long
    leftNIdx = leftN
    rightNIdx = rightN
    If (rightN - leftN) > 0 Then
        pivot = (leftN + rightN) / 2
        While (leftNIdx <= pivot) And (rightNIdx >= pivot)
            While SortedList(leftNIdx) < SortedList(pivot) And (leftNIdx <= pivot)
                leftNIdx = leftNIdx + 1
            Wend
            While SortedList(rightNIdx) > SortedList(pivot) And (rightNIdx >= pivot)
                rightNIdx = rightNIdx - 1
            Wend
            Swap SortedList(leftNIdx), SortedList(rightNIdx)
            leftNIdx = leftNIdx + 1
            rightNIdx = rightNIdx - 1
            If (leftNIdx - 1) = pivot Then
                rightNIdx = rightNIdx + 1
                pivot = rightNIdx
            ElseIf (rightNIdx + 1) = pivot Then
                leftNIdx = leftNIdx - 1
                pivot = leftNIdx
            End If
        Wend
        QSort leftN, pivot - 1
        QSort pivot + 1, rightN
    End If

End Sub



Sub Sort (m As _MEM)
    Dim i As _Unsigned Long
    $If 64BIT Then
        Dim ES As _Integer64, EC As _Integer64
    $Else
            DIM ES AS LONG, EC AS LONG
    $End If

    If Not m.TYPE And 65536 Then Exit Sub 'We won't work without an array
    If m.TYPE And 1024 Then DataType = 10
    If m.TYPE And 1 Then DataType = DataType + 1
    If m.TYPE And 2 Then DataType = DataType + 2
    If m.TYPE And 4 Then If m.TYPE And 128 Then DataType = DataType + 4 Else DataType = 3
    If m.TYPE And 8 Then If m.TYPE And 128 Then DataType = DataType + 8 Else DataType = 5
    If m.TYPE And 32 Then DataType = 6
    If m.TYPE And 512 Then DataType = 7

    'Convert our offset data over to something we can work with
    Dim m1 As _MEM: m1 = _MemNew(Len(ES))
    _MemPut m1, m1.OFFSET, m.ELEMENTSIZE: _MemGet m1, m1.OFFSET, ES 'Element Size
    _MemPut m1, m1.OFFSET, m.SIZE: _MemGet m1, m1.OFFSET, EC 'Element Count will temporily hold the WHOLE array size
    _MemFree m1

    EC = EC / ES - 1 'Now we take the whole element size / the size of the elements and get our actual element count.  We subtract 1 so our arrays start at 0 and not 1.
    'And work with it!
    Dim o As _Offset, o1 As _Offset, counter As _Unsigned Long

    Select Case DataType
        Case 1 'BYTE
            Dim temp1(-128 To 127) As _Unsigned Long
            Dim t1 As _Byte
            i = 0
            Do
                _MemGet m, m.OFFSET + i, t1
                temp1(t1) = temp1(t1) + 1
                i = i + 1
            Loop Until i > EC
            i1 = -128
            Do
                Do Until temp1(i1) = 0
                    _MemPut m, m.OFFSET + counter, i1 As _BYTE
                    counter = counter + 1
                    temp1(i1) = temp1(i1) - 1
                    If counter > EC Then Exit Sub
                Loop
                i1 = i1 + 1
            Loop Until i1 > 127
        Case 2: 'INTEGER
            Dim temp2(-32768 To 32767) As _Unsigned Long
            Dim t2 As Integer
            i = 0
            Do
                _MemGet m, m.OFFSET + i * 2, t2
                temp2(t2) = temp2(t2) + 1
                i = i + 1
            Loop Until i > EC
            i1 = -32768
            Do
                Do Until temp2(i1) = 0
                    _MemPut m, m.OFFSET + counter * 2, i1 As INTEGER
                    counter = counter + 1
                    temp2(i1) = temp2(i1) - 1
                    If counter > EC Then Exit Sub
                Loop
                i1 = i1 + 1
            Loop Until i1 > 32767
        Case 3 'SINGLE
            Dim T3a As Single, T3b As Single
            gap = EC
            Do
                gap = 10 * gap \ 13
                If gap < 1 Then gap = 1
                i = 0
                swapped = 0
                Do
                    o = m.OFFSET + i * 4
                    o1 = m.OFFSET + (i + gap) * 4
                    If _MemGet(m, o, Single) > _MemGet(m, o1, Single) Then
                        _MemGet m, o1, T3a
                        _MemGet m, o, T3b
                        _MemPut m, o1, T3b
                        _MemPut m, o, T3a
                        swapped = -1
                    End If
                    i = i + 1
                Loop Until i + gap > EC
            Loop Until gap = 1 And swapped = 0
        Case 4 'LONG
            Dim T4a As Long, T4b As Long
            gap = EC
            Do
                gap = 10 * gap \ 13
                If gap < 1 Then gap = 1
                i = 0
                swapped = 0
                Do
                    o = m.OFFSET + i * 4
                    o1 = m.OFFSET + (i + gap) * 4
                    If _MemGet(m, o, Long) > _MemGet(m, o1, Long) Then
                        _MemGet m, o1, T4a
                        _MemGet m, o, T4b
                        _MemPut m, o1, T4b
                        _MemPut m, o, T4a
                        swapped = -1
                    End If
                    i = i + 1
                Loop Until i + gap > EC
            Loop Until gap = 1 And swapped = 0
        Case 5 'DOUBLE
            Dim T5a As Double, T5b As Double
            gap = EC
            Do
                gap = 10 * gap \ 13
                If gap < 1 Then gap = 1
                i = 0
                swapped = 0
                Do
                    o = m.OFFSET + i * 8
                    o1 = m.OFFSET + (i + gap) * 8
                    If _MemGet(m, o, Double) > _MemGet(m, o1, Double) Then
                        _MemGet m, o1, T5a
                        _MemGet m, o, T5b
                        _MemPut m, o1, T5b
                        _MemPut m, o, T5a
                        swapped = -1
                    End If
                    i = i + 1
                Loop Until i + gap > EC
            Loop Until gap = 1 And swapped = 0
        Case 6 ' _FLOAT
            Dim T6a As _Float, T6b As _Float
            gap = EC
            Do
                gap = 10 * gap \ 13
                If gap < 1 Then gap = 1
                i = 0
                swapped = 0
                Do
                    o = m.OFFSET + i * 32
                    o1 = m.OFFSET + (i + gap) * 32
                    If _MemGet(m, o, _Float) > _MemGet(m, o1, _Float) Then
                        _MemGet m, o1, T6a
                        _MemGet m, o, T6b
                        _MemPut m, o1, T6b
                        _MemPut m, o, T6a
                        swapped = -1
                    End If
                    i = i + 1
                Loop Until i + gap > EC
            Loop Until gap = 1 And swapped = 0
        Case 7 'String
            Dim T7a As String, T7b As String, T7c As String
            T7a = Space$(ES): T7b = Space$(ES): T7c = Space$(ES)
            gap = EC
            Do
                gap = Int(gap / 1.247330950103979)
                If gap < 1 Then gap = 1
                i = 0
                swapped = 0
                Do
                    o = m.OFFSET + i * ES
                    o1 = m.OFFSET + (i + gap) * ES
                    _MemGet m, o, T7a
                    _MemGet m, o1, T7b
                    If T7a > T7b Then
                        T7c = T7b
                        _MemPut m, o1, T7a
                        _MemPut m, o, T7c
                        swapped = -1
                    End If
                    i = i + 1
                Loop Until i + gap > EC
            Loop Until gap = 1 And swapped = false
        Case 8 '_INTEGER64
            Dim T8a As _Integer64, T8b As _Integer64
            gap = EC
            Do
                gap = 10 * gap \ 13
                If gap < 1 Then gap = 1
                i = 0
                swapped = 0
                Do
                    o = m.OFFSET + i * 8
                    o1 = m.OFFSET + (i + gap) * 8
                    If _MemGet(m, o, _Integer64) > _MemGet(m, o1, _Integer64) Then
                        _MemGet m, o1, T8a
                        _MemGet m, o, T8b
                        _MemPut m, o1, T8b
                        _MemPut m, o, T8a
                        swapped = -1
                    End If
                    i = i + 1
                Loop Until i + gap > EC
            Loop Until gap = 1 And swapped = 0
        Case 11: '_UNSIGNED _BYTE
            Dim temp11(0 To 255) As _Unsigned Long
            Dim t11 As _Unsigned _Byte
            i = 0
            Do
                _MemGet m, m.OFFSET + i, t11
                temp11(t11) = temp11(t11) + 1
                i = i + 1
            Loop Until i > EC
            i1 = 0
            Do
                Do Until temp11(i1) = 0
                    _MemPut m, m.OFFSET + counter, i1 As _UNSIGNED _BYTE
                    counter = counter + 1
                    temp11(i1) = temp11(i1) - 1
                    If counter > EC Then Exit Sub
                Loop
                i1 = i1 + 1
            Loop Until i1 > 255
        Case 12 '_UNSIGNED INTEGER
            Dim temp12(0 To 65535) As _Unsigned Long
            Dim t12 As _Unsigned Integer
            i = 0
            Do
                _MemGet m, m.OFFSET + i * 2, t12
                temp12(t12) = temp12(t12) + 1
                i = i + 1
            Loop Until i > EC
            i1 = 0
            Do
                Do Until temp12(i1) = 0
                    _MemPut m, m.OFFSET + counter * 2, i1 As _UNSIGNED INTEGER
                    counter = counter + 1
                    temp12(i1) = temp12(i1) - 1
                    If counter > EC Then Exit Sub
                Loop
                i1 = i1 + 1
            Loop Until i1 > 65535
        Case 14 '_UNSIGNED LONG
            Dim T14a As _Unsigned Long, T14b As _Unsigned Long
            gap = EC
            Do
                gap = 10 * gap \ 13
                If gap < 1 Then gap = 1
                i = 0
                swapped = 0
                Do
                    o = m.OFFSET + i * 4
                    o1 = m.OFFSET + (i + gap) * 4
                    If _MemGet(m, o, _Unsigned Long) > _MemGet(m, o1, _Unsigned Long) Then
                        _MemGet m, o1, T14a
                        _MemGet m, o, T14b
                        _MemPut m, o1, T14b
                        _MemPut m, o, T14a
                        swapped = -1
                    End If
                    i = i + 1
                Loop Until i + gap > EC
            Loop Until gap = 1 And swapped = 0
        Case 18: '_UNSIGNED _INTEGER64
            Dim T18a As _Unsigned _Integer64, T18b As _Unsigned _Integer64
            gap = EC
            Do
                gap = 10 * gap \ 13
                If gap < 1 Then gap = 1
                i = 0
                swapped = 0
                Do
                    o = m.OFFSET + i * 8
                    o1 = m.OFFSET + (i + gap) * 8
                    If _MemGet(m, o, _Unsigned _Integer64) > _MemGet(m, o1, _Unsigned _Integer64) Then
                        _MemGet m, o1, T18a
                        _MemGet m, o, T18b
                        _MemPut m, o1, T18b
                        _MemPut m, o, T18a
                        swapped = -1
                    End If
                    i = i + 1
                Loop Until i + gap > EC
            Loop Until gap = 1 And swapped = 0
    End Select
End Sub

Not all sorts are created equal for every job.  Some will truly shine in various situations, and so far I've found *nothing* that beats a simple counting process for raw speed, when it can implemented directly like in the above. 

[Dimster]

Hi Terry
Not sure if this has already been covered in Steve's string approach but thought I'd throw this out there,  the method I use to sort multiple variable values is to convert the values to string values with the primary sort value as a whole number (ie A$ = "125") and the secondary sort values as decimal values (ie B$ = ".867", C$ = ".379), when you combine this string (D$ = A$ + B$ + C$ ) you get 125.867.379 without the decimals you get 125867379 which is a little harder to see the secondary values in the sort. Helps me see accuracy better and I do tend for accuracy over speed in my sorts.

[TempodiBasic]

Hi Terry
did you speak of bubble sort?

please give a look at this thread
seven bubble sort routines

[TempodiBasic]

@SMcNeill

Hey Steve your MemSort is Fast and Furious....
remember to respect the speed limit in the city!