Option Explicit

Const MIN = 1, MAX = 12

Private Enum sortType
    BUBBLE
    BIBUBBLE
    INSERTION
    SHELLS
    SELECTION
    BISELECTION
    QUICK
    HEAP
End Enum

Dim Last1%
Dim sortarray() As Integer

'======================================================
' The classic Bubble Sort is about the simplest in that
'   it just makes continual passes on an array
'   swapping an element with the one above it until on
'   one pass there are no swaps made so it knows its
'   work is done.
'======================================================
Private Sub Bubble_Sort()
    Dim j%, last%, tmp%, Done As Boolean
    
    'End the loop 1 less than Last1
    ' because we are comparing with j + 1
    last = Last1 - 1
    
    Do While Not Done
        Done = True 'Set the boolean optimisticly
        
        For j = 0 To last
            If sortarray(j) > sortarray(j + 1) Then
                'The swap
                tmp = sortarray(j)
                sortarray(j) = sortarray(j + 1)
                sortarray(j + 1) = tmp
                
                'If we have made one swap then we are not done
                ' and we must make another full pass
                Done = False
            End If
        Next
        
        'At the end of one pass the highest element is
        ' bubbled up to the top - so wee don't need to
        ' compare it again
        last = last - 1
    Loop
End Sub

'======================================================
' A BiBubble Sort first bubbles the largest item to
'   the top just like the bubble sort, but then
'   it next bubbles the smallest item down to
'   the bottom.
'======================================================
Private Sub BiBubble_Sort()
    Dim j%, first%, last%, tmp%, Done As Boolean
        
    last = Last1 - 1
    Do While Not Done
        Done = True
        For j = first To last
            If sortarray(j) > sortarray(j + 1) Then
                tmp = sortarray(j)
                sortarray(j) = sortarray(j + 1)
                sortarray(j + 1) = tmp
                Done = False
            End If
        Next
        
        If Done Then Exit Do
        first = first + 1
        
        'Now we bubble down from the top
        For j = last To first Step -1
            If sortarray(j) < sortarray(j - 1) Then
                tmp = sortarray(j)
                sortarray(j) = sortarray(j - 1)
                sortarray(j - 1) = tmp
                Done = False
            End If
        Next
        
        last = last - 1
    Loop
End Sub

'======================================================
' The Insertion Sort is kind of a reverse bubble where
'   elements are examined from low to high but the
'   values are compared with the element below and
'   swapped down to its lowest possible position. It
'   ends up being about as efficient as the bubble sort
'   since effectively there is one pass for each
'   element.
'======================================================
Private Sub Insertion_Sort()
    Dim j%, low%, high%, tmp%
    
    For j = 1 To Last1
        high = j
        Do
            low = high - 1
            If sortarray(low) > sortarray(high) Then
                tmp = sortarray(low)
                sortarray(low) = sortarray(high)
                sortarray(high) = tmp
                
                'Since a swap has been made we try
                ' to take the swapped element lower.
                high = low  'same as high = high - 1
            Else
                'When there are no more swaps then
                ' this element has been taken as low
                ' as it will go
                Exit Do
            End If
        Loop Until high <= 0
    Next
End Sub

'======================================================
'Another version of the Insertion Sort (no button)
'  demonstrating the shuffle up assignment rather
'  than swapping each element with the next 1. This
'  can save approx 66% of swapping assignments in
'  a large array.
'======================================================
Private Sub Insertion_Shuffle_Sort()
    Dim j%, low%, high%, tmp%
    
    For j = 1 To Last1
        high = j
        tmp = sortarray(high)

        Do
            low = high - 1
            If sortarray(low) <= tmp Then Exit Do
            sortarray(high) = sortarray(low)
            high = low
        Loop Until high <= 0

        sortarray(high) = tmp
    Next
End Sub

'======================================================
' The Shell Sort is an insertion sort that compares
'   elements that are more than 1 apart.
' The diff (or offset determines how far apart the
'   compared (and swapped) items will be. After
'   each pass the diff becomes progressively smaller
'   until it is 1 - and then finally 0.
' Swapping elements far apart can result in
'   considerable time saving.
'======================================================
Private Sub Shell_Sort()
    Dim diff%, low%, high%, tmp%
    
    'The classic divisor to obtain the offset is 2
    'Note: diff = (MAX - MIN) \ 2
    diff = Last1 \ 2
    
    Do While diff
        'Establish starting high position
        'Note: high = MIN + diff
        high = diff
        
        Do Until high > Last1
            'Compute the low position
            low = high - diff
            
            If sortarray(low) > sortarray(high) Then
                tmp = sortarray(low)
                sortarray(low) = sortarray(high)
                sortarray(high) = tmp
                
                'If a swap is made then we chase
                ' it down like an insertion sort.
                ' This guarantees that eventually
                ' when diff = 1 then the array will
                ' be fully sorted.
                If diff = 1 Then
                    'Chase lower only on final pass
                    ' (Insertion Sort)
                    If low > 0 Then high = low - 1
                    'Made 1 less because incr below
                End If
            End If
            
            high = high + 1
        Loop
        
        'You can experiment with other divisors
        ' (like 1.3 here) to improve speed
        ' taking care that eventually diff
        ' will become 1 and 0. When it becomes 0
        ' we pop out of the loop
        diff = Int(CSng(diff) / 1.3)
    Loop
