Option Explicit

Const IHI = 32766
Const ELEMENTS = 1000
Const BUTTONS = 4
Const MAXFUNC = 10
Const UNIT = 300, MARGIN = 100
Const TITLEBAR = 295, BOARDER = 60
Const ORANGE = &H80C0FF
Const ICL = "Include"
Const TIME_MS = 1

Private Type SMPTE
    hour As Byte
    min As Byte
    sec As Byte
    frame As Byte
    fps As Byte
    dummy As Byte
    pad(2) As Byte
End Type
Private Type MMTIME
    wType As Long
    units As Long
    smpteVal As SMPTE
    songPtrPos As Long
End Type

Private Declare Function timeGetSystemTime& _
    Lib "winmm.dll" (lpTime As MMTIME, ByVal uSize&)

Dim mmt As MMTIME, L1 As Long
Dim confirmtotal As Long
Dim ascend As Integer, last1 As Integer
Dim sorts(MAXFUNC) As String
Dim captions(3) As String

Dim startarray(IHI) As Integer
Dim sortarray(IHI) As Integer

Private Sub Command1_MouseUp(Index%, Button%, Shift%, X!, Y!)
    Select Case Index
        Case 0: Reset Button
        Case 1: UpDn Index
        Case 2: DoTimings
        Case 3: IncALL
        Case Else: Toggle Index, Button
    End Select
End Sub

Private Sub Form_Load()
    Dim i%, j%
    Dim leftloc%, toploc%
    
    ascend = 1
    last1 = ELEMENTS - 1
    mmt.wType = TIME_MS
    L1 = LenB(mmt)
    
    Form1.Height = BOARDER * 2 + TITLEBAR + _
                (UNIT + MARGIN) * (MAXFUNC + 3)
    Form1.Width = (MARGIN + BOARDER) * 2 + _
                 UNIT * 15 + MARGIN * 4
    Form1.BackColor = vbButtonShadow
    Form1.Caption = "Sorting Timer"
    
    addButton "Randomize", _
          "Right click for all different numbers"
    addButton "Ascend", "Click for Descending"
    addButton "Timings", "Perform Timings"
    
    toploc = MARGIN + UNIT
    leftloc = BOARDER + MARGIN
    Text1.Top = toploc
    Text1.Left = leftloc + (MARGIN + UNIT * 4) * 3
    Text1.Height = UNIT
    Text1.Width = UNIT * 3
    Text1.Text = Str$(ELEMENTS)
    
    sorts(0) = "Bubble"
    sorts(1) = "Bi-Bubble"
    sorts(2) = "Count"
    sorts(3) = "Heap"
    sorts(4) = "Insertion"
    sorts(5) = "Interpolate"
    sorts(6) = "Merge"
    sorts(7) = "Quick"
    sorts(8) = "Selection"
    sorts(9) = "Shell"
    
    captions(0) = "Sort Type"
    captions(1) = "Millisecs"
    captions(2) = "Verified"
    captions(3) = "Elements"
    
    toploc = BOARDER + (MARGIN + UNIT) * 2
    For j = 0 To MAXFUNC
        i = j + 3
        Load Command1(i)
        Command1(i).Top = toploc + (MARGIN + UNIT) * j
        Command1(i).Left = leftloc
        Command1(i).Height = UNIT
        Command1(i).Width = UNIT * 3
        Command1(i).FontBold = True
        If j Then
            Command1(i).ToolTipText = _
                         "Right click for only this"
            Command1(i).Caption = ICL
        Else
            Command1(i).ToolTipText = _
                          "Include all methods"
            Command1(i).Caption = "ALL"
        End If
        Command1(i).Visible = True
    Next
    DoEvents
    
    toploc = BOARDER + MARGIN * 3 + UNIT * 3
    leftloc = BOARDER + MARGIN * 2 + UNIT * 3
    For j = 0 To MAXFUNC - 1
        If j Then Load Label1(j)
    
        Label1(j).Top = toploc + (MARGIN + UNIT) * j
        Label1(j).Left = leftloc
        Label1(j).Height = UNIT
        Label1(j).Width = UNIT * 5
        Label1(j).FontBold = True
        Label1(j).Caption = sorts(j)
        Label1(j).BackColor = vbButtonShadow
        Label1(j).Alignment = 1
        Label1(j).Visible = True
    Next
    DoEvents
    
    leftloc = BOARDER + MARGIN * 3 + UNIT * 8
    For j = 0 To MAXFUNC - 1
        i = j + MAXFUNC
        Load Label1(i)
        Label1(i).Top = toploc + (MARGIN + UNIT) * j
        Label1(i).Left = leftloc
        Label1(i).Height = UNIT
        Label1(i).Width = UNIT * 4
        Label1(i).FontBold = True
        Label1(i).Caption = ""
        Label1(i).Alignment = 1
        Label1(i).Visible = True
    Next
    DoEvents
    
    leftloc = BOARDER + MARGIN * 4 + UNIT * 12
    For j = 0 To MAXFUNC - 1
        i = j + MAXFUNC * 2
        Load Label1(i)
        Label1(i).Top = toploc + (MARGIN + UNIT) * j
        Label1(i).Left = leftloc
        Label1(i).Height = UNIT
        Label1(i).Width = UNIT * 3
        Label1(i).FontBold = True
        Label1(i).Caption = ""
        Label1(i).Visible = True
    Next
    DoEvents
    
    toploc = MARGIN * 3 + UNIT * 2
    leftloc = BOARDER + MARGIN * 2 + UNIT * 5
    For j = 0 To 3
        i = j + MAXFUNC * 3
        Load Label1(i)
        Label1(i).Top = toploc
        Label1(i).Left = leftloc + _
                  (MARGIN + UNIT * 3) * j
        Label1(i).Height = UNIT
        Label1(i).Width = UNIT * 3
        Label1(i).FontBold = True
        Label1(i).Alignment = 2
        Label1(i).Caption = captions(j)
        Label1(i).Visible = True
        
        Select Case j
            Case 0: leftloc = leftloc + UNIT
            Case 2: toploc = MARGIN
           leftloc = leftloc - UNIT * 3 - MARGIN
        End Select
    Next
    DoEvents
    
    Reset 1
