' 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 Sortieralgorithmen 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
Const False=0, True=Not False
Const Maxsort=500
Const MaxArray=460
Const Warte=10
Const MaxAlg=14
Const MsgLn=30
Dim Shared Item(1 To MaxArray) As Integer
'
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 YQSort(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)
Declare Function FB_qsort Cdecl (elm1 As Integer Ptr, elm2 As Integer Ptr) As Integer
Declare Sub ASM_QSort(a() As Integer, l As Integer, r As Integer)
 
Dim As Integer Ds, i, j
Dim As Double Beginn, Ende, d, xs
Dim As String a, t(13)={"Bubble Sort", "Bubble Sort 2", "Fast Sort", "Insert Sort", "Quick Sort", _
                      "Quick Sort 2", "FB_QSort", "ytwinky_QSort", "Rapid Sort", "Selection Sort", _
                      "Shaker Sort", "Shell Sort", "Shell Sort 2","ASM_QSort"}
Dim Shared As Integer show
Dim Shared As Integer Grafics
Grafics=Abs(lcase(Command(1))<>"-g")
'
Screen 12
'
Locate 1, 60
Print "Algorithm    Time[s]";
Color 7, 0
For Ds=1 To MaxAlg
  Locate 2*Ds, 59
  Print t(ds-1)
  '
  CreateArray Item()
  ShuffleArray Item()
  If Grafics Then PlotIt (Item(),0)
  '
  Locate MsgLn, 60
  Print "Sorting.........";
  show=False
  Beginn=Timer
  For i=1 To MaxSort
    ShuffleArray Item()
    Select Case Ds
      Case  1 : BubbleSort Item(), MaxArray : xs=Timer-Beginn
      Case  2 : BubbleSort2 Item(), MaxArray
      Case  3 : FastSorti Item(), 1, MaxArray
      Case  4 : InsertSort Item(), MaxArray
      Case  5 : QuickSort Item(), 1, MaxArray
      Case  6 : QuickSort2 Item(), 1, MaxArray
      Case  7 : qsort( @item(1), MaxArray, SizeOf(item), cast(any ptr,@FB_qsort))
      Case  8 : YQSort Item(), 1, MaxArray
      Case  9 : RapidSort Item(), 1, MaxArray
      Case 10 : SelectSort Item(), MaxArray
      Case 11 : ShakerSort Item(), MaxArray
      Case 12 : ShellSort Item(), MaxArray
      Case 13 : ShellSort2 Item(), MaxArray
      Case 14 : ASM_QSort(Item(), 1, MaxArray )
    End Select
  Next
  Ende=Timer
  If Ende<Beginn Then Ende+=Beginn
  d=Ende-Beginn
  Locate 2*Ds, 73
  If d>xs Then Color 4
  If d<xs/2 Then Color 6
  If d<xs/5 Then Color 14
  If d<xs/12 Then Color 2
  If d<xs/20 Then Color 10
  Print Using "##.####"; d
  Color 7, 0
  '
  Locate MsgLn, 60
  Print "show Sorting....";
  show=True
  ShuffleArray Item()
  Select Case Ds
      Case  1 : BubbleSort Item(), MaxArray
      Case  2 : BubbleSort2 Item(), MaxArray
      Case  3 : FastSorti Item(), 1, MaxArray
      Case  4 : InsertSort Item(), MaxArray
      Case  5 : QuickSort Item(), 1, MaxArray
      Case  6 : QuickSort2 Item(), 1, MaxArray
      Case  7 : qsort( @item(1), MaxArray, SizeOf(item), Cast(Any Ptr, @FB_QSort))
      Case  8 : YQSort Item(), 1, MaxArray
      Case  9 : RapidSort Item(), 1, MaxArray
      Case 10 : SelectSort Item(), MaxArray
      Case 11 : ShakerSort Item(), MaxArray
      Case 12 : ShellSort Item(), MaxArray
      Case 13 : ShellSort2 Item(), MaxArray
      Case 14 : ASM_QSort(Item(), 1, MaxArray )
  End Select
  If Grafics Then
    For i=1 To MaxArray  'zeigt die Sortierung als grüne Diagonale
      PSet (i, Item(i)), 10
    Next
    Sleep 500 '1 sek.
  End If