End Sub

'======================================================
' The Selection Sort simply makes progressive passes to
'   find the smallest element. It then swaps that
'   element into the lowest position and subsequent
'   passes do not examine the placed element.
'======================================================
Private Sub Selection_Sort()
    Dim j%, low%, lower%, tmp%
    
    Do Until lower >= Last1
        'First assume the lowest position
        '  is the low value.
        low = lower
                
        'Run through the remaining elements
        '  keep track of the low value
        For j = lower + 1 To Last1
            If sortarray(j) < sortarray(low) Then low = j
        Next
        
        'Now swap if it is not positioned correctly
        If low <> lower Then
            tmp = sortarray(lower)
            sortarray(lower) = sortarray(low)
            sortarray(low) = tmp
        End If
        
        'Increment so we don't examine
        '  this position again
        lower = lower + 1
    Loop
End Sub

'======================================================
' The BiSelection Sort is like the Selection Sort but
'   keeps track of both the lowest and the highest
'   value on a single pass. At the end of the pass
'   the highest value found is swapped to the highest
'   position and the lowest valuefound is swapped to
'   the lowest position.
'======================================================
Private Sub BiSelection_Sort()
    Dim j%, low%, high%, lower%, upper%, tmp%
    
    upper = Last1
    
    Do Until lower >= upper
        'Initialize with elements at the ends
        high = upper
        low = lower
                
        'Loop to find highest and lowest value
        For j = lower To upper
            If sortarray(j) < sortarray(low) Then
                low = j
            ElseIf sortarray(j) > sortarray(high) Then
                high = j
            End If
        Next
        
        'Swap the highest found to highest position
        If high <> upper Then
            If low = upper Then low = high
            tmp = sortarray(upper)
            sortarray(upper) = sortarray(high)
            sortarray(high) = tmp
        End If
        
        'Swap the lowest found to lowest position
        If low <> lower Then
            tmp = sortarray(lower)
            sortarray(lower) = sortarray(low)
            sortarray(low) = tmp
        End If
        
        'Move the ends in towards the center
        lower = lower + 1
        upper = upper - 1
    Loop
End Sub

'======================================================
' The Quick Sort is so named because of its ability to
'   sort extremely fast by swapping elements that may
'   be a great many positions apart. It starts by
'   choosing a mid value around which to base its
'   swaps in the middle of the array. Since the center
'   position actually may hold a value that is far from
'   an optimal mid value, some have attempted to
'   improve this technique of selecting a mid value.
' Perhaps the most interesting part of this sort is
'   that the procedure is recursive. You will note at
'   the end of the procedure are 2 lines that call
'   itself (the two halves of the array that do not
'   get sorted by the original call).
' This recursive feature has the price of using
'   increasing stack space to store the dimmed
'   variables which in very large arrays may have the
'   penalty of blowing the STACK space where these temp
'   variables are stored in memory. Since this can have
'   the effect of crashing your program, most sorting
'   done nowadays implements a Heap Sort.
'======================================================
Private Sub Quick_Sort(ByVal lower%, ByVal upper%)
    If lower >= upper Then Exit Sub
    
    Dim low%, midl%, high%, midval%, tmp%
    
    low = lower
    high = upper
    
    'Determine a mid value by position only
    midl = (lower + upper) \ 2
    midval = sortarray(midl)
 
    Do While low <= high
        'Find a value higher than the mid value
        '  that is below the midpoint
        Do Until low >= upper
            If sortarray(low) >= midval Then Exit Do
            low = low + 1
        Loop
     
        'Find a value lower than the mid value
        '  that is above the midpoint
        Do Until high <= lower
            If midval >= sortarray(high) Then Exit Do
            high = high - 1
        Loop
 
        If low <= high Then
            'Note we do not want to increment low and
            '  decrement high if they have collided
            If low < high Then
                'This test means we have found:
                '1. A value higher than midval
                '2. A value lower than midval
                '3. They are out of order
                '(if one or the other has not been
                ' found then low will be >= high)
                tmp = sortarray(low)
                sortarray(low) = sortarray(high)
                sortarray(high) = tmp
            End If
            low = low + 1
            high = high - 1
            'We continue until high and low collide
        End If
    Loop

    'These are the recursive calls designed to sort
    ' two halves after high and low have collided
    If lower < high Then Quick_Sort lower, high
    If low < upper Then Quick_Sort low, upper
