//归并排序的,不知道哪里错了.大家帮忙给调试下,提点建议//
Dim r(101), m(101) As Integer
Private Function mergesort(n As Integer)
s = 1
Do While s < n
Call mergepass1(s, n)
s = 2 * s
Call mergepass2(s, n)
s = 2 * s
Loop
End Function
Private Function mergepass1(ByVal s As Integer, ByVal n As Integer)
i = 0
Do While i <= n - 2 * s
Call merge(i, i + s - 1, i + 2 * s - 1)
i = i + 2 * s
Loop
If i + s < n Then
Call merge(i, i + s - 1, n - 1)
Else
j = i
Do While j <= n - 1
m(j) = r(j)
j = j + 1
Loop
End If
End Function
Private Function mergepass2(ByVal s As Integer, ByVal n As Integer)
i = 0
Do While i <= n - 2 * s
Call merge(i, i + s - 1, i + 2 * s - 1)
i = i + 2 * s
Loop
If i + s < n Then
Call merge(i, i + s - 1, n - 1)
Else
j = i
Do While j <= n - 1
r(j) = m(j)
j = j + 1
Loop
End If
End Function
Private Function merge(ByVal l As Integer, ByVal x As Integer, ByVal y As Integer)
i = l
j = x + 1
k = l
Do While (i <= x And j <= y)
If r(i) <= r(j) Then
m(k) = r(i)
k = k + 1
i = i + 1
Else
m(k) = r(j)
k = k + 1
j = j + 1
End If
Loop
If i > x Then
q = j
Do While q <= y
m(k) = r(q)
k = k + 1
q = q + 1
Loop
Else
q = i
Do While q <= x
m(k) = r(q)
k = k + 1
q = q + 1
Loop
End If
End Function
Private Sub Command1_Click()
Call mergesort(5)
For i = 1 To 5
Print r(i)
Next
Print
End Sub
Private Sub Form_Activate()
For i = 1 To 5
r(i) = Int(90 * Rnd + 10)
Print r(i)
Next
'-----------------------------------------------------------------------
'堆栈 (stack) - FOR LONG DATA TYPE
'数据结构中的 Stack, 有Push、Pop、Peek等方法
'
'LastUpdate:2004-1-23
'by Kwanhong Young (r4c Studio)
'-----------------------------------------------------------------------
Private sItem() As Long
Private iCount As Long
Private Sub Class_Initialize()
'//start...
ReDim sItem(0)
iCount = 0
End Sub
Private Sub Class_Terminate()
'//over
ReDim sItem(0)
iCount = 0
End Sub
Public Sub Push(ByVal vValue As Long)
sItem(iCount) = vValue
iCount = iCount + 1
ReDim Preserve sItem(iCount)
End Sub
Public Function Pop() As Long
If iCount > 0 Then
iCount = iCount - 1
Pop = sItem(iCount)
ReDim Preserve sItem(iCount)
End If
End Function
Public Function Peek() As Long
If iCount > 0 Then Peek = sItem(iCount - 1)
End Function
Public Property Get Count() As Long
Count = iCount
End Property
Public Sub GetAllItem(itm() As Long)
ReDim itm(iCount)
Dim i As Long
For i = 0 To iCount - 1
itm(i) = sItem(i)
Next
End Sub
Public Function GetAllItem_toString(Optional ByVal cDelimiter As String = "|") As String
If iCount = 0 Then Exit Function
GetAllItem_toString = Join(sItem, cDelimiter) '//VB6
'//--------------------------------------------- //VB5
'Dim i As Long
'Dim strTmp As String
'For i = 0 To iCount - 1
' strTmp = strTmp & sItem(i) & cDelimiter
'Next
'GetAllItem_toString = Left(strTmp, Len(strTmp) - 1)
'///////////////////////////////////////////////////////////////
'// QucikSort_V2 function class
'//
'// LastUpdate:2004-1-22
'// by Kwanhong Young (r4c Studio)
'///////////////////////////////////////////////////////////////
Private stack As cStack_long
Private Sub Class_Initialize()
Set stack = New cStack_long
End Sub
Private Sub Class_Terminate()
Set stack = Nothing
End Sub
Public Sub StartSort_Long(vArray() As Long)
Dim iLow As Long
Dim iHi As Long
'//get range of array
iLow = LBound(vArray) '//Low bound
iHi = UBound(vArray) '//High bound
'//push low value to stack first
stack.Push iLow
stack.Push iHi
'//use STACK, not RECURSION
Do
iHi = stack.Pop
iLow = stack.Pop
QuickSort_Long vArray(), iLow, iHi '//call the procedure
Loop Until stack.Count = 0
End Sub
Private Sub QuickSort_Long(vArray() As Long, iLow As Long, iHi As Long)
'//QuickSort procedure
'//vArray() The array to sort
'//iLow Lower bound of sort point
'//iHi Upper bound of sort point
Dim iMid As Long '//middle value
Dim tmpSwap As Long '//variou for swap function
'//two working pointer
Dim tmpLow As Long
Dim tmpHi As Long
'//Save to the working pointer
tmpLow = iLow
tmpHi = iHi
'//Get middle value
iMid = vArray((iLow + iHi) \ 2)
Do While (tmpLow <= tmpHi)
'//look up the first value that large than MIDDLE
Do While (vArray(tmpLow) < iMid And tmpLow < iHi)
tmpLow = tmpLow + 1
Loop
'//loop up the first value the small than MIDDLE
Do While (iMid < vArray(tmpHi) And tmpHi > iLow)
tmpHi = tmpHi - 1
Loop
'//swap the two items.
If (tmpLow <= tmpHi) Then
tmpSwap = vArray(tmpLow)
vArray(tmpLow) = vArray(tmpHi)
vArray(tmpHi) = tmpSwap
'//swap ok
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1
End If
Loop
'//do the remain - RECURSION METHOD
'If (iLow < tmpHi) Then QuickSort_Long vArray, iLow, tmpHi
'If (tmpLow < iHi) Then QuickSort_Long vArray, tmpLow, iHi
'//do the remain - STACK METHOD
If (tmpLow < iHi) Then
stack.Push tmpLow
stack.Push iHi
End If
If (iLow < tmpHi) Then
stack.Push iLow
stack.Push tmpHi
End If
End Sub
'----------------------------------------- FOR STRING DATA TYPE ------------------------------------
Public Sub StartSort_String(vArray() As String)
Dim iLow As Long
Dim iHi As Long
'//get range of array
iLow = LBound(vArray) '//Low bound
iHi = UBound(vArray) '//High bound
'//push low value to stack first
stack.Push iLow
stack.Push iHi
'//use STACK, not RECURSION
Do
iHi = stack.Pop
iLow = stack.Pop
QuickSort_String vArray(), iLow, iHi '//call the procedure
Loop Until stack.Count = 0
End Sub
Private Sub QuickSort_String(vArray() As String, iLow As Long, iHi As Long)
'//QuickSort procedure
'//vArray() The array to sort
'//iLow Lower bound of sort point
'//iHi Upper bound of sort point
Dim iMid As String '//middle value
Dim tmpSwap As String '//variou for swap function
'//two working pointer
Dim tmpLow As Long
Dim tmpHi As Long
'//Save to the working pointer
tmpLow = iLow
tmpHi = iHi
'//Get middle value
iMid = vArray((iLow + iHi) \ 2)
Do While (tmpLow <= tmpHi)
'//look up the first value that large than MIDDLE
Do While (vArray(tmpLow) < iMid And tmpLow < iHi)
tmpLow = tmpLow + 1
Loop
'//loop up the first value the small than MIDDLE
Do While (iMid < vArray(tmpHi) And tmpHi > iLow)
tmpHi = tmpHi - 1
Loop
'//swap the two items.
If (tmpLow <= tmpHi) Then
tmpSwap = vArray(tmpLow)
vArray(tmpLow) = vArray(tmpHi)
vArray(tmpHi) = tmpSwap
'//swap ok
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1
End If
Loop
'//do the remain - STACK METHOD
If (tmpLow < iHi) Then
stack.Push tmpLow
stack.Push iHi
End If
If (iLow < tmpHi) Then
stack.Push iLow
stack.Push tmpHi
End If
//不好意思,把全部的都发了,发错了.下边是归并的//
Dim r(101), m(101) As Integer
Private Sub mergesort(r() As Integer, n As Integer)
Dim m(101) As Integer
s = 1
Do While s < n
Call mergepass(r(), m(), s, n)
s = 2 * s
Call mergepass(m(), r(), s, n)
s = 2 * s
Loop
End Sub
Private Sub mergepass(r() As Integer, m() As Integer, ByVal s As Integer, ByVal n As Integer)
i = 0
Do While i <= n - 2 * s
Call merge(r(), m(), i, i + s - 1, i + 2 * s - 1)
i = i + 2 * s
Loop
If i + s < n Then
Call merge(r(), m(), i, i + s - 1, n - 1)
Else
j = i
Do While j <= n - 1
m(j) = r(j)
j = j + 1
Loop
End If
End Sub
Private Function merge(r() As Integer, m() As Integer, ByVal l As Integer, ByVal x As Integer, ByVal y As Integer)
i = l
j = x + 1
k = l
Do While (i <= x And j <= y)
If r(i) <= r(j) Then
m(k) = r(i)
k = k + 1
i = i + 1
Else
m(k) = r(j)
k = k + 1
j = j + 1
End If
Loop
If i > x Then
q = j
Do While q <= y
m(k) = r(q)
k = k + 1
q = q + 1
Loop
Else
q = i
Do While q <= x
m(k) = r(q)
k = k + 1
q = q + 1
Loop
End If
End Function
Private Sub Command1_Click()
Dim r(101) As Integer
Randomize
For i = 0 To 9
r(i) = Int(90 * Rnd + 10)
Print r(i)
Next
Print
Call mergesort(r(), 10)
For i = 0 To 9
Print r(i)
Next
Print
End Sub
//归并可以了。大家再帮看看基数的。这个在VC++里用到了指针,大家看在VB里怎么搞.谢谢//
//这个是搞好的归并的//
Dim pivotpos As Integer
Dim r(101), m(101) As Integer
Private Sub Command1_Click()
i = 1
Do While i <= 8
c = r(i)
j = i
Do While (j > 0 And c < r(j - 1))
r(j) = r(j - 1)
j = j - 1
Loop
r(j) = c
i = i + 1
Loop
For i = 1 To 8
Me.Print r(i)
Next
Print
End Sub
Private Sub Command2_Click()
i = 1
Do While i <= 8
j = 1
Do While j <= 8 - i
If r(j) > r(j + 1) Then
c = r(j)
r(j) = r(j + 1)
r(j + 1) = c
End If
j = j + 1
Loop
i = i + 1
Loop
For i = 1 To 8
Print r(i)
Next
Print
End Sub
Private Sub Command3_Click()
Call quicksort(1, 8)
For i = 1 To 8
Print r(i)
Next
Print
End Sub
Private Sub Command4_Click()
Dim i As Integer
Call heapsort(9)
For i = 1 To 8
Print r(i)
Next
Print
End Sub
Private Sub Command5_Click() '有问题
Dim r(101) As Integer
Randomize
For i = 0 To 9
r(i) = Int(90 * Rnd + 10)
Print r(i)
Next
Print
Call mergesort(r(), 10)
For i = 0 To 9
Print r(i)
Next
Print
End Sub
Private Sub Form_Activate()
Dim i As Integer
For i = 1 To 8
r(i) = Int(90 * Rnd + 10)
Print r(i)
Next
Print
End Sub
Private Function quicksort(low As Integer, high As Integer) '快速排序
Dim i, j, t As Integer
If (low < high) Then
i = low
j = high
t = r(low)
Do While i < j
Do While i < j And r(j) > t
j = j - 1
Loop
If i < j Then
r(i) = r(j)
i = i + 1
End If
Do While i < j And r(i) <= t
i = i + 1
Loop
If i < j Then
r(j) = r(i)
j = j - 1
End If
Loop
r(i) = t
Call quicksort(low, i - 1)
Call quicksort(i + 1, high)
End If
End Function
Private Function sift(ByVal n As Integer, ByVal s As Integer) '渗透建堆
Dim t, k, j As Integer
t = r(s)
k = s
j = 2 * k + 1
Do While j < n
If j < n - 1 And r(j) < r(j + 1) Then
j = j + 1
End If
If (t < r(j)) Then
r(k) = r(j)
k = j
j = 2 * k + 1
Else
GoTo mmm
End If
Loop
mmm: r(k) = t
End Function
Private Function heapsort(ByVal n As Integer) '堆排序
Dim k, t, i As Integer
i = n / 2 - 1
Do While i >= 0
Call sift(n, i)
i = i - 1
Loop
k = n - 1
Do While k >= 1
t = r(0)
r(0) = r(k)
r(k) = t
Call sift(k, 0)
k = k - 1
Loop
End Function
Private Sub mergesort(r() As Integer, n As Integer)
Dim m(101) As Integer
s = 1
Do While s < n
Call mergepass(r(), m(), s, n)
s = 2 * s
Call mergepass(m(), r(), s, n)
s = 2 * s
Loop
End Sub
Private Sub mergepass(r() As Integer, m() As Integer, ByVal s As Integer, ByVal n As Integer)
i = 0
Do While i <= n - 2 * s
Call merge(r(), m(), i, i + s - 1, i + 2 * s - 1)
i = i + 2 * s
Loop
If i + s < n Then
Call merge(r(), m(), i, i + s - 1, n - 1)
Else
j = i
Do While j <= n - 1
m(j) = r(j)
j = j + 1
Loop
End If
End Sub
Private Function merge(r() As Integer, m() As Integer, ByVal l As Integer, ByVal x As Integer, ByVal y As Integer)
i = l
j = x + 1
k = l
Do While (i <= x And j <= y)
If r(i) <= r(j) Then
m(k) = r(i)
k = k + 1
i = i + 1
Else
m(k) = r(j)
k = k + 1
j = j + 1
End If
Loop
If i > x Then
q = j
Do While q <= y
m(k) = r(q)
k = k + 1
q = q + 1
Loop
Else
q = i
Do While q <= x
m(k) = r(q)
k = k + 1
q = q + 1
Loop
End If