Next

Locate MsgLn, 60
Print "verdisch....";
Print Input(1)
End

'
Sub CreateArray(Item() As Integer)
  Dim As Integer i
  Locate MsgLn, 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
  If Grafics=0 Then Return
  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 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
  Var 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 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)
    Next
    If show Then PlotIt(Item())
  Next
End Sub

Sub BubbleSort2(Item() As Integer, Count As Integer)
  Dim As Integer passes=0, swapped, j
  Do
    swapped=0
    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 Then PlotIt (Item())
  Loop Until swapped=0
End Sub

'
Sub FastSorti(InArray() As Integer, Lower As Integer, Upper As Integer)
  ' This routine was writtn 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\=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-=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=True
                  Index=cutpoint
                End If
              Else
                stopnow=True
                Index=cutpoint
              End If
            Loop Until stopnow
        End If
        If show 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-=1
    Wend
    Item(b+1)=t
    If show 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=Item(LoElement), HiVal=Item(HiElement)
  'größte und kleinste Wert bestimmen
  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)+=1
  Next
  'umkopieren SortArray => Item sortiert
  nptr=LoElement-1
  For arr=LoVal To HiVal
    rep=SortArray(arr)
    For n=1 To rep
      nptr+=1
      Item(nptr)=arr
    Next
    If show Then PlotIt (Item(), Warte\10)
  Next
  Erase SortArray
End Sub

'
Type stacktype        'for QuickSort
  As Integer low, hi
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
  'maxsp=1
  lstack(1).low=Lower
  lstack(1).hi=Upper
  sp=2
  Do
    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+=1
        Loop
        Do While SortArray(j)>compare
          j-=1
        Loop
        If i<=j Then
          Swap SortArray(i), SortArray(j)
          i+=1
          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+=1
            End If
            hi=j
          Else
            If low<j Then
              lstack(sp).low=low
              lstack(sp).hi=j
              sp+=1
            End If
            low=i
          End If
          If show 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 As Integer First=lower, Last=Upper, i, j, StackPtr
  ReDim As Integer QStack(Upper\5+10)
  Do
    Do
      Temp=ToSort((Last+First)\2)
      i=First
      j=Last
      Do
        While ToSort(i)<Temp
          i+=1
        Wend
        While ToSort(j)>Temp
          j-=1
        Wend
        If i>j Then Exit Do
        If i<j Then Swap ToSort(i), ToSort(j)
        i+=1
        j-=1
      Loop While i<=j
      If i<Last Then
        QStack(StackPtr)=i
        QStack(StackPtr+1)=Last
        StackPtr+=2
      End If
      Last=j
      If show 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 Then PlotIt(Item())
  Next
End Sub

'
Sub ShakerSort(Item() As Integer, Count As Integer)
  Dim As Integer c=1, b=Count, d=b-1, a
  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 Then PlotIt(Item())
  Loop While c<d
End Sub

'
Sub ShellSort(Item() As Integer, Count As Integer)
  Dim As Integer m=Count, x, h, v
  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-=m
      Loop While h>=1
    Next
    If show Then PlotIt(Item(), Warte*30)
  Loop
End Sub

'
'***
Sub ShellSort2(Item() As Integer, Count As Integer)
  Dim A(5) As Integer={0, 9, 5, 3, 2, 1} 'die 0 ist sehr wichtig :D
  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-=k
      Loop
      Item(j+k)=x
      If show Then PlotIt(Item(), Warte\10)
    Next
  Next
End Sub

Function FB_qsort Cdecl (elm1 As Integer Ptr, elm2 As Integer Ptr) As Integer
  Function=*elm1-*elm2
  If show Then PlotIt(Item(), Warte\10)
End Function


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 show Then PlotIt(Item(), Warte\10)
  If l<j Then ASM_QSort(a(), l, j)
  If i<r Then ASM_QSort(a(), i, r)
End Sub