Page 1 of 1
Flashsort
Posted: Sun May 01, 2005 12:05 pm
by akj
Code updated for 5.20+
I found this incredibly quick sorting algorithm called FlashSort on a website recently and I thought I would let you know about it.
It's sort speed is linear i.e. O(n) where n is the number of items being sorted.
Classical high-speed sort methods like QuickSort and HeapSort have a typical speed of O(n*log(n)) which is far slower for large n.
The following PureBasic implementation will sort a million integers in about one second.
It was adapted from code on the website - which explains the strange choice of variable names. I have corrected a couple of bugs which caused incorrect sorting, especially when the number of items to be sorted was very small.
Code: Select all
; Flashsort AKJ 01-May-05
; Downloaded: www.neubert.net/Flacodes/FLACodes.html#Sprung2
; Introduction: www.neubert.net/FSOIntro.html
; FlashSort sorts the n elements of array A() in O(n) [i.e. linear] time.
; It uses an additional array L() of size n/8 as a first step in the
; classification of the elements of array A().
Declare RANDOMS()
Declare DISPLAY()
Declare FLASHSORT()
Global N
OpenConsole()
Print("How many numbers to be sorted? ")
N=Val(Input())
PrintN("")
Global Dim A(N) ; The integer array to be sorted
PrintN("Generating "+Str(N)+" random integers ...")
PrintN("")
RANDOMS()
DISPLAY()
PrintN("")
PrintN("Sorting ...")
t0=ElapsedMilliseconds()
M=FLASHSORT() ; Returns the number of classes
; Format the elapsed time
msecs$=Str(ElapsedMilliseconds()-t0)
secs$=Left(msecs$,Len(msecs$)-3)+"."+Right("00"+msecs$,3)
; Display summary
Print(Str(N)+" Integers sorted")
Print(" in "+secs$+" seconds")
Print(" using "+Str(M)+" class")
If M>1: PrintN("es"): Else: PrintN(""): EndIf
PrintN("")
DISPLAY()
PrintN("")
Print("Press ENTER ... ")
Input()
CloseConsole()
End
Procedure RANDOMS()
RandomSeed(ElapsedMilliseconds())
For I=1 To N
A(I) = Random(10000)
Next I
EndProcedure
Procedure DISPLAY()
count=16
If count>N
PrintN("All "+Str(N)+" numbers:")
For I = 1 To N
Print(Str(A(I))+" ")
Next I
Else
PrintN("First "+Str(count)+" numbers:")
For I = 1 To count
Print(Str(A(I))+" ")
Next I
PrintN("")
PrintN("Last "+Str(count)+" numbers:")
For I = N - count+1 To N
Print(Str(A(I))+" ")
Next I
EndIf
PrintN("")
EndProcedure
Procedure FLASHSORT() ; Integer version
; Sorts an integer array A(), using a much smaller index array L()
; This is a translation of Karl-Dietrich Neubert's FlashSort algorithm
; It was first published in Dr. Dobb's Journal, February 1998
; CLASS FORMATION
M = N/8
If M<1: M=1: EndIf ; Bug fix by AKJ
Dim L(M)
ANMIN = A(1)
NMAX = 1
For I=1 To N
If A(I)<ANMIN: ANMIN = A(I): EndIf
If A(I)>A(NMAX): NMAX = I: EndIf
Next I
If ANMIN=A(NMAX): ProcedureReturn M: EndIf
C1.f = (M - 1)/(A(NMAX)-ANMIN)
For K=1 To M
L(K) = 0
Next K
For I=1 To N
K = 1 + Int(C1*(A(I)-ANMIN))
L(K) + 1
Next I
For K=2 To M
L(K) + L(K-1)
Next K
HOLD = A(NMAX)
A(NMAX) = A(1)
A(1) = HOLD
; PERMUTATION
NMOVE = 0
J = 1
K = M
While NMOVE<N-1
While J>L(K)
J + 1
K = 1 + Int(C1*(A(J)-ANMIN))
Wend
FLASH = A(J)
While J<>L(K) + 1
K = 1 + Int(C1*(FLASH-ANMIN))
HOLD = A(L(K))
A(L(K)) = FLASH
FLASH = HOLD
L(K) - 1
NMOVE + 1
Wend
Wend
Dim L(0) ; Free memory
; STRAIGHT INSERTION
For I = N-2 To 1 Step -1
If A(I)>A(I + 1)
HOLD = A(I)
J = I
While A(J+1)<HOLD
A(J) = A(J+1)
J + 1
If J=N: Break: EndIf ; Bug fix by AKJ
Wend
A(J) = HOLD
EndIf
Next I
ProcedureReturn M
EndProcedure
Posted: Sun May 01, 2005 1:12 pm
by thefool
seems to work ok for low numbers.. But:
okay tried to sort nearly a million
999999
result:
Posted: Sun May 01, 2005 1:26 pm
by Rescator
*laughs*
Just change line 52 from
A(I) = Random(10000)
to
A(I) = Random(n)
Posted: Sun May 01, 2005 1:42 pm
by thefool
heh but at least its not my fault
didnt have time to look it through
edit: This sort is pretty fast! good one.
Re: Flashsort
Posted: Sun May 01, 2005 9:23 pm
by NoahPhense
Very nice akj ..
- np
Posted: Mon May 02, 2005 6:43 pm
by Fred
Don't tell me we will have to change the PB sort routines once more !
Posted: Mon May 02, 2005 8:22 pm
by Num3
Fred wrote:Don't tell me we will have to change the PB sort routines once more !
Ok... No one will tell you ....
Posted: Mon May 02, 2005 10:11 pm
by freedimension
Fred wrote:Don't tell me we will have to change the PB sort routines once more !
Is this sort algorithm stable like the current one?
Posted: Tue May 03, 2005 1:08 am
by NoahPhense
freedimension wrote:Fred wrote:Don't tell me we will have to change the PB sort routines once more !
Is this sort algorithm stable like the current one?
I don't know but it's pretty damn fast ..
- np
Posted: Thu May 05, 2005 2:29 pm
by horst
NoahPhense wrote:freedimension wrote:Fred wrote:Don't tell me we will have to change the PB sort routines once more !
Is this sort algorithm stable like the current one?
I don't know but it's pretty damn fast ..
- np
I dunno, but on my old 533Mhz Win98 the PB sort is amost twice as fast:
1.3 sec (PB) vs. 2.2 sec (Flash).
Anything wrong with the PB sort (PB3.93) ???
Posted: Thu May 05, 2005 2:43 pm
by zikitrake
horst wrote:
I dunno, but on my old 533Mhz Win98 the PB sort is amost twice as fast:
1.3 sec (PB) vs. 2.2 sec (Flash).
Anything wrong with the PB sort (PB3.93) ???
Using 9999999 numbers (PIII 2.0 Ghz, WinXP pro, 512 RAM):
- With FLASHSORT() ---> 11.343 seconds
- With PB SortArray(A(), 0) -> 3.922 seconds
Posted: Thu May 05, 2005 2:56 pm
by Comtois
Yes
Using 9999999 numbers (P IV 2,6 GHz)
With FlashSort --> 4,469
With SortArray --> 1,891
Code: Select all
; Flashsort AKJ 01-May-05
; Downloaded: www.neubert.net/Flacodes/FLACodes.html#Sprung2
; Introduction: www.neubert.net/FSOIntro.html
; FlashSort sorts the n elements of array A() in O(n) [i.e. linear] time.
; It uses an additional array L() of size n/8 as a first step in the
; classification of the elements of array A().
Declare RANDOMS()
Declare DISPLAY()
Declare DISPLAYCopy()
Declare FLASHSORT()
Global n
OpenConsole()
Print("How many numbers to be sorted? ")
n=Val(Input())
PrintN("")
Dim A(n) ; The integer array to be sorted by FlashSort
Dim CopyA(n) ; The integer array to be sorted by SortArray
PrintN("Generating "+Str(n)+" random integers ...")
PrintN("")
RANDOMS()
DISPLAY()
PrintN("")
PrintN("Sorting With FLASHSORT...")
t0=ElapsedMilliseconds()
M=FLASHSORT() ; Returns the number of classes
; Format the elapsed time
msecs$=Str(ElapsedMilliseconds()-t0)
secs$=Left(msecs$,Len(msecs$)-3)+"."+Right("00"+msecs$,3)
PrintN("Sorting With ARRAYSORT...")
t1=ElapsedMilliseconds() ; <
SortArray(CopyA(),0) ; <
msecs1$=Str(ElapsedMilliseconds()-t1) ; <
secs1$=Left(msecs1$,Len(msecs1$)-3)+"."+Right("00"+msecs1$,3) ; <
; Display summary
Print(Str(n)+" Integers sorted with FlashSort")
Print(" in "+secs$+" seconds")
Print(" using "+Str(M)+" class")
If M>1: PrintN("es"): Else: PrintN(""): EndIf
PrintN("")
DISPLAY()
PrintN("")
PrintN("")
;SortArray
Print(Str(n)+" Integers sorted with SortArray")
Print(" in "+secs1$+" seconds")
PrintN("")
DISPLAYCopy()
PrintN("")
Print("Press ENTER ... ")
Input()
CloseConsole()
End
Procedure RANDOMS()
RandomSeed(ElapsedMilliseconds())
For i=1 To n
A(i) = Random(10000)
CopyA(i) = A(i) ;<
Next i
EndProcedure
Procedure DISPLAY()
count=16
If count>n
PrintN("All "+Str(n)+" numbers:")
For i = 1 To n
Print(Str(A(i))+" ")
Next i
Else
PrintN("First "+Str(count)+" numbers:")
For i = 1 To count
Print(Str(A(i))+" ")
Next i
PrintN("")
PrintN("Last "+Str(count)+" numbers:")
For i = n - count+1 To n
Print(Str(A(i))+" ")
Next i
EndIf
PrintN("")
EndProcedure
Procedure DISPLAYCopy()
count=16
If count>n
PrintN("All "+Str(n)+" numbers:")
For i = 1 To n
Print(Str(CopyA(i))+" ")
Next i
Else
PrintN("First "+Str(count)+" numbers:")
For i = 1 To count
Print(Str(CopyA(i))+" ")
Next i
PrintN("")
PrintN("Last "+Str(count)+" numbers:")
For i = n - count+1 To n
Print(Str(CopyA(i))+" ")
Next i
EndIf
PrintN("")
EndProcedure
Procedure.l FLASHSORT() ; Integer version
; Sorts an integer array A(), using a much smaller index array L()
; This is a translation of Karl-Dietrich Neubert's FlashSort algorithm
; It was first published in Dr. Dobb's Journal, February 1998
; CLASS FORMATION
M = n/8
If M<1: M=1: EndIf ; Bug fix by AKJ
Dim L(M)
ANMIN = A(1)
NMAX = 1
For i=1 To n
If A(i)<ANMIN: ANMIN = A(i): EndIf
If A(i)>A(NMAX): NMAX = i: EndIf
Next i
If ANMIN=A(NMAX): ProcedureReturn M: EndIf
C1.f = (M - 1)/(A(NMAX)-ANMIN)
For K=1 To M
L(K) = 0
Next K
For i=1 To n
K = 1 + Int(C1*(A(i)-ANMIN))
L(K) + 1
Next i
For K=2 To M
L(K) + L(K-1)
Next K
HOLD = A(NMAX)
A(NMAX) = A(1)
A(1) = HOLD
; PERMUTATION
NMOVE = 0
J = 1
K = M
While NMOVE<n-1
While J>L(K)
J + 1
K = 1 + Int(C1*(A(J)-ANMIN))
Wend
FLASH = A(J)
While J<>L(K) + 1
K = 1 + Int(C1*(FLASH-ANMIN))
HOLD = A(L(K))
A(L(K)) = FLASH
FLASH = HOLD
L(K) - 1
NMOVE + 1
Wend
Wend
Dim L(0) ; Free memory
; STRAIGHT INSERTION
For i = n-2 To 1 Step -1
If A(i)>A(i + 1)
HOLD = A(i)
J = i
While A(J+1)<HOLD
A(J) = A(J+1)
J + 1
If J=n: Break: EndIf ; Bug fix by AKJ
Wend
A(J) = HOLD
EndIf
Next i
ProcedureReturn M
EndProcedure
Posted: Thu May 05, 2005 3:23 pm
by MrMat
@Comtois: Shouldn't the line
Code: Select all
msecs$=Str(ElapsedMilliseconds()-t0)
be
?
I still get SortArray to be faster but maybe if FlashSort was optimised in asm it might do better.
Posted: Thu May 05, 2005 3:30 pm
by Comtois
Yes , you're right
Edit previous post, i hope everything is correct now ?
