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

' 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
'***********************************************************************
'
Const MaxAlgo=12
Const Maxsort = 1000
Const MaxArray = 400
Const Warte = 10
Const Status=27
Dim AlgoList(11) As ZString Ptr=>{@"Bubble Sort", @"Shaker Sort", @"Selection Sort", @"Insert Sort", @"Shell Sort", _
@"Shell Sort 2", @"Quick Sort", @"Rapid Sort", @"Fast Sort", @"Bubble Sort 2", @"Quick Sort 2", @"ytwinky QSort"}
DIM As Integer Item(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 Sub QuickSorty(a() As Integer, l As Integer, r As Integer)
'
Dim As Integer Ds, i, j
Dim Shared Show As Integer
Dim As String a
Dim As Double b, C
'
Screen 12
'
FOR Ds = 1 To MaxAlgo
  LOCATE 1 + (2 * (Ds - 1)), 59
  PRINT *AlgoList(Ds-1)
  '
  CreateArray Item()
  ShuffleArray Item()
  PlotIt (Item(), 0)
  '
  LOCATE Status, 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 : QuickSort2 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 : QuickSorty Item(), 1, MaxArray
    END Select
  Next
  C = Timer
  LOCATE 2 + (2 * (Ds - 1)), 59
  PRINT USING "  Elaps: ##.####### s"; Abs(C - b)
  '
  LOCATE Status, 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 : QuickSort2 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 : QuickSorty Item(), 1, MaxArray
  END Select
  FOR i = 1 TO MaxArray  'zeigt die Sortierung als grüne Diagonale
    PSET (i, Item(i)), 10
  NEXT
  Sleep 500 '0.5 sek.
Next

LOCATE Status, 60
PRINT "Habe Fertig."
Sleep
End

'
'***
SUB CreateArray (Item() As Integer)
  Dim As Integer i
  LOCATE Status, 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) '11 lines , 2 vars, no array
  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 Then PlotIt (Item())
  Next
End Sub

Sub BubbleSort2 (Item() As Integer, Count As Integer) '14 lines , 3 vars, no array
  Dim As Integer passes, swapped = 0, 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) '33 lines , 6 vars, no array
  ' 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 -= 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 Then PlotIt (InArray(),Warte\10)
      END IF
    NEXT Index
  LOOP UNTIL Increment <= 1
END SUB

'
'***
Sub InsertSort (Item() As Integer, Count As Integer) '13 lines , 3 vars, no array
  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) '21 lines , 7 vars, 1 array
  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
  low AS INTEGER
  hi AS INTEGER
END Type

SUB QuickSort (SortArray() As Integer, Lower As Integer, Upper As Integer) '49 lines , 7 vars, 1 array + 1 Type
  'QuickSort iterative (rather than recursive) by Cornel Huth
  ReDim lstack(1 TO 128) AS stacktype  'our stack
  DIM AS INTEGER sp = 2                'out stack pointer
  Dim As Integer low, hi, i, j, midx, compare
  'maxsp = sp
  lstack(sp).low = Lower
  lstack(sp).hi = Upper
  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) '37 lines , 6 vars, 1 array
'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 = 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) '16 lines , 4 vars, no array
  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) '23 lines , 4 vars, no array
  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 Then PlotIt (Item())
  LOOP WHILE C < d
END SUB

'
'***
SUB ShellSort (Item() As Integer, Count As Integer) '17 lines , 4 vars, no array \
  Var M=Count, X=0, h=0, v=0
  DO WHILE M\2 'INT(M / 2)
    M = M\2 '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) '18 lines , 5 vars, 1 array
  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 -= k
      LOOP
      Item(J + k) = X
      If Show Then PlotIt (Item(),Warte\10)
    Next
  NEXT
END Sub

Sub QuickSorty(a() As Integer, l As Integer, r As Integer) '19 lines , 3 vars, no array
  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 Show Then PlotIt (a())
  If l<j Then QuickSorty(a(), l, j)
  If i<r Then QuickSorty(a(), i, r)
End Sub