End Sub

'======================================================
' Discussions of the Heap Sort revolve around nodes
'   and sifting. The method defies simple explanation.
'======================================================
Private Sub Heap_Sort()
    Dim j%, tmp%

    'Note: j = MAX - (MAX - MIN) \ 2
    j = Last1 - Last1 \ 2
    
    Do Until j >= Last1
        SiftUp Last1, j, 0
        j = j + 1
    Loop

    For j = 0 To Last1 - 1
        If sortarray(Last1) < sortarray(j) Then
            tmp = sortarray(Last1)
            sortarray(Last1) = sortarray(j)
            sortarray(j) = tmp
            
            SiftUp Last1, Last1 - 1, j
        End If
    Next
End Sub
Private Sub SiftUp(first%, ByVal midl%, last%)
    Dim k%, k1%, m1%, tmp%
    
    k = (midl - first) * 2 + first
    Do While k >= last
        If k > last Then
            k1 = k + 1
            If sortarray(k) < sortarray(k1) Then
                k = k - 1
            End If
        End If
        
        k1 = k + 1
        m1 = midl + 1
        
        If sortarray(k1) < sortarray(m1) Then
            tmp = sortarray(k1)
            sortarray(k1) = sortarray(m1)
            sortarray(m1) = tmp
        Else
            Exit Do
        End If
        midl = k
        k = (midl - first) * 2 + first
    Loop
End Sub

Private Sub Command1_Click(Index As Integer)
    Caption = Command1(Index).Caption
    
    Select Case Index
        Case BUBBLE: Bubble_Sort
        Case BIBUBBLE: BiBubble_Sort
        Case SHELLS: Shell_Sort
        Case INSERTION: Insertion_Sort
        Case SELECTION: Selection_Sort
        Case BISELECTION: BiSelection_Sort
        Case QUICK: Quick_Sort 0, Last1
        Case HEAP: Heap_Sort
    End Select
    
    ShowArray
End Sub

'Randomize the Array
Private Sub Command2_Click()
    Dim j%, k%
    Dim c As New Collection
    
    Randomize
    Last1 = MAX - MIN
    ReDim sortarray(Last1)
    
    For j = MIN To MAX
        c.Add j
    Next
    
    Do While c.Count > 0
        j = Int(c.Count * Rnd) + 1
        sortarray(k) = CInt(c.Item(j))
        c.Remove j
        k = k + 1
    Loop
    
    Caption = "Ascend Sorting"
    ShowArray
End Sub

Private Sub ShowArray()
    Dim j%
    
    Cls
    For j = 0 To Last1
         Print sortarray(j)
    Next
End Sub

Private Sub Form_Load()
    Const MARGIN = 200, HGHT = 300, WDTH = 1600
    Dim j%, lt!, tp!
    
    Move 1000, 1000, 4800, 3600
    tp = MARGIN
    lt = Width - (WDTH + MARGIN) * 2
    
    For j = 0 To 7
        If j Then Load Command1(j)
        
        With Command1(j)
            .Move lt, tp, WDTH, HGHT
            .FontBold = True
            Select Case j
                Case BUBBLE: .Caption = "Bubble Sort"
                Case BIBUBBLE: .Caption = "BiBubble Sort"
                Case INSERTION: .Caption = "Insertion Sort"
                Case SHELLS: .Caption = "Shell Sort"
                Case SELECTION: .Caption = "Selection Sort"
                Case BISELECTION: .Caption = "BiSelection Sort"
                Case QUICK: .Caption = "Quick Sort"
                Case HEAP: .Caption = "Heap Sort"
            End Select
            .Visible = True
        End With
        
        If j = 3 Then
            lt = lt + MARGIN + WDTH
            tp = MARGIN
        Else
            tp = tp + HGHT + MARGIN
        End If
    Next
    
    lt = lt - MARGIN - WDTH
    With Command2
        .Move lt, tp, WDTH * 2 + MARGIN, HGHT
        .FontBold = True
        .Caption = "Randomize"
    End With
        
    AutoRedraw = True
    FontBold = True
    Command2_Click
End Sub