End Sub


Private Sub addButton(s$, Optional tip$ = "")
    Static num%, j%
    
    If num Then Load Command1(num)
        
    Command1(num).Top = MARGIN
    Command1(num).Left = BOARDER + MARGIN + _
                      (MARGIN + UNIT * 4) * num
    Command1(num).Height = UNIT * 2
    Command1(num).Width = UNIT * 4
    Command1(num).ToolTipText = tip
    Command1(num).FontBold = True
    Command1(num).Caption = s
    Command1(num).Visible = True
    
    num = num + 1
End Sub

Private Sub changecolor(ByVal clr&)
    Static i%
    
    For i = 0 To MAXFUNC * 3 + 3
        Label1(i).BackColor = clr
    Next
    
    Form1.BackColor = clr
    DoEvents
End Sub

Private Sub Reset(ByVal b%)
    Static i%, j%, s!
    Static b1%
    
    changecolor ORANGE
    MousePointer = vbHourglass
    DoEvents
    
    If b = 0 Then b = b1
    s = CSng(last1 + 1)
    If b = 1 Then
        For i = 0 To last1
            Randomize
            startarray(i) = Int(s * Rnd)
        Next
    Else
        For i = 0 To last1
            sortarray(i) = i
            startarray(i) = -1
        Next
        For i = 0 To last1
            Randomize
            j = Int(s * Rnd)
            Do While startarray(j) >= 0
                j = j + 1
                If j > last1 Then j = 0
            Loop
            startarray(j) = sortarray(i)
        Next
    End If

    changecolor vbButtonShadow
    b1 = b
    MousePointer = vbDefault
End Sub


