Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
SORT_TEST.BAS nur die schnellsten Routinen
| Uploader: |  Volta |
| Datum/Zeit: | 13.05.2006 17:25:44 |
' SORT_TEST.BAS
'(13.05.2006, Volta)
' RapidSort berichtigt und nun lauffähig.
' Das Programm wurde an die Syntax von freeBASIC angepasst.
' Vor jeder Sortierung werden die Daten gemischt (ShuffleArray).
' Mehrfaches Aufrufen der Routinen (MaxSort = 200) mit MaxArray = 50000.
' auf einem AMD Sempron (1400 MHz) gemessenenen Sortierzeiteten:
' Fastsort......13,75 sek
' ShellSort.....13,02 sek
' FB_QSort.......5,62 sek (rekursiv?)
' Ytwinky_QSort..5,07 sek (rekursiv)
' ASM_QSort......5,05 sek (rekursiv)
' QuickSort......5,14 sek (iterativ)
' QuickSort2.....5,04 sek (iterativ)
' RapidSort......1,96 sek
'
#Include "crt.bi" 'for FB_QSort
Option Explicit
Const Maxsort=200
Const MaxArray=50000
Const Anzeige=460
Const Warte=10
Dim Shared Item(1 To MaxArray)
'
DECLARE SUB ShellSort (Item() As Integer, Count As Integer)
DECLARE Sub Fastsorti (InArray() As Integer, Lower As Integer, Upper As Integer)
DECLARE SUB QuickSort (Item() As Integer, Lower As Integer, Upper As Integer)
Declare SUB QuickSort2 (ToSort() As Integer, Lower As Integer, Upper As Integer)
Declare Sub RapidSort (Item()As Integer, LoElement As Integer, HiElement As Integer)
Declare Sub YQSort(a() As Integer, l As Integer, r As Integer)
Declare Sub ASM_QSort(a() As Integer, l As Integer, r As Integer)
DECLARE Sub CreateArray (Item() As Integer)
DECLARE Sub ShuffleArray (Item() As Integer)
Declare Sub PlotIt (Item() AS Integer,delay As Integer=Warte)
Function FB_qsort Cdecl (elm1 As Integer, elm2 As Integer) As Integer
Function=elm1-elm2
End Function
'
Dim As Integer Ds, i
Dim a$
Dim b!, C!
Screen 12
'Randomize Timer
'
FOR Ds=1 To 8
SELECT CASE Ds
Case 1:A$="Fast Sort"
Case 2:A$="Shell Sort"
Case 3:A$="FB_QSort"
Case 4:A$="Ytwinky_QSort"
Case 5:A$="ASM_QSort"
Case 6:A$="Quick Sort"
Case 7:A$="Quick Sort 2"
Case 8:A$="Rapid Sort"
End Select
LOCATE 1+(2*(Ds-1)), 59:PRINT A$
'
CreateArray Item()
ShuffleArray Item()
PlotIt (Item(),0)
'
LOCATE 29, 60:PRINT "Sorting........."
b!=Timer
For i=1 To MaxSort
ShuffleArray Item()
SELECT CASE Ds
Case 1:Fastsorti Item(), 1, MaxArray
Case 2:ShellSort Item(), MaxArray
Case 3:qsort( @item(1), MaxArray, SizeOf(item), @FB_qsort)
Case 4:YQSort Item(), 1, MaxArray
Case 5:ASM_QSort Item(), 1, MaxArray
Case 6:QuickSort Item(), 1, MaxArray
Case 7:QuickSort2 Item(), 1, MaxArray
Case 8:RapidSort Item(), 1, MaxArray
END Select
Next
C!=Timer
IF C!<b! THEN C!=C!+b!
LOCATE 2+(2*(Ds-1)), 59
PRINT USING " Elaps: ##.####### s"; (C!-b!)
'
LOCATE 29, 60:PRINT "show Sorting...."
FOR i=1 To Anzeige 'zeigt die Sortierung als rote Diagonale
PSET (i, Item(i)), 12
NEXT
Sleep 1000 '1 sek.
Next
'
LOCATE 29, 60:PRINT "verdisch...."
Sleep
End
'
SUB CreateArray (Item() As Integer)
Dim As Integer i
LOCATE 29, 60:PRINT "Creating Array"
FOR i=1 TO MaxArray
Item(i)=i
NEXT
END Sub
'
Sub PlotIt (x() AS Integer,delay As Integer)
Dim As Integer i,j
LINE (0, 0)-(Anzeige, Anzeige), 0, BF
FOR i=1 To Anzeige 'zeigt die Verteilung als gelbe Punkte
j= x(i) Mod Anzeige
PSET (i,j), 14
Next
Sleep delay
End Sub
'
Sub ShuffleArray (Item() AS INTEGER)
Dim As Integer i
FOR i=1 TO MaxArray
SWAP Item(i), Item(INT(RND*MaxArray)+1)
NEXT
END Sub
'
Sub Fastsorti (InArray() As Integer, Lower As Integer, Upper As Integer)
' This routine was writen by Ryan Wellman.
' Copyright 1992, Ryan Wellman, all rights reserved.
' Released as Freeware October 22, 1992.
' You may freely use, copy & modify this code as you see
' fit. Under the condition that I am given credit for
' the original sort routine, and partial credit for modified
' versions of the routine.
' Thanks to Richard Vannoy who gave me the idea to compare
' entries further than 1 entry away.
Dim As Integer Increment, m2, n2, Index, cutpoint, stopnow
Increment=(Upper+Lower)
m2=Lower-1
DO
Increment=Increment\2
n2=Increment+m2
For Index=Lower TO Upper-Increment
IF InArray(Index)>InArray(Index+Increment) THEN
SWAP InArray(Index), InArray(Index+Increment)
IF Index>n2 THEN
cutpoint=Index
stopnow=0
DO
Index=Index-Increment
IF SGN(Index+Increment)=1 AND SGN(Index)=1 THEN
IF InArray(Index)>InArray(Index+Increment) THEN
SWAP InArray(Index), InArray(Index+Increment)
ELSE
stopnow=-1
Index=cutpoint
END IF
ELSE
stopnow=-1
Index=cutpoint
END IF
LOOP UNTIL stopnow
END If
END IF
Next Index
LOOP UNTIL Increment <= 1
End Sub
'
' RapidSort berichtigt und nun lauffähig.
'Eignet sich nur zum sortieren von ubyte, ushort oder uinteger Werten.
'Dieser Sortieralgorithmus ist zwar sehr schnell, aber
'bei größeren Zahlenwerten (HiVal) wird ein riesiges
'Array (SortArray(LoVal TO HiVal)) entstehen, welches schnell
'die Speichergrenzen überschreitet und Fehler produzieren kann.
Sub RapidSort (Item()As Integer, LoElement As Integer, HiElement As Integer)
Dim As Integer n, wert, nptr, arr, rep, LoVal, HiVal
'größte und kleinste Wert bestimmen
LoVal=Item(LoElement)
HiVal=Item(HiElement)
FOR n=LoElement TO HiElement
If LoVal> Item(n) Then LoVal=Item(n)
If HiVal< Item(n) Then HiVal=Item(n)
Next
'ein SortArray erstellen, als Index größte bis kleinste Wert
ReDim SortArray(LoVal TO HiVal) As Integer
'in SortArray wird gezählt wie oft jeder Wert in Item() vorkommt
FOR n=LoElement TO HiElement
wert=Item(n)
SortArray(wert)=SortArray(wert)+1
Next
'umkopieren SortArray => Item sortiert
nptr=LoElement-1
FOR arr=LoVal TO HiVal
rep=SortArray(arr)
FOR n=1 TO rep
nptr=nptr+1
Item(nptr)=arr
Next
Next
Erase SortArray
END Sub
'
TYPE stacktype 'for QuickSort
low AS INTEGER
hi AS INTEGER
END Type
SUB QuickSort (SortArray() As Integer, Lower As Integer, Upper As Integer)
'QuickSort iterative (rather than recursive) by Cornel Huth
ReDim lstack(1 TO 128) AS stacktype 'our stack
Dim sp AS Integer 'out stack pointer
Dim As Integer low, hi, i, j, midx, compare
sp=1
lstack(sp).low=Lower
lstack(sp).hi=Upper
sp=sp+1
DO
sp=sp-1
low=lstack(sp).low
hi=lstack(sp).hi
DO
i=low
J=hi
midx=(low+hi)\2
compare=SortArray(midx)
DO
DO WHILE SortArray(i)<compare
i=i+1
LOOP
DO WHILE SortArray(J)>compare
J=J-1
LOOP
IF i <= J THEN
Swap SortArray(i), SortArray(J)
i=i+1
J=J-1
End IF
Loop While i <= J
IF J-low<hi-i THEN
IF i<hi THEN
lstack(sp).low=i
lstack(sp).hi=hi
sp=sp+1
End IF
hi=J
ELSE
IF low<J THEN
lstack(sp).low=low
lstack(sp).hi=J
sp=sp+1
End IF
low=i
End If
Loop While low<hi
Loop While sp <> 1
Erase lstack
End Sub
'
Sub QuickSort2 (ToSort() As Integer, Lower As Integer, Upper As Integer)
'Standard QuickSort Routine
Dim Temp As integer
Dim First, Last, i, j, StackPtr
ReDim QStack(Upper\5+10)
First=lower
Last=Upper
Do
Do
Temp=ToSort((Last+First)\2)
i=First
j=Last
Do
While ToSort(i)<Temp
i=i+1
Wend
While ToSort(j)>Temp
j=j-1
Wend
If i>j Then Exit Do
If i<j Then Swap ToSort(i), ToSort(j)
i=i+1
j=j-1
Loop While i <= j
If i<Last Then
QStack(StackPtr)=i
QStack(StackPtr+1)=Last
StackPtr=StackPtr+2
End If
Last=j
Loop While First<Last
If StackPtr=0 Then Exit Do
StackPtr=StackPtr-2
First=QStack(StackPtr)
Last=QStack(StackPtr+1)
Loop
Erase QStack
End Sub
'
SUB ShellSort (Item() As Integer, Count As Integer)
Dim As Integer M, X, h, v
M=Count
DO While M\2
M=M\2
FOR X=1 TO Count-M
h=X
DO
v=h+M
IF Item(h)<Item(v) THEN EXIT DO
SWAP Item(h), Item(v)
h=h-M
Loop While h >= 1
Next
LOOP
END Sub
'
Sub YQSort(a() As Integer, l As Integer, r As Integer)
'(c)longtime ago by someone who could program in pascal
'program QSort(pascal) has been successfully ported to FB
Dim As Integer i=l, j=r, x=a((l+r)\2)
Do
While a(i)<x
i+=1
Wend
While x<a(j)
j-=1
Wend
If i<=j Then
Swap a(i), a(j)
i+=1
j-=1
End If
Loop Until i>j
If l<j Then QuickSort(a(), l, j)
If i<r Then QuickSort(a(), i, r)
End Sub
'
Sub ASM_QSort(a() As Integer, l As Integer, r As Integer)
Dim As Integer i=l, j=r, x=a((l+r)\2)
Asm
QS_L0: 'Do
mov ecx, [a]
mov ecx, [ecx]
QS_L1:
mov ebx, [i]
lea edi, [ecx+ebx*4]
mov ebx, [x]
cmp [edi], ebx 'While a(i)<x
jge QS_L2
inc dword ptr [i] 'i+=1
jmp QS_L1
QS_L2:
mov ebx, [j]
lea esi, [ecx+ebx*4]
mov eax, [esi]
cmp [x], eax 'While x<a(j)
jge QS_L3
dec dword ptr [j] 'j-=1
jmp QS_L2
QS_L3:
cmp [i], ebx 'If i<=j Then
jg QS_L4
mov eax, [edi] 'Swap a(i), a(j)
xchg eax, [esi]
mov [edi], eax
inc dword ptr [i] 'i+=1
dec dword ptr [j] 'j-=1
QS_L4:
cmp [i], ebx 'Loop Until i>j
jle QS_L0
End Asm
If l<j Then QuickSort(a(), l, j)
If i<r Then QuickSort(a(), i, r)
End Sub
'kleiner Tip für den BE: gib bei RESFILE '-r' ein dann bleibt die asm-Datei erhalten.
'BESETTINGS (don't change!):
'BECURSOR=23F8
'BETOGGLE=11111111111
'BETARGET=1
'BERESFILE=-r