03-10-2026, 08:19 AM
(This post was last modified: 03-10-2026, 08:32 AM by PhilOfPerth.)
(03-08-2026, 07:06 PM)SMcNeill Wrote: I gives you (once again) Steve's Amazing MemSort routine, which I've been giving folks since forever ago...
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.
@ Steve I've been experimenting a bit with your " Amazing MemSort routine ", and would like to adapt it for use in some of my progs.
Most of it is above my level of comprehension, but I noticed one of the "types" it recognize is String. I was not able to find a way to sort these. I've tried
converting the string characters to their Asc value, but no joy. I suspect there's a simple way built in somewhere but I can't find it. Is there one?
I've abbreviated the Main section to this:
Screen _NewImage(800, 700, 32)
Dim Shared Items As Long
Input "How many items"; Items
Dim Shared n(Items) As Single
For i = 1 To Items: Input n(i): Next i
Print "Sorting..."; Items; "items"
Dim m As _MEM
m = _Mem(n())
Sort m
For i = 1 To Items: Print n(i): Next
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, Western Australia.) 
Please visit my Website at: http://oldendayskids.blogspot.com/
Please visit my Website at: http://oldendayskids.blogspot.com/