Private Sub UpDn(ByVal i%)
    If Command1(i).Caption = "Ascend" Then
        Command1(i).Caption = "Descend"
        Command1(i).ToolTipText = "Click for Ascending"
        ascend = -1
    Else
        Command1(i).Caption = "Ascend"
        Command1(i).ToolTipText = "Click for Descending"
        ascend = 1
    End If
End Sub
    
Private Sub IncALL()
    Dim i%
    For i = BUTTONS To MAXFUNC + BUTTONS - 1
        Command1(i).Caption = ICL
    Next
End Sub

    
Private Sub Toggle(ByVal i%, ByVal b%)
    Static j%, s$
    s = ICL
    
    If b = 1 Then
        If Command1(i).Caption = ICL Then s = "Exclude"
    Else
        For j = BUTTONS To MAXFUNC + BUTTONS - 1
            Command1(j).Caption = "Exclude"
        Next
    End If
    
    Command1(i).Caption = s
End Sub


Private Sub DoTimings()
    Static t1&, t2&, func%
    Static lower%, upper%
    Dim flag As Boolean
    
    Screen.MousePointer = vbHourglass
    changecolor vbButtonShadow
    
    For lower = MAXFUNC To MAXFUNC * 3 - 1
        Label1(lower).Caption = ""
    Next
    
    confirmtotal = 0
    For lower = 0 To last1
        confirmtotal = confirmtotal + startarray(lower)
    Next
    
    lower = 0: upper = last1
    
    func = 4
    If Command1(func).Caption = ICL Then
        Setup
        t1 = GetTime
        bubble_sort 0, last1
        t2 = GetTime
        flag = ShowTime(t1, t2, func)
    End If
    
    func = 5
    If Command1(func).Caption = ICL Then
        Setup
        t1 = GetTime
        bibubble_sort 0, last1
        t2 = GetTime
        flag = ShowTime(t1, t2, func)
    End If
    
    func = 6
    If Command1(func).Caption = ICL Then
        Setup
        t1 = GetTime
        count_sort 0, last1
        t2 = GetTime
        flag = ShowTime(t1, t2, func)
    End If
    
    func = 7
    If Command1(func).Caption = ICL Then
        Setup
        t1 = GetTime
        heap_sort 0, last1
        t2 = GetTime
        flag = ShowTime(t1, t2, func)
    End If
    
    func = 8
    If Command1(func).Caption = ICL Then
        Setup
        t1 = GetTime
        insert_sort 0, last1
        t2 = GetTime
        flag = ShowTime(t1, t2, func)
    End If
    
    func = 9
    If Command1(func).Caption = ICL Then
        Setup
        t1 = GetTime
        interp_sort 0, last1
        t2 = GetTime
        flag = ShowTime(t1, t2, func)
    End If
    
    func = 10
    If Command1(func).Caption = ICL Then
        Setup
        t1 = GetTime
        merge_sort 0, last1
        t2 = GetTime
        flag = ShowTime(t1, t2, func)
    End If
    
    func = 11
    If Command1(func).Caption = ICL Then
        Setup
        If ascend < 0 Then swapint lower, upper
        t1 = GetTime
        quick_sort lower, upper
        t2 = GetTime
        flag = ShowTime(t1, t2, func)
    End If
    
    func = 12
    If Command1(func).Caption = ICL Then
        Setup
        t1 = GetTime
        select_sort 0, last1, False
        t2 = GetTime
        flag = ShowTime(t1, t2, func)
    End If
    
    func = 13
    If Command1(func).Caption = ICL Then
        Setup
        t1 = GetTime
        shell_sort 0, last1
        t2 = GetTime
        flag = ShowTime(t1, t2, func)
    End If
    
    If flag Then
        For lower = 0 To last1
            startarray(lower) = sortarray(lower)
        Next
    
        changecolor ORANGE
    End If
    
    Screen.MousePointer = vbDefault
End Sub

Private Sub Setup()
    Static i%
    
    DoEvents
    For i = 0 To last1
        sortarray(i) = startarray(i)
    Next
End Sub

