03-08-2026, 07:06 PM
I gives you (once again) Steve's Amazing MemSort routine, which I've been giving folks since forever ago...
0.009 seconds to sort on my machine (Which may not be as impressive on 2112's computer as even his original routine only takes about 1 second on my laptop to run.)
That's mighty dang close to "no time at all", and it doesn't come with a 40MB overhead, nor does it have any chance of corrupting the original data. It's more than fast enough for *MY* personal needs, and since the routine has already been written and I can plug it in anything with just a copy/paste, it's the best sort routine for my regular use.
Code: (Select All)
' FiliSort v1.0
' This a very simple sorting method, a lot faster than Bubblesort
' For 50000 numbers in my pc, it takes 16.43 sec
' while the Bubble Sort takes 29.18 sec
Screen _NewImage(800, 700, 32)
Dim Shared tn As Long
tn = 20000 ' total numbers to sort
Dim Shared n(tn) As Single
Randomize Timer
For i = 1 To tn: n(i) = Rnd * 100 - 50: Next i
t# = Timer(0.001)
Print "Sorting..."; tn; "numbers": Print "Timer starts:"; t#
Dim m As _MEM
m = _Mem(n())
Sort m
t2# = Timer(0.001)
Print "Timer ends:"; t2#
Print Using "###.### Seconds:"; (t2# - t#)
timer1! = Timer
Print "Sorting..."; tn; "numbers": Print "Timer starts:"; timer1!
FiliSort n()
timer2! = Timer
Print "Timer ends:"; timer2!; " Seconds:"; (timer2! - timer1!) / 1.18
'For k = 1 To tn: Print n(k): Next k
End
Sub FiliSort (n())
For k = 1 To tn / 2
min = n(k): max = n(tn - k + 1)
imin = 0: imax = 0
For i = k To tn - k
If min > n(i + 1) Then min = n(i + 1): imin = i + 1 'find the minimum of the numbers
If max <= n(i) Then max = n(i): imax = i 'find the maximum of the numbers
Next i
If imin > 0 Then n(imin) = n(k): n(k) = min
If imax = k Then imax = imin
If imax > 0 Then n(imax) = n(tn - k + 1): n(tn - k + 1) = max
Next k
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
0.009 seconds to sort on my machine (Which may not be as impressive on 2112's computer as even his original routine only takes about 1 second on my laptop to run.)
That's mighty dang close to "no time at all", and it doesn't come with a 40MB overhead, nor does it have any chance of corrupting the original data. It's more than fast enough for *MY* personal needs, and since the routine has already been written and I can plug it in anything with just a copy/paste, it's the best sort routine for my regular use.