Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
visisort.bas aus der MonsterFAQ 2 (mit FB_qsort)
| Uploader: |  Volta |
| Datum/Zeit: | 12.05.2006 21:51:28 |
' VISISORT.BAS = Demonstrates 9 sort algorithms ans compairs their speed
' ============ Demonstriert 9 Sortieralgorithmen und misst deren
' Geschwindigkeit
'
' Deutsche Beschreibung
' ------------------------------
' (von Thomas Antoni, 11.3.2006)
' Dieses Q(uick)Basic-Programm demonstriert 9 verschiedene
' Sortieralgorithmen und misst deren Geschwindigkeit im Vergleich. Dazu
' wird ein Feld mit 200 Integerzahlen in abfallender Reihenfolge gefuellt
' und anschliessend in aufsteigende Reihenfolge umsortiert. Die Folge der
' unsortierten und sortierten zahlen werden jeweils als gelbe Punkte
' auf einer Linie visualisiert - daher der Name "VisiSort". Das Programm
' wurde von einem alten Apple 3-Programm abgeleitet.
' In der folgenden Liste sind die Sortieralgrithmen und die auf meinem
' Pentium 100 MHz gemessenenen Sortierzeiten aufgefuehrt:
'
' BubbleSort....22.9 sec
' ShakerSort....26.6 sec
' SelectionSort..0.5 sec
' InsertSort....26.5 sec
' ShellSort......0,9 sec
' ShellSort2.....4.2 sec
' QuickSort......0.3 sec (iteratives, nicht-rekursives verfahren)
' Fastsort.......0.2 sec
' RapidSort......0.0 sec (scheint nicht zu funktionieren)
'(09.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 = 3000) mit MaxArray = 460.
' auf einem Pentium (1000 MHz) gemessenenen Sortierzeiten (MaxSort = 3000):
' unsortiert vorsortiert (ohne ShuffleArray)
' BubbleSort...12,22 sek 3,84 sek
' ShakerSort....9,72 sek 0,03 sek
' SelectionSort.3,13 sek 3,01 sek
' InsertSort....7,05 sek 0,08 sek
' ShellSort.....0,88 sek 0,18 sek
' ShellSort2....1,96 sek 0,50 sek
' QuickSort.....0,48 sek 0,18 sek (iterativ)
' RapidSort.....0,10 sek 0,10 sek
' Fastsort......1,09 sek 0,13 sek
' BubbleSort2..12,03 sek 0,03 sek
' QuickSort2....0,48 sek 0,18 sek
' FB_QSort......0,57 sek 0,31 sek
'
' English-language Description
' -------------------------------
' On the business of sort algorithm's, It made me think of a program
' that was out on the Apple 2 systems, way back when, called
' Visi-Sort Plus, which let you actuallly see how a sort program
' really works. Intrigued by it, I decided to make one for the IBM
' (VGA monitors). The only sort I could not fit in was RapidSort,
' other from that there are 9 different sorts you can view.
' (c) by LUIS ESPINOZA, May 28, 1993
'***********************************************************************
'
#Include "crt.bi" 'nur für FB_QSort
Option Explicit
Const Maxsort = 4000
Const MaxArray = 460
Const Warte = 10
Dim Shared Item(1 To MaxArray)
'
Declare Sub BubbleSort (Item() As Integer, Count As Integer)
Declare Sub BubbleSort2 (Item() As Integer, Count As Integer)
DECLARE SUB ShakerSort (Item() As Integer, Count As Integer)
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 ShellSort2 (Item() As Integer, Count As Integer)
DECLARE SUB SelectSort (Item() As Integer, Count As Integer)
DECLARE Sub InsertSort (Item() As Integer, Count As Integer)
DECLARE Sub RapidSort (Item()As Integer, LoElement As Integer, HiElement As Integer)
DECLARE SUB CreateArray (Item() As Integer)
DECLARE Sub ShuffleArray (Item() As Integer)
Declare Sub PlotIt (Item() AS Integer,delay As Integer = Warte)
Declare Function FB_qsort Cdecl ( elm1 As integer, elm2 As integer ) As Integer
'
Dim As Integer Ds, i, j
Dim Shared show As integer
Dim a$
Dim b!, C!
'
Screen 12
'
FOR Ds = 1 To 12
SELECT CASE Ds
CASE 1 : A$ = "Bubble Sort"
CASE 2 : A$ = "Shaker Sort"
CASE 3 : A$ = "Selection Sort"
CASE 4 : A$ = "Insert Sort"
CASE 5 : A$ = "Shell Sort"
CASE 6 : A$ = "Shell Sort 2"
CASE 7 : A$ = "Quick Sort"
CASE 8 : A$ = "Rapid Sort"
CASE 9 : A$ = "Fast Sort"
Case 10 : A$ = "Bubble Sort 2"
Case 11 : A$ = "Quick Sort 2"
Case 12 : A$ = "FB_QSort"
End Select
LOCATE 1 + (2 * (Ds - 1)), 59
PRINT A$
'
CreateArray Item()
ShuffleArray Item()
PlotIt (Item(),0)
'
LOCATE 26, 60
PRINT "Sorting........."
show = 0
b! = Timer
For i = 1 To MaxSort
ShuffleArray Item()
SELECT CASE Ds
CASE 1 : BubbleSort Item(), MaxArray
CASE 2 : ShakerSort Item(), MaxArray
CASE 3 : SelectSort Item(), MaxArray
CASE 4 : InsertSort Item(), MaxArray
CASE 5 : ShellSort Item(), MaxArray
CASE 6 : ShellSort2 Item(), MaxArray
CASE 7 : QuickSort Item(), 1, MaxArray
CASE 8 : RapidSort Item(), 1, MaxArray
CASE 9 : Fastsorti Item(), 1, MaxArray
CASE 10 : BubbleSort2 Item(), MaxArray
Case 11 : QuickSort2 Item(), 1, MaxArray
Case 12 : qsort( @item(1), MaxArray, SizeOf(item), @FB_qsort)
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 26, 60
PRINT "show Sorting...."
show=1
ShuffleArray Item()
SELECT CASE Ds
CASE 1 : BubbleSort Item(), MaxArray
CASE 2 : ShakerSort Item(), MaxArray
CASE 3 : SelectSort Item(), MaxArray
CASE 4 : InsertSort Item(), MaxArray
CASE 5 : ShellSort Item(), MaxArray
CASE 6 : ShellSort2 Item(), MaxArray
CASE 7 : QuickSort Item(), 1, MaxArray
CASE 8 : RapidSort Item(), 1, MaxArray
CASE 9 : Fastsorti Item(), 1, MaxArray
CASE 10 : BubbleSort2 Item(), MaxArray
Case 11 : QuickSort2 Item(), 1, MaxArray
Case 12 : qsort( @item(1), MaxArray, SizeOf(item), @FB_qsort)
END Select
FOR i = 1 TO MaxArray 'zeigt die Sortierung als grüne Diagonale
PSET (i, Item(i)), 10
NEXT
Sleep 1000 '1 sek.
Next
LOCATE 26, 60
PRINT "verdisch...."
Sleep
End
'
'***
SUB CreateArray (Item() As Integer)
Dim As Integer i
LOCATE 26, 60
PRINT "Creating Array"
FOR i = 1 TO MaxArray
Item(i) = i
NEXT
END Sub
'
'***
Sub PlotIt (Item() AS Integer,delay As Integer)
Dim As Integer i
LINE (0, 0)-(MaxArray, MaxArray), 0, BF
FOR i = 1 TO MaxArray 'zeigt die Verteilung als rote Punkte
PSET (i,Item(i)), 12
Next
Sleep delay
End Sub
'
'***
Sub ShuffleArray (Item() AS INTEGER)
Dim As Integer i
FOR i = 1 TO MaxArray
SWAP Item(INT(RND * MaxArray) + 1), Item(INT(RND * MaxArray) + 1)
NEXT
END Sub
'
'***
Sub BubbleSort (Item() As Integer, Count As Integer)
Dim As Integer i, j
For i = 1 To Count - 1
For J = 1 To Count - i
If Item(J) > Item(J + 1) THEN
Swap Item(J), Item(J + 1)
End If
Next
If show = 1 Then PlotIt (Item())
Next
End Sub
Sub BubbleSort2 (Item() As Integer, Count As Integer)
Dim As Integer passes, swapped, j
passes = 0
Do
swapped = 0
passes = passes + 1
For j = 1 To count - passes
If Item(J) > Item(J + 1) THEN
Swap Item(J), Item(J + 1)
swapped = 1
End If
next
If show = 1 Then PlotIt (Item())
loop until swapped = 0
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
If show = 1 Then PlotIt (InArray(),Warte\10)
END IF
NEXT Index
LOOP UNTIL Increment <= 1
END SUB
'
'***
Sub InsertSort (Item() As Integer, Count As Integer)
Dim As Integer A, t, b
FOR A = 2 TO Count
t = Item(A)
b = A - 1
WHILE b >= 1 AND (t < Item(b))
Item(b + 1) = Item(b)
b = b - 1
WEND
Item(b + 1) = t
If show = 1 Then PlotIt (Item())
NEXT
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
If show = 1 Then PlotIt (Item(),Warte\10)
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
'maxsp = sp
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
If show = 1 Then PlotIt (SortArray())
LOOP WHILE low < hi
'IF sp > maxsp THEN maxsp = sp
LOOP WHILE sp <> 1
'PRINT "MAX SP"; maxsp
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
If show = 1 Then PlotIt (ToSort())
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 SelectSort (Item() As Integer, Count As Integer)
Dim As Integer A, C, t, b
FOR A = 1 TO Count - 1
C = A
t = Item(A)
FOR b = A + 1 TO Count
IF Item(b) < t THEN
C = b
t = Item(b)
END IF
NEXT
Item(C) = Item(A)
Item(A) = t
If show = 1 Then PlotIt (Item())
NEXT
END SUB
'
'***
SUB ShakerSort (Item() As Integer, Count As Integer)
Dim As Integer C, b, d, A
C = 1
b = Count
d = b - 1
DO
FOR A = d TO C STEP -1
IF Item(A) > Item(A + 1) THEN
SWAP Item(A), Item(A + 1)
b = A
END IF
NEXT
C = b + 1
FOR A = C TO d
IF Item(A) > Item(A + 1) THEN
SWAP Item(A), Item(A + 1)
b = A
END IF
NEXT
d = b
If show = 1 Then PlotIt (Item())
LOOP WHILE C < d
END SUB
'
'***
SUB ShellSort (Item() As Integer, Count As Integer)
Dim As Integer M, X, h, v
M = Count
DO WHILE INT(M / 2)
M = INT(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
If show = 1 Then PlotIt (Item(),Warte*30)
LOOP
END SUB
'
'***
SUB ShellSort2 (Item() As Integer, Count As Integer)
DIM A(5) As Integer
A(1)=9: A(2)=5: A(3)=3: A(4)=2: A(5)=1
Dim As Integer i, w, k, x, j
FOR w = 1 TO 5
k = A(w)
FOR i = k TO Count
X = Item(i)
J = i - k
DO WHILE X < Item(ABS(J)) AND J > 0 AND J < Count
Item(J + k) = Item(J)
J = J - k
LOOP
Item(J + k) = X
If show = 1 Then PlotIt (Item(),Warte\10)
Next
NEXT
END Sub
Function FB_qsort Cdecl ( elm1 As integer, elm2 As integer ) As Integer
Function = Sgn(elm1 - elm2 )
If show = 1 Then PlotIt (Item(),Warte\10)
End Function