Private Function GetTime() As Long
    timeGetSystemTime mmt, L1
    GetTime = mmt.units
End Function
Private Function ShowTime(ByVal start&, _
             ByVal stopp&, ByVal i%) As Boolean
    i = i - BUTTONS
    Label1(i + MAXFUNC).Caption = _
                       Str$(stopp - start)
    DoEvents
    ShowTime = confirm(i)
    DoEvents
End Function

Private Function confirm(ByVal i%) As Boolean
    Static j%, s$
    Dim l&
    
    s = "success"
    confirm = True
    l = sortarray(last1)
    
    For j = 0 To last1 - 1
        l = l + sortarray(j)
        If sortarray(j) * ascend > sortarray(j + 1) * ascend Then
            s = "!order!"
            confirm = False
            Exit For
        End If
    Next
    
    If l <> confirmtotal Then
        s = "!total!"
        confirm = False
    End If
    
    Label1(i + MAXFUNC * 2).Caption = s
End Function

Private Function compar(ByVal n1%, ByVal n2%) As Boolean
        If sortarray(n1) > sortarray(n2) Then
            swap n1, n2
            compar = True
        Else
            compar = False
        End If
End Function

Private Function compar1(ByVal n1%, ByVal n2%) As Boolean
        compar1 = sortarray(n1) > sortarray(n2)
End Function

Private Sub swap(ByVal n1%, ByVal n2%)
    Static t1%
    
    t1 = sortarray(n1)
    sortarray(n1) = sortarray(n2)
    sortarray(n2) = t1
    
End Sub

Private Sub swapint(n1%, n2%)
    Static i%
    i = n1: n1 = n2: n2 = i
End Sub

' Necessary to avoid integer overflow
Private Function averag%(ByVal i1%, ByVal i2%)
    Dim L1&, L2&
    
    L1 = i1: L2 = i2
    L1 = (L1 + L2) \ 2
    
    averag = L1
End Function

Private Sub bubble_sort(ByVal lower%, ByVal upper%)
    Dim i%, j%
    Dim first%, last%, atmp%
    
    If ascend < 0 Then swapint lower, upper
    
    first = lower
    Do: last = upper - ascend: upper = -1
        i = first
        Do Until i * ascend > last * ascend
            atmp = sortarray(i)
            Do
                j = i + ascend
                If sortarray(j) >= atmp Then Exit Do
                sortarray(i) = sortarray(j)
                If upper < 0 Then
                    first = i - ascend
                    If first * ascend < _
                      lower * ascend Then first = lower
                End If
                upper = i
                i = i + ascend
            Loop Until i * ascend > last * ascend
            sortarray(i) = atmp
            i = i + ascend
        Loop
    Loop While upper > 0
End Sub


Private Sub bibubble_sort(ByVal lower%, ByVal upper%)
    Dim low%, high%
    Dim i%, j%, atmp%
    
    If ascend < 0 Then swapint lower, upper

    Do: high = upper - ascend
        upper = 0
        i = lower
        Do Until i * ascend > high * ascend
            atmp = sortarray(i)
            Do: j = i + ascend
                If sortarray(j) >= atmp Then Exit Do
                sortarray(i) = sortarray(j)
                upper = i
                i = i + ascend
            Loop Until i * ascend > high * ascend
            sortarray(i) = atmp
            i = i + ascend
        Loop
        If upper = 0 Then Exit Do

        low = lower + ascend
        lower = 0
        i = upper
        Do Until i * ascend < low * ascend
            atmp = sortarray(i)
            Do
                j = i - ascend
                If sortarray(j) <= atmp Then Exit Do
                sortarray(i) = sortarray(j)
                lower = i
                i = i - ascend
            Loop Until i * ascend < low * ascend
            sortarray(i) = atmp
            i = i - ascend
        Loop
    Loop While lower
End Sub

