Posts: 36
Threads: 10
Joined: Oct 2025
Reputation:
10
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
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
Posts: 4,713
Threads: 224
Joined: Apr 2022
Reputation:
322
What's with (time diff)/1.18???
You would get much better accuracy with Timer(.001)
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
timer1! = Timer
t1 = Timer(.001)
Print "Sorting..."; tn; "numbers": Print "Timer starts:"; timer1!
FiliSort n()
timer2! = Timer
t2 = Timer(.001)
Print "Timer ends:"; timer2!; " Seconds:"; (timer2! - timer1!) '/ 1.18
Print "Timer(.001) time is:"; (t2 - t1); "secs"
Print
'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
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 4,713
Threads: 224
Joined: Apr 2022
Reputation:
322
03-08-2026, 05:55 PM
(This post was last modified: 03-08-2026, 07:43 PM by bplus.)
here is 20,000 random numbers between -50 and 50 that took no time to sort!!!
Code: (Select All)
DefLng A-Z
Screen _NewImage(800, 700, 32)
tn = 20000 ' total numbers to sort
Dim Shared n(-5000000 To 5000000)
Randomize Timer
For i = 1 To tn: num = (Rnd * 100 - 50) * 100000: n(num) = n(num) + 1: Next i
timer1! = Timer
t1 = Timer(.001)
Print "Sorting..."; tn; "numbers": Print "Timer starts:"; timer1!
timer2! = Timer
t2 = Timer(.001)
Print "Timer ends:"; timer2!; " Seconds:"; (timer2! - timer1!) '/ 1.18
Print "Timer(.001) time is:"; (t2 - t1); "secs"
Print
Print "press any to see sorted numbers... zzz"
Sleep
For k = -5000000 To 5000000
If n(k) Then
For i = 1 To n(k)
Print k / 100000
Next
End If
Next k
End
Update: This is for entertainment purposes ONLY don't take this seriously (unless the method comes in handy  ).
Notice: No DATA has been corrupted in the making of this bit of entertainment. Please do not launch rockets or do brain surgery with this code!
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 36
Threads: 10
Joined: Oct 2025
Reputation:
10
Hi Bplus, I didn't know about the Timer(.001), that was nice.
The last code I suppose is a teasing to newbies... haha..
Posts: 3,453
Threads: 376
Joined: Apr 2022
Reputation:
346
(03-08-2026, 05:55 PM)bplus Wrote: here is 20,000 random numbers between -50 and 50 that took no time to sort!!!
..snip
Well yeah... Of course that took no time to sort, as it *did no sorting*. 
You created an array large enough to hold all the possible values of the numbers generated, then simply counted the numbers and placed it into that array at creation time. There's no sorting going on here and this uses 40MB of memory to hold 20,0000 bytes of data.
If that's what you consider an improvement, I'd hate to see what somebody considers something worse!! LOL!!
(-5,000,000 TO +5,000,000) <this is an array of 10,000,000 elements.
Each element is 4 bytes in size as it's simply Dim Shared n(-5000000 To 5000000) and you did a DEFLNG A-Z earlier, making everything LONG types.
So 10,000,000 elements * 4 bytes = 40,000,000 bytes to hold the data.
The data is only 20,000 numbers which are from -50 to 50, which can be stored in single bytes. So... 20,000 bytes of data.
That's ONLY 2000 times overhead involved in this process.
WHATTA KEEPER!!  
It's a good thing this didn't use DOUBLE precision to start with, or else we'd really see some impressive amounts of memory in work then with an array large enough to hold every value!
A second thought which I had with this process is I'm willing to bet YOU CORRUPTED YOUR DATA.
x = 1.23456
x * 100000 = 123456.654376474256356685 due to the imperfections of floating point math. This would round up in the counter to 123457 and your data would be corrupted.
I don't see how this is a reliable improvement in any form, once you start looking at how it actually works and performs without taking speed into consideration.
Posts: 3,453
Threads: 376
Joined: Apr 2022
Reputation:
346
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.
Posts: 4,713
Threads: 224
Joined: Apr 2022
Reputation:
322
(03-08-2026, 06:55 PM)SMcNeill Wrote: (03-08-2026, 05:55 PM)bplus Wrote: here is 20,000 random numbers between -50 and 50 that took no time to sort!!!
..snip
Well yeah... Of course that took no time to sort, as it *did no sorting*.
You created an array large enough to hold all the possible values of the numbers generated, then simply counted the numbers and placed it into that array at creation time. There's no sorting going on here and this uses 40MB of memory to hold 20,0000 bytes of data.
If that's what you consider an improvement, I'd hate to see what somebody considers something worse!! LOL!!
(-5,000,000 TO +5,000,000) <this is an array of 10,000,000 elements.
Each element is 4 bytes in size as it's simply Dim Shared n(-5000000 To 5000000) and you did a DEFLNG A-Z earlier, making everything LONG types.
So 10,000,000 elements * 4 bytes = 40,000,000 bytes to hold the data.
The data is only 20,000 numbers which are from -50 to 50, which can be stored in single bytes. So... 20,000 bytes of data.
That's ONLY 2000 times overhead involved in this process.
WHATTA KEEPER!!
It's a good thing this didn't use DOUBLE precision to start with, or else we'd really see some impressive amounts of memory in work then with an array large enough to hold every value!
A second thought which I had with this process is I'm willing to bet YOU CORRUPTED YOUR DATA.
x = 1.23456
x * 100000 = 123456.654376474256356685 due to the imperfections of floating point math. This would round up in the counter to 123457 and your data would be corrupted.
I don't see how this is a reliable improvement in any form, once you start looking at how it actually works and performs without taking speed into consideration.
Some people cant take a joke
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 799
Threads: 139
Joined: Apr 2022
Reputation:
33
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/
Posts: 3,453
Threads: 376
Joined: Apr 2022
Reputation:
346
@PhilOfPerth Variable length strings don't work with _MEM, so there's no easy way to use them with my MemSort routine. It'll work for all other base variable types, but can't handle variable length strings.
The only thing to do is:
1) You could make all your strings a fixed length and then it'd sort them. DIM array(10000) AS STRING * 20 <-- for example
2) Use a different sort routine to handle the variable length strings. For my personal use, I tend to package and use a combSort routine for most things. It's fast enough to handle anything I usually toss at it, it's non-recursive so there's no chance of blowing the stack, and it's simple enough for me to understand and alter if I ever need to change something with it.
If you want, I can share the routine I usually use for you. I'm certain it's here on the forums, and probably attached to a dozen different programs and examples from the years, but I'm too lazy and it's too late at night right now to hunt for them. If you want it, let me know, and I'll hunt it down once I get over this daylight swap jetlag which seems to be killing my energy levels.
Posts: 799
Threads: 139
Joined: Apr 2022
Reputation:
33
03-10-2026, 10:17 PM
(This post was last modified: 03-10-2026, 10:27 PM by PhilOfPerth.)
(03-10-2026, 09:21 AM)SMcNeill Wrote: @PhilOfPerth Variable length strings don't work with _MEM, so there's no easy way to use them with my MemSort routine. It'll work for all other base variable types, but can't handle variable length strings.
The only thing to do is:
1) You could make all your strings a fixed length and then it'd sort them. DIM array(10000) AS STRING * 20 <-- for example
2) Use a different sort routine to handle the variable length strings. For my personal use, I tend to package and use a combSort routine for most things. It's fast enough to handle anything I usually toss at it, it's non-recursive so there's no chance of blowing the stack, and it's simple enough for me to understand and alter if I ever need to change something with it.
If you want, I can share the routine I usually use for you. I'm certain it's here on the forums, and probably attached to a dozen different programs and examples from the years, but I'm too lazy and it's too late at night right now to hunt for them. If you want it, let me know, and I'll hunt it down once I get over this daylight swap jetlag which seems to be killing my energy levels. Thanks Steve, much appreciated.
I'll look for that CombSort, and give it a try, but may continue with my effort at converting the string to an integer as well. It would be nice to "invent" something - even a buckled wheel!
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/
|
