 The
base application shown here was obtained over the web, from an unknown author.
The actual application consists of 2 parts - the first, a
simple 30-element sort comparison (in the upper frame), and the second a more intense speed comparison between the 4 sort methods
presented.
I have added code to display the actual number of times
(iterations) the various routines swapped values; this code is commented and should be removed for any actual implementation of
any sort method here.
In addition, because the Bubble and Selection sorts can
take a very long time with a large number of items to sort, I have added "Skip" buttons to abort that aspect of the
speed test. I realize that the addition of DoEvents somewhat skews the time reported to perform the Bubble and Selection sorts,
but not as much as you might think. As this is a complex form, I've tried to
make things as simple as possible.
To a form, add three frames (Frame1, 2 & 3), eight command buttons
(Command1 through Command8), one text box (Text1), and sixteen labels
(Label1 through Label16). Set the label's autosize to True before pasting
additional copies. The form load event takes care of positioning and
parenting the controls into the respective form, as well as aligning the
forms and exterior controls. If your system uses small fonts on your system
the form will look like the illustration. Large font users will have to
tweak the values in the form load to allow for the larger text. |
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'variables for the Quick sort
'iteration as the sub is recursive
Private QSCallCnt As Long
Private QSSwaps As Long
'used to abandon long sorts
Private SkipFlag As Long
Private tmrCounter As Long 'used for the counter in the speed test
Private sortMethod As Long 'flag for the timer
Private Sub Form_Load()
Randomize
Me.Width = 8500
'FRAME 1 CONTROLS .......
With Frame1
.Caption = "Perform sort of 30 random elements"
.Move 200, 200, Me.ScaleWidth - 350, 1600
End With
Label1.Caption = "Unsorted:"
Set Label1.Container = Frame1
Label1.Move 200, 300
Label2.Caption = "Sorted:"
Set Label2.Container = Frame1
Label2.Move 200, 600
Label3.Caption = ""
Set Label3.Container = Frame1
Label3.Move 1000, 300
Label4.Caption = ""
Label4.ForeColor = RGB(0, 0, 212)
Set Label4.Container = Frame1
Label4.Move 1000, 600
Command1.Caption = "Bubble Sort"
Set Command1.Container = Frame1
Command1.Move 1000, 1050, 1400
Command2.Caption = "Selection Sort"
Set Command2.Container = Frame1
Command2.Move 2550, 1050, 1400
Command3.Caption = "Shell Sort"
Set Command3.Container = Frame1
Command3.Move 4100, 1050, 1400
Command4.Caption = "Quick Sort"
Set Command4.Container = Frame1
Command4.Move 5700, 1050, 1400
'FRAME 2 CONTROLS .......
With Frame2
.Caption = "Perform Speed Comparison"
.Move 200, 2000, Me.ScaleWidth - 3100, 2550
End With
Label5.Caption = "Number of Random Elements:"
Set Label5.Container = Frame2
Label5.Move 200, 350
Text1.Text = "1000"
Set Text1.Container = Frame2
Text1.Move 2400, 300, 600
Command5.Caption = "Speed Test"
Set Command5.Container = Frame2
Command5.Move 4000, 260, 1100
Label6.Caption = "Speed Test Status:"
Set Label6.Container = Frame2
Label6.Move 200, 800
Label7.Caption = ""
Label7.ForeColor = RGB(0, 0, 212)
Set Label7.Container = Frame2
Label7.Move 1800, 800
Label8.Caption = "Bubble Sort time taken :"
Set Label8.Container = Frame2
Label8.Move 200, 1100
Command6.Caption = "Skip"
Set Command6.Container = Frame2
Command6.Move 4000, 1050, 1100, 305
Label9.Caption = "Selection Sort time taken :"
Set Label9.Container = Frame2
Label9.Move 200, 1400
Command7.Caption = "Skip"
Set Command7.Container = Frame2
Command7.Move 4000, 1350, 1100, 305
Label10.Caption = "Shell Sort time taken :"
Set Label10.Container = Frame2
Label10.Move 200, 1700
Label11.Caption = "Quick Sort time taken :"
Set Label11.Container = Frame2
Label11.Move 200, 2000
'FRAME 3 CONTROLS .......
With Frame3
.Caption = "Iteration Comparison"
.Move 5525, 2000, 2700, 2550
End With
Label12.Caption = ""
Set Label12.Container = Frame3
Label12.Move 200, 1100
Label13.Caption = ""
Set Label13.Container = Frame3
Label13.Move 200, 1400
Label14.Caption = ""
Set Label14.Container = Frame3
Label14.Move 200, 1700
Label15.Caption = ""
Set Label15.Container = Frame3
Label15.Move 200, 2000
Label16.Caption = ""
Set Label16.Container = Frame3
Label16.Move 200, 2170
'Exit button and final form setup .......
Command8.Caption = "Exit"
Command8.Width = 1600
Command8.Move (Frame3.Left + Frame3.Width) - Command8.Width, (Frame2.Top + Frame2.Height) + 100
Me.Height = Frame1.Height + Frame2.Height + 1500
Me.Caption = "VBnet Sorting Comparison Demo - Bubble/Selection/Shell/Quicksort"
Timer1.Interval = 1000
Timer1.Enabled = False
End Sub
Private Sub Command1_Click()
'Build an array of 30 random numbers and print
'values to the screen. Then pass array to sort
'proc and display the result.
Dim nArray(0 To 30) As Long
Dim cnt As Long
Dim buff As String
'fill an array with random numbers and display
For cnt = LBound(nArray) To UBound(nArray)
nArray(cnt) = Int(Rnd * 12) + 1
buff = buff & " " & nArray(cnt)
Next cnt
Label3.Caption = buff
Call BubbleSortNumbers(nArray)
'rebuild buff string and display
buff = ""
For cnt = LBound(nArray) To UBound(nArray)
buff = buff & " " & nArray(cnt)
Next cnt
Label4.Caption = buff
End Sub
Private Sub Command2_Click()
Dim nArray(0 To 30) As Long
Dim cnt As Long
Dim buff As String
'fill an array with random numbers and display
For cnt = LBound(nArray) To UBound(nArray)
nArray(cnt) = Int(Rnd * 12) + 1
buff = buff & " " & nArray(cnt)
Next cnt
Label3.Caption = buff
Call SelectionSortNumbers(nArray)
'rebuild buff string and display
buff = ""
For cnt = LBound(nArray) To UBound(nArray)
buff = buff & " " & nArray(cnt)
Next cnt
Label4.Caption = buff
End Sub
Private Sub Command3_Click()
Dim nArray(0 To 30) As Long
Dim cnt As Long
Dim buff As String
'fill an array with random numbers and display
For cnt = LBound(nArray) To UBound(nArray)
nArray(cnt) = Int(Rnd * 12) + 1
buff = buff & " " & nArray(cnt)
Next cnt
Label3.Caption = buff
Call ShellSortNumbers(nArray)
'rebuild buff string and display
buff = ""
For cnt = LBound(nArray) To UBound(nArray)
buff = buff & " " & nArray(cnt)
Next cnt
Label4.Caption = buff
End Sub
Private Sub Command4_Click()
Dim nArray(0 To 30) As Long
Dim cnt As Long
Dim buff As String
'fill an array with random numbers and display
For cnt = LBound(nArray) To UBound(nArray)
nArray(cnt) = Int(Rnd * 12) + 1
buff = buff & " " & nArray(cnt)
Next cnt
Label3.Caption = buff
QSCallCnt = 0
QSSwaps = 0
Call QuickSortNumbers(nArray, 0, UBound(nArray))
'rebuild buff string and display
buff = ""
For cnt = LBound(nArray) To UBound(nArray)
buff = buff & " " & nArray(cnt)
Next cnt
Label4.Caption = buff
End Sub
Private Sub Command5_Click()
Dim cnt As Long
'the main array of random numbers
ReDim varray(0 To CLng(Text1.Text - 1)) As Long
'copies of the array for each routine
Dim vTemp1 As Variant
Dim vTemp2 As Variant
Dim vTemp3 As Variant
Frame1.Enabled = False
Label7.Caption = "Building array of " & Text1.Text & " elements ........."
For cnt = LBound(varray) To UBound(varray)
varray(cnt) = Int(Rnd * 100) + 1
Next cnt
vTemp1 = varray
vTemp2 = varray
vTemp3 = varray
'---------------------------------------------------------------------------
Label7.Caption = "Performing Bubble Sort ......"
sortMethod = 1
tmrCounter = 0
SkipFlag = False
Command6.Enabled = True
Timer1.Enabled = True
Call BubbleSortNumbers(varray)
Timer1.Enabled = False
Command6.Enabled = False
Label8.Caption = "Bubble Sort time taken : " & tmrCounter & " seconds"
'---------------------------------------------------------------------------
Label7.Caption = "Performing Selection Sort ......"
sortMethod = 2
tmrCounter = 0
SkipFlag = False
Command7.Enabled = True
Timer1.Enabled = True
Call SelectionSortNumbers(vTemp1)
Timer1.Enabled = False
Command7.Enabled = False
Label9.Caption = "Selection Sort time taken : " & tmrCounter & " seconds"
'---------------------------------------------------------------------------
Label7.Caption = "Performing Shell Sort ......"
sortMethod = 3
tmrCounter = 0
Timer1.Enabled = True
Call ShellSortNumbers(vTemp2)
Timer1.Enabled = False
Label10.Caption = "Shell Sort time taken : " & tmrCounter & " seconds"
'---------------------------------------------------------------------------
Label7.Caption = "Performing Quick Sort ......"
sortMethod = 4
tmrCounter = 0
Timer1.Enabled = True
Call QuickSortNumbers(vTemp3, 0, UBound(vTemp3))
Timer1.Enabled = False
Label11.Caption = "Quick Sort time taken : " & tmrCounter & " seconds"
'---------------------------------------------------------------------------
Label7.Caption = "Speed Test Complete."
Frame1.Enabled = True
End Sub
Private Sub Command6_Click()
SkipFlag = True
End Sub
Private Sub Command7_Click()
SkipFlag = True
End Sub
Private Sub Command8_Click()
Unload Me
End Sub
Private Sub Timer1_Timer()
tmrCounter = tmrCounter + 1
Select Case sortMethod
Case 1
Label8.Caption = "Bubble Sort time taken : " & tmrCounter & " seconds"
Case 2
Label9.Caption = "Selection Sort time taken : " & tmrCounter & " seconds"
Case 3
Label10.Caption = "Shell Sort time taken : " & tmrCounter & " seconds"
Case 4
Label11.Caption = "Quick Sort time taken : " & tmrCounter & " seconds"
Case Else
End Select
End Sub
Private Sub BubbleSortNumbers(varray As Variant)
Dim cnt1 As Long
Dim cnt2 As Long
Dim tmp As Long
Dim counter As Long
Label12.Caption = "Working..."
For cnt1 = UBound(varray) To LBound(varray) Step -1
For cnt2 = LBound(varray) + 1 To cnt1
If varray(cnt2 - 1) > varray(cnt2) Then
tmp = varray(cnt2 - 1)
varray(cnt2 - 1) = varray(cnt2)
varray(cnt2) = tmp
'-----------------------------
'Required for the speed Test;
'comment out for real use
counter = counter + 1
DoEvents
If SkipFlag Then Exit For
'----------------------------
End If
Next cnt2
Next cnt1
Label12.Caption = "Elements swapped : " & counter
End Sub
Private Sub QuickSortNumbers(varray As Variant, inLow As Long, inHigh As Long)
'varray() The varray to sort
'inLow First element of varray to start sort
'inHigh Last element of varray to start sort
'----------------------------------------------------
'update the call count label; comment out for real use
QSCallCnt = QSCallCnt + 1
'----------------------------------------------------
Dim pivot As Long
Dim tmpSwap As Long
Dim tmpLow As Long
Dim tmpHigh As Long
tmpLow = inLow
tmpHigh = inHigh
pivot = varray((inLow + inHigh) / 2)
While (tmpLow <= tmpHigh)
While (varray(tmpLow) < pivot And tmpLow < inHigh)
tmpLow = tmpLow + 1
Wend
While (pivot < varray(tmpHigh) And tmpHigh > inLow)
tmpHigh = tmpHigh - 1
Wend
If (tmpLow <= tmpHigh) Then
tmpSwap = varray(tmpLow)
varray(tmpLow) = varray(tmpHigh)
varray(tmpHigh) = tmpSwap
tmpLow = tmpLow + 1
tmpHigh = tmpHigh - 1
'----------------------------------------------------
'update the swap count label ; comment out for real use
QSSwaps = QSSwaps + 1
'----------------------------------------------------
End If
Wend
If (inLow < tmpHigh) Then QuickSortNumbers varray, inLow, tmpHigh
If (tmpLow < inHigh) Then QuickSortNumbers varray, tmpLow, inHigh
Label15.Caption = "Sub was called : " & QSCallCnt & " times"
Label16.Caption = "Elements Swapped : " & QSSwaps
End Sub
Private Sub SelectionSortNumbers(varray As Variant)
Dim cnt1 As Long
Dim cnt2 As Long
Dim nMin As Long
Dim tmp As Long
Dim counter As Long
Label13.Caption = "Working..."
For cnt1 = LBound(varray) To UBound(varray) - 1
nMin = cnt1
For cnt2 = (cnt1 + 1) To UBound(varray)
If varray(cnt2) < varray(nMin) Then
nMin = cnt2
'----------------------------------------------------
'comment out for real use
'update the iterations label
counter = counter + 1
'----------------------------------------------------
End If
'----------------------------------------------------
'Required to enable abort of speed Test;
'comment out for real use
DoEvents
If SkipFlag Then Exit For
'----------------------------------------------------
Next cnt2
tmp = varray(nMin)
varray(nMin) = varray(cnt1)
varray(cnt1) = tmp
Next cnt1
Label13.Caption = "Elements swapped : " & counter
End Sub
Private Sub ShellSortNumbers(varray As Variant)
Dim cnt As Long
Dim tmp As Long
Dim nHold As Long
Dim nHValue As Long
Dim counter As Long
Label14.Caption = "Working..."
nHValue = LBound(varray)
Do
nHValue = 3 * nHValue + 1
Loop Until nHValue > UBound(varray)
Do
nHValue = nHValue / 3
For cnt = nHValue + LBound(varray) To UBound(varray)
tmp = varray(cnt)
nHold = cnt
Do While varray(nHold - nHValue) > tmp
varray(nHold) = varray(nHold - nHValue)
nHold = nHold - nHValue
'----------------------------------------------------
'Required for the speed Test; comment out for real use
'update the iterations label
counter = counter + 1
DoEvents
'----------------------------------------------------
If nHold < nHValue Then Exit Do
Loop
varray(nHold) = tmp
Next cnt
Loop Until nHValue = LBound(varray)
Label14.Caption = "Elements swapped : " & counter
End Sub
|