Private Sub count_sort(ByVal lower%, ByVal upper%)
    Dim i%, j%
    ReDim cnt(IHI) As Integer
    
    If ascend < 0 Then swapint lower, upper
    
    For i = lower To upper Step ascend
        cnt(sortarray(i)) = cnt(sortarray(i)) + 1
    Next
    
    i = lower
    j = 0
    Do Until i * ascend > upper * ascend
        Do Until cnt(j) <> 0
            j = j + 1
        Loop
        Do While cnt(j)
            sortarray(i) = j
            i = i + ascend
            cnt(j) = cnt(j) - 1
        Loop
    Loop
End Sub


Private Sub heap_sort(ByVal lower%, ByVal upper%)
    Dim n%, j%
    
    If ascend < 0 Then swapint lower, upper

    n = Abs(upper - lower) \ 2
    n = lower + n * ascend
    Do Until n * ascend <= lower * ascend
        siftUp lower, n, upper
        n = n - ascend
    Loop

    For n = upper + ascend To lower + 2 * ascend Step -ascend
        j = n - ascend
        If compar(lower, j) Then
            siftUp lower, lower + ascend, j
        End If
    Next
End Sub
Private Sub siftUp(ByVal first%, ByVal mid%, last%)
    Dim j%, k%
    Dim j1%, k1%
    
    j = mid
    k = sift1(j, first)
    Do While k * ascend <= last * ascend
        If (k * ascend < last * ascend) Then
            k1 = k - ascend
            If compar1(k, k1) Then k = k + ascend
        End If
        
        k1 = k - ascend: j1 = j - ascend
        
        If compar(k1, j1) = False Then Exit Do
        j = k
        k = sift1(j, first)
    Loop
End Sub
' Necessary to avoid integer overflow
Private Function sift1(ByVal n1%, ByVal n2%)
    Dim j&, first&
    
    j = n1: first = n2
    j = (j - first) * 2 + first
    If j > IHI Then j = IHI
    
    sift1 = j
End Function


Private Sub insert_sort(ByVal lower%, ByVal upper%)
    Dim low%, high%
    Dim i%, atmp%
    
    If ascend < 0 Then swapint lower, upper
    
    For i = lower + ascend To upper Step ascend
        high = i
        atmp = sortarray(high)

        Do: low = high - ascend
            If sortarray(low) <= atmp Then Exit Do
            sortarray(high) = sortarray(low)
            high = low
        Loop Until high * ascend <= lower * ascend

        sortarray(high) = atmp
    Next
End Sub


Private Sub interp_sort(ByVal lower%, ByVal upper%)
    interp1_sort lower, upper
    insert_sort lower, upper
End Sub
Private Sub interp1_sort(ByVal lower%, ByVal upper%)
    
    select_sort lower, upper, True
    
    ReDim previous(lower To upper) As Integer
    Dim j%, k%
    Dim ip1%
    Dim dif1!, dif2!
    
    dif1 = CSng(upper - lower)
    dif2 = CSng(sortarray(upper) - sortarray(lower))
    previous(lower) = -1: previous(upper) = -1
    
    If ascend < 0 Then swapint lower, upper
    j = lower + ascend
    
    Do Until j = upper
        ip1 = Fix(Abs(dif1 * _
        CSng(sortarray(j) - sortarray(lower)) / dif2))
            
        ip1 = lower + ip1 * ascend
        
        If (j = ip1) Or previous(ip1) Then
            previous(j) = -1
            Do
                If j = lower Or j = upper Then Exit Do
                j = j + ascend
            Loop While previous(j)
        Else
            previous(ip1) = -1
            swap j, ip1
        End If
    Loop
End Sub

