' 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

Const Maxsort = 500
Const MaxArray = 460
Const Warte = 10
Const MaxAlg=13
Const MsgLn=30
Dim Shared As Integer 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 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, elm2 As integer ) As Integer
'
Dim As Integer Ds, i, j
Dim Shared As integer show, Grafics
Grafics=Abs(LCAse(Command$(1))<>"-g")
Dim a As String
Dim As Double b, C
'
Screen 12
'
FOR Ds = 1 To MaxAlg
  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"
    Case 13 : A= "ytwinky_QSort" 
  End Select
  LOCATE 1 + (2 * (Ds - 1)), 59
  PRINT A
  '
  CreateArray Item()
  ShuffleArray Item()
If Grafics Then PlotIt (Item(),0)
  '
  LOCATE MsgLn, 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)
      Case 13: YQSort Item(), 1, MaxArray
    END Select
  Next
  C = Timer
  LOCATE 2 + (2 * (Ds - 1)), 59
  PRINT USING "  Elaps: ##.####### s"; Abs(C - b)
  '
  LOCATE MsgLn, 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)
    Case 13:YQSort 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....";
Sleep
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 
  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 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 As Integer First, Last, i, j, StackPtr
  ReDim As Integer 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

'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
'
'
'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