|
楼主 |
发表于 2013-1-14 17:15
|
显示全部楼层
本帖最后由 lee1892 于 2013-1-14 17:16 编辑
二叉堆的 类 代码实现
[code=vb]
' ====================================================================
' 二叉堆的 类 实现演示
' By Lee1892, 2013.01.14
' --------------------------------------------------------------------
' 属性:
' HeapType 最大/最小堆,允许设定一次,可读写
' Count 元素数量,只读
' Item (参数:元素序号)返回元素值
' HeapTop 返回堆顶元素值
' AllData 返回全部元素数组
' --------------------------------------------------------------------
' 方法:
' Add 添加元素,返回该元素在堆中的位置
' ExtracTop 返回并删除堆顶元素
' DeleteByIndex (参数:元素序号)删除元素
' ModifyByIndex (参数:元素序号)更改元素值
' ====================================================================
Option Explicit
Public Enum HEAP_TYPE
bhMax = -1
bhMin = 0
End Enum
Private Const lngStep = 100
Private arrData() As Variant
Private ehtHeapType As HEAP_TYPE
Private lngCount As Long
Private blnTypeSetted As Boolean
Private lngLength As Long
Public Property Let HeapType(ByVal eHeapType As HEAP_TYPE)
If Not blnTypeSetted Then
ehtHeapType = eHeapType
Else
Err.Raise 10000, "Binary Heap Class", _
"Heap type can only be set once." & vbCrLf & _
"This Binary Heap Class has been set as " & _
IIf(ehtHeapType, "Max. Heap", "Min. Heap")
End If
End Property
Public Property Get HeapType() As HEAP_TYPE
HeapType = ehtHeapType
End Property
Public Property Get Count() As Long
Count = lngCount
End Property
Public Property Get Item(ByVal nIndex As Long) As Variant
If nIndex < 1 Or nIndex > lngCount Then
Err.Raise 10002, "Binary Heap Class", "Out of range."
Exit Sub
End If
Item = arrData(nIndex)
End Property
Public Property Get HeapTop() As Variant
If Not IsEmpty(arrData(1)) Then
HeapTop = arrData(1)
Else
Err.Raise 10001, "Binary Heap Class", "The heap top is empty!"
End If
End Property
Public Property Get AllData() As Variant
Dim aOutput() As Variant
If lngCount = 0 Then AllData = Array(): Exit Sub
aOutput = arrData
ReDim Preserve aOutput(1 To lngCount)
AllData = aOutput
End Property
Private Sub Class_Initialize()
ReDim arrData(1 To lngStep)
blnTypeSetted = False
lngCount = 0
lngLength = 1
End Sub
Private Sub Class_Terminate()
Erase arrData
End Sub
Public Function Add(ByVal vItem As Variant) As Long
Dim nIndex As Long
lngCount = lngCount + 1
If lngCount > lngLength * lngStep Then
lngLength = lngLength + 1
ReDim Preserve arrData(1 To lngLength * lngStep)
End If
arrData(lngCount) = vItem
Call UpHeap(lngCount, nIndex)
Add = nIndex
End Function
Public Function ExtractTop() As Variant
If IsEmpty(arrData(1)) Then
Err.Raise 10001, "Binary Heap Class", "The heap top is empty!"
Exit Function
End If
ExtractTop = arrData(1)
If lngCount = 1 Then
ReDim arrData(1 To lngStep)
lngCount = lngCount - 1
Else
arrData(1) = arrData(lngCount)
lngCount = lngCount - 1
Call MaxHeapify(1)
End If
End Function
Public Function DeleteByIndex(ByVal nIndex As Long) As Boolean
If nIndex > lngCount Or nIndex < 1 Then
DeleteByIndex = False
Exit Function
End If
arrData(nIndex) = arrData(lngCount)
lngCount = lngCount - 1
Call MaxHeapify(nIndex)
DeleteByIndex = True
End Function
Public Function ModifyByIndex(ByVal nIndex As Long, ByVal vValue As Variant) As Boolean
If nIndex > lngCount Or nIndex < 1 Then
ModifyByIndex = False
Exit Function
End If
ModifyByIndex = True
If vValue = arrData(nIndex) Then Exit Function
If (ehtHeapType = bhMax And vValue > arrData(nIndex)) Or _
(ehtHeapType = bhMin And vValue < arrData(nIndex)) Then
arrData(nIndex) = vValue
Call UpHeap(nIndex)
Else
arrData(nIndex) = vValue
Call MaxHeapify(nIndex)
End If
End Function
Private Sub UpHeap(ByVal nIndex As Long, Optional nReturn As Long)
Dim vSwap As Variant, nParent As Long
nReturn = nIndex
If nIndex = 1 Then Exit Sub
nParent = nIndex \ 2
If (ehtHeapType = bhMax And arrData(nIndex) > arrData(nParent)) Or _
(ehtHeapType = bhMin And arrData(nIndex) < arrData(nParent)) Then
vSwap = arrData(nIndex): arrData(nIndex) = arrData(nParent): arrData(nParent) = vSwap
nReturn = nParent
Call UpHeap(nParent)
End If
End Sub
Private Sub MaxHeapify(ByVal nIndex As Long)
Dim vSwap As Variant, nChild As Long
If 2 * nIndex > lngCount Then Exit Sub
If 2 * nIndex = lngCount Then
nChild = 2 * nIndex
ElseIf (ehtHeapType = bhMax And arrData(2 * nIndex) > arrData(2 * nIndex + 1)) Or _
(ehtHeapType = bhMin And arrData(2 * nIndex) < arrData(2 * nIndex + 1)) Then
nChild = 2 * nIndex
Else
nChild = 2 * nIndex + 1
End If
If (ehtHeapType = bhMax And arrData(nChild) > arrData(nIndex)) Or _
(ehtHeapType = bhMin And arrData(nChild) < arrData(nIndex)) Then
vSwap = arrData(nIndex): arrData(nIndex) = arrData(nChild): arrData(nChild) = vSwap
Call MaxHeapify(nChild)
End If
End Sub
[/code] |
|