Private Sub merge_sort(ByVal lower%, ByVal upper%)
    Dim diff%
    diff = upper - lower
    
    If diff <= 0 Then Exit Sub
    
    Dim upper1%, lower1%
    upper1 = averag(lower, upper)
    lower1 = upper1 + 1

    merge_sort lower, upper1
    merge_sort lower1, upper
    
    Dim i%, j%, lowerx%
    Dim flag As Boolean, atmp%
    
    If ascend < 0 Then
        swapint lower, upper
        swapint lower1, upper1
    End If
    
    If diff = 1 Then
        compar lower, upper
        Exit Sub
    End If
    
    lowerx = lower

    Do While lower1 * ascend <= upper * ascend
        If compar(lowerx, lower1) Then
            i = lower1
            atmp = sortarray(i)
            Do Until i * ascend >= upper * ascend
                j = i + ascend
                If atmp <= sortarray(j) Then Exit Do
                sortarray(i) = sortarray(j)
                i = i + ascend
            Loop
            sortarray(i) = atmp
            flag = True
        End If
        
        lowerx = lowerx + ascend
        If lowerx * ascend >= lower1 * ascend Then
            lower1 = lowerx
            lower = lower + ascend
            lowerx = lower
            If Not flag Then Exit Do
            flag = False
        End If
    Loop
End Sub


Private Sub quick_sort(ByVal lower%, ByVal upper%)
    If lower * ascend >= upper * ascend Then Exit Sub
    
    Dim low%, mid%, high%
    Dim vmid%
    
    low = lower
    high = upper
    mid = averag(lower, upper)
   
    vmid = sortarray(mid)
 
    Do While (low * ascend <= high * ascend)
        Do
            If low * ascend >= upper * ascend Then Exit Do
            If sortarray(low) >= vmid Then Exit Do
            low = low + ascend
        Loop
     
        Do
            If high * ascend <= lower * ascend Then Exit Do
            If vmid >= sortarray(high) Then Exit Do
            high = high - ascend
        Loop
 
        If low * ascend <= high * ascend Then
            If low * ascend < high * ascend Then
                swap low, high
            End If
            low = low + ascend
            high = high - ascend
        End If
    Loop
   
    If (lower * ascend < high * ascend) Then
        quick_sort lower, high
    End If
    If (low * ascend < upper * ascend) Then
        quick_sort low, upper
    End If
End Sub


Private Sub select_sort(ByVal lower%, ByVal upper%, _
                          interpolating As Boolean)
    Dim j%, min%, max%
    
    If ascend < 0 Then swapint lower, upper
    
    Do Until lower * ascend >= upper * ascend
        If compar1(lower, upper) Then
            max = lower
            min = upper
        Else
            max = upper
            min = lower
        End If
        
        For j = lower + ascend To upper - ascend Step ascend
            If compar1(min, j) Then
                min = j
            ElseIf compar1(j, max) Then
                max = j
            End If
        Next
        
        If max <> upper Then
            If min = upper Then min = max
            swap max, upper
        End If
        
        If min <> lower Then swap lower, min
        
        lower = lower + ascend
        upper = upper - ascend
        If interpolating Then Exit Do
    Loop
End Sub


Private Sub shell_sort(ByVal lower%, ByVal upper%)
    Dim diff%, high1%, atmp%
    Dim high%, low%
    
    diff = Abs(upper - lower): GoSub sh1
    If ascend < 0 Then swapint lower, upper
    
    Do While diff
        high = lower + diff * ascend
        For high = high To upper Step ascend
            Do Until high * ascend > upper * ascend
                low = high - diff * ascend
                If compar(low, high) = False Then
                    Exit Do
                End If
                If diff = 1 Then
                    If low * ascend > lower * ascend Then
                        high = low
                    End If
                Else
                    high = high + ascend
                End If
            Loop
        Next
        
        GoSub sh1
    Loop
    Exit Sub
sh1: diff = Int(CSng(diff) / 1.3): Return
End Sub

Private Sub Text1_KeyUp(KeyCode%, Shift%)
    If KeyCode = vbKeyReturn Then Command1(2).SetFocus
End Sub

Private Sub Text1_LostFocus()
    Dim d As Double, i%
    
    d = Val(Text1.Text)
    If d < 100 Or d > IHI Then
        i = last1 + 1
    Else
        i = CInt(d)
        last1 = i - 1
        Reset 0
    End If
    
    Text1.Text = Str$(i)
End Sub