【VB】调用JDK源码中的红黑树实现高效插入删除查询
本帖最后由 天马座 于 2020-11-15 01:11 编辑VB自带容器没有查找树并且字典也不是高效的实现，所以本人想给VB造个轮子
那么当然要选择红黑树了，因为红黑树实现比较复杂(本人抄代码都抄3小时，连复制再粘贴)
所以本人直接把JDK TreeMap源码移植到vb了,好处是JDK的实现相对来说比较可靠
红黑树的核心代码就是插入和删除，其他所有操作接口跟普通二叉搜索树完全一样
本人对vb编辑器不太熟悉，用它打字慢，所以直接用按键编辑器写成vbs版本了,大家简单修改一下就变成vb了
下面代码vb和vbs版本区别就是变量没有定义类型，还有就是Entry类中的成员名left,right vb无法定义得改名，用记事本批量替换一下就可以 其他一样，后续我有时间上网会同步更新完善
2020年11月13日更新完善了所有接口 并且添加VB6版本的代码生成器 在附件下载
全部写完之后测试效率有点低，原因是用类写的节点，Set语句会频繁COM的AddRef,QueryInterface，Release
如果想要高效的实现请改为数组版用6个数组模拟RBEntry 参考 https://www.0xaa55.com/thread-26178-1-1.html，
Class RBEntry
Public key
Public value
Public parent
Public leftChild
Public rightChild
Public color
End Class
Class KVPair
Public key
Public value
End Class
Class BasicCompare
Public Function compare(ByVal a, ByVal b)
If a < b Then
compare = - 1
ElseIf b < a Then
compare = 1
Else
compare = 0
End If
End Function
End Class
Class BasicEqual
Public Function equal(ByVal a, ByVal b)
If a = b Then
equal = true
Else
equal = false
End If
End Function
End Class
Class TreeMap
Private RED, BLACK
Private root
Private size
Private a
Private keyCpr
Private valueCpr
Private Sub Class_Initialize()
RED = false
BLACK = true
Set root = Nothing
Set keyCpr = New BasicCompare
Set valueCpr = New BasicEqual
size = 0
End Sub
Private Sub Class_Terminate()
Call clear()
End Sub
Private Function newEntry(ByRef key, ByRef value, ByVal parent)
Dim o
Set o = New RBEntry
Call setKey(o,key)
Call setValue(o,value)
Set o.parent = parent
Set o.leftChild = Nothing
Set o.rightChild = Nothing
o.color = BLACK
Set newEntry = o
End Function
Public Function clone()
Dim o
Set o = New TreeMap
o.setKeyCompare keyCpr
o.setValueCompare valueCpr
Dim p
Set p = getFirstEntry()
Do While Not (p Is Nothing)
o.add p.key, p.value
Set p = successor(p)
Loop
Set clone = o
End Function
Public Sub setKeyCompare(ByVal newCpr)
If newCpr Is Nothing Then Exit Sub
Set keyCpr = newCpr
Call clear()
End Sub
Public Sub setValueCompare(ByVal newCpr)
If newCpr Is Nothing Then Exit Sub
Set valueCpr = newCpr
Call clear()
End Sub
Public Property Get count()
count = size
End Property
Public Function isEmpty()
isEmpty = (size = 0)
End Function
Public Function newEnum()
If size = 0 Then
newEnum = array()
Exit Function
End If
ReDim a(size-1)
Dim p
Dim i
i = 0
Set p = getFirstEntry()
Do While Not (p Is Nothing)
Set a(i) = New KVPair
Call setKey(a(i), p.key)
Call setValue(a(i), p.value)
Set p=successor(p)
i = i + 1
Loop
newEnum = a
Erase a
End Function
Public Sub clear()
Call unlink(root)
Set root = Nothing
size = 0
End Sub
Public Function getValue(ByVal key)
Dim p
Set p = getEntry(key)
If p Is Nothing Then
Exit Function
End If
If VarType(p.value) = vbObject Then
Set getValue = p.value
Else
getValue = p.value
End If
End Function
Public Sub add(ByVal key, ByVal value)
Dim t
Set t = root
If t Is Nothing Then
Set root = newEntry(key, value, Nothing)
size = 1
Exit Sub
End If
Dim parent
Dim cmp
Do
Set parent = t
cmp = keyCpr.compare(key, t.key)
If cmp < 0 Then
Set t = t.leftChild
ElseIf cmp > 0 Then
Set t = t.rightChild
Else
Call setValue(t,value)
Exit Sub
End If
Loop While Not(t Is Nothing)
Set e = newEntry(key, value, parent)
If cmp < 0 Then
Set parent.leftChild = e
Else
Set parent.rightChild = e
End If
Call fixAfterInsertion(e)
size = size + 1
End Sub
Public Sub remove(ByVal key)
Dim p
Set p = getEntry(key)
If p Is Nothing Then
Exit Sub
End If
Call deleteEntry(p)
End Sub
Private Sub fixAfterInsertion(ByVal x)
Dim y
x.color = RED
Do While Not (x Is Nothing)And Not (x Is root)
If x.parent.color <> RED Then
Exit Do
End If
If parentOf(x) Is leftChildOf(parentOf(parentOf(x))) Then
Set y = rightChildOf(parentOf(parentOf(x)))
If colorOf(y) = RED Then
Call setColor(parentOf(x), BLACK)
Call setColor(y, BLACK)
Call setColor(parentOf(parentOf(x)), RED)
Set x = parentOf(parentOf(x))
Else
If x Is rightChildOf(parentOf(x)) Then
Set x = parentOf(x)
Call rotateLeft(x)
End If
Call setColor(parentOf(x), BLACK)
Call setColor(parentOf(parentOf(x)), RED)
Call rotateRight(parentOf(parentOf(x)))
End If
Else
Set y = leftChildOf(parentOf(parentOf(x)))
If colorOf(y) = RED Then
Call setColor(parentOf(x), BLACK)
Call setColor(y, BLACK)
Call setColor(parentOf(parentOf(x)), RED)
Set x = parentOf(parentOf(x))
Else
If x Is leftChildOf(parentOf(x)) Then
Set x = parentOf(x)
Call rotateRight(x)
End If
Call setColor(parentOf(x), BLACK)
Call setColor(parentOf(parentOf(x)), RED)
Call rotateLeft(parentOf(parentOf(x)))
End If
End If
Loop
root.color = BLACK
End Sub
Private Sub deleteEntry(ByVal p)
size = size - 1
Dim replacement
If Not (p.leftChild Is Nothing)And Not (p.rightChild Is Nothing)Then
Dim s
Set s = successor(p)
Call setKey(p,s.key)
Call setValue(p,s.value)
Set p = s
End If
If Not (p.leftChild Is Nothing)Then
Set replacement = p.leftChild
Else
Set replacement = p.rightChild
End If
If Not (replacement Is Nothing)Then
Set replacement.parent = p.parent
If p.parent Is Nothing Then
Set root = replacement
ElseIf p Is p.parent.leftChild Then
Set p.parent.leftChild= replacement
Else
Set p.parent.rightChild = replacement
End If
Set p.parent = Nothing
Set p.rightChild = Nothing
Set p.leftChild = Nothing
If p.color = BLACK Then
Call fixAfterDeletion(replacement)
End If
ElseIf p.parent Is Nothing Then
Set root = Nothing
Else
If p.color = BLACK Then
Call fixAfterDeletion(p)
End If
If Not (p.parent Is Nothing)Then
If p Is p.parent.leftChild Then
Set p.parent.leftChild = Nothing
ElseIf p Is p.parent.rightChild Then
Set p.parent.rightChild = Nothing
End If
Set p.parent = Nothing
End If
End If
End Sub
Private Sub fixAfterDeletion(ByVal x)
Dim sib
Do While Not (x Is root)And colorOf(x) = BLACK
If x Is leftChildOf(parentOf(x)) Then
Set sib = rightChildOf(parentOf(x))
If colorOf(sib) = RED Then
Call setColor(sib, BLACK)
Call setColor(parentOf(x), RED)
Call rotateLeft(parentOf(x))
Set sib = rightChildOf(parentOf(x))
End If
If colorOf(leftChildOf(sib)) = BLACK And colorOf(rightChildOf(sib)) = BLACK Then
Call setColor(sib, RED)
Set x = parentOf(x)
Else
If colorOf(rightChildOf(sib)) = BLACK Then
Call setColor(leftChildOf(sib), BLACK)
Call setColor(sib, RED)
Call rotateRight(sib)
Set sib = rightChildOf(parentOf(x))
End If
Call setColor(sib, colorOf(parentOf(x)))
Call setColor(parentOf(x), BLACK)
Call setColor(rightChildOf(sib), BLACK)
Call rotateLeft(parentOf(x))
Set x = root
End If
Else
Set sib = leftChildOf(parentOf(x))
If colorOf(sib) = RED Then
Call setColor(sib, BLACK)
Call setColor(parentOf(x), RED)
Call rotateRight(parentOf(x))
Set sib = leftChildOf(parentOf(x))
End If
If colorOf(rightChildOf(sib)) = BLACK And colorOf(leftChildOf(sib)) = BLACK Then
Call setColor(sib, RED)
Set x = parentOf(x)
Else
If colorOf(leftChildOf(sib)) = BLACK Then
Call setColor(rightChildOf(sib), BLACK)
Call setColor(sib, RED)
Call rotateLeft(sib)
Set sib = leftChildOf(parentOf(x))
End If
Call setColor(sib, colorOf(parentOf(x)))
Call setColor(parentOf(x), BLACK)
Call setColor(leftChildOf(sib), BLACK)
Call rotateRight(parentOf(x))
Set x = root
End If
End If
Loop
Call setColor(x, BLACK)
End Sub
Private Sub rotateLeft(ByVal p)
Dim r
if Not (p Is Nothing) Then
Set r = p.rightChild
Set p.rightChild = r.leftChild
If Not (r.leftChild Is Nothing)Then
Set r.leftChild.parent = p
End If
Set r.parent = p.parent
If p.parent Is Nothing Then
Set root = r
ElseIf p.parent.leftChild Is p Then
Set p.parent.leftChild = r
Else
Set p.parent.rightChild = r
End If
Set r.leftChild = p
Set p.parent = r
End If
End Sub
Private Sub rotateRight(ByVal p)
Dim l
If Not (p Is Nothing)Then
Set l = p.leftChild
Set p.leftChild = l.rightChild
If Not (l.rightChild Is Nothing)Then
Set l.rightChild.parent = p
End If
Set l.parent = p.parent
If p.parent Is Nothing Then
Set root = l
ElseIf p.parent.rightChild Is p Then
Set p.parent.rightChild = l
Else
Set p.parent.leftChild = l
End If
Set l.rightChild = p
Set p.parent = l
End If
End Sub
Private Sub setKey(ByVal p,ByRef key)
If VarType(key) = vbObject Then
Set p.key = key
Else
p.key = key
End If
End Sub
Private Sub setValue(ByVal p,ByRef value)
If VarType(value) = vbObject Then
Set p.value = value
Else
p.value = value
End If
End Sub
Private Sub setColor(ByVal p, ByVal c)
If Not (p Is Nothing)Then
p.color = c
End If
End Sub
Private Function colorOf(ByVal p)
If p Is Nothing Then
colorOf = BLACK
Else
colorOf = p.color
End If
End Function
Private Function parentOf(ByVal p)
If p Is Nothing Then
Set parentOf = Nothing
Else
Set parentOf = p.parent
End If
End Function
Private Function leftChildOf(ByVal p)
If p Is Nothing Then
Set leftChildOf = Nothing
Else
Set leftChildOf = p.leftChild
End If
End Function
Private Function rightChildOf(ByVal p)
If p Is Nothing Then
Set rightChildOf = Nothing
Else
Set rightChildOf = p.rightChild
End If
End Function
'二叉树操作函数
Public Function containsKey(ByVal key)
containsKey = Not (getEntry(key) Is Nothing)
End Function
Public Function containsValue(ByVal value)
Dim p
Set p = getFirstEntry()
Do While Not (p Is Nothing)
If valueCpr.equal(value,p.value) Then
containsValue = true
Exit Function
End If
Set p = successor(p)
Loop
containsValue = false
End Function
Public Function firstKey()
Dim p
Set p = getFirstEntry()
If p Is Nothing Then
Exit Function
End If
If VarType(p.key) = vbObject Then
Set firstKey = p.key
Else
firstKey = p.key
End If
End Function
Public Function lastKey()
Dim p
Set p = getLastEntry()
If p Is Nothing Then
Exit Function
End If
If VarType(p.key) = vbObject Then
Set lastKey = p.key
Else
lastKey = p.key
End If
End Function
Public Function higherKey(ByVal key)
Dim p
Set p = getHigherEntry(key)
If p Is Nothing Then
Exit Function
End If
If VarType(p.key) = vbObject Then
Set higherKey = p.key
Else
higherKey = p.key
End If
End Function
Public Function lowerKey(ByVal key)
Dim p
Set p = getLowerEntry(key)
If p Is Nothing Then
Exit Function
End If
If VarType(p.key) = vbObject Then
Set lowerKey = p.key
Else
lowerKey = p.key
End If
End Function
Public Function ceilingKey(ByVal key)
Dim p
Set p = getCeilingEntry(key)
If p Is Nothing Then
Exit Function
End If
If VarType(p.key) = vbObject Then
Set ceilingKey = p.key
Else
ceilingKey = p.key
End If
End Function
Public Function floorKey(ByVal key)
Dim p
Set p = getFloorEntry(key)
If p Is Nothing Then
Exit Function
End If
If VarType(p.key) = vbObject Then
Set floorKey = p.key
Else
floorKey = p.key
End If
End Function
Public Function selectKey(ByVal index)
Dim p
Set p = selectEntry(index)
If p Is Nothing Then
Exit Function
End If
If VarType(p.key) = vbObject Then
Set selectKey = p.key
Else
selectKey = p.key
End If
End Function
Public Function indexOf(ByVal key)
Dim p
Dim i
Set p = getFirstEntry()
i = 0
Do While not (p Is Nothing)
If keyCpr.compare(key,p.key) = 0 Then
indexOf = i
Exit Function
End If
Set p = successor(p)
i = i + 1
Loop
indexOf = - 1
End Function
Private Function getEntry(ByRef key)
Dim p
Dim cmp
Set p = root
Do While not (p Is Nothing)
cmp = keyCpr.compare(key,p.key)
If cmp < 0 Then
Set p = p.leftChild
ElseIf cmp > 0 Then
Set p = p.rightChild
Else
Set getEntry = p
Exit Function
End If
Loop
Set getEntry = Nothing
End Function
Private Function successor(ByVal t)
Dim p, ch
If t Is Nothing Then
Set successor = Nothing
ElseIf not (t.rightChild Is Nothing)Then
Set p = t.rightChild
Do While not (p.leftChild Is Nothing)
Set p = p.leftChild
Loop
Set successor = p
Else
Set p = t.parent
Set ch = t
Do While not (p Is Nothing)
If Not (ch Is p.rightChild) Then Exit do
Set ch = p
Set p = p.parent
Loop
Set successor = p
End If
End Function
Private Function predecessor(ByVal t)
Dim p, ch
If t Is Nothing Then
Set predecessor = Nothing
ElseIf not (t.leftChild Is Nothing)Then
Set p = t.leftChild
Do While not (p.rightChild Is Nothing)
Set p = p.rightChild
Loop
Set predecessor = p
Else
Set p = t.parent
Set ch = t
Do While not (p Is Nothing)
If Not (ch Is p.leftChild) Then Exit do
Set ch = p
Set p = p.parent
Loop
Set predecessor = p
End If
End Function
Private Function getFirstEntry()
Dim p
Set p = root
If Not (p Is Nothing)Then
Do While Not (p.leftChild Is Nothing)
Set p = p.leftChild
Loop
End If
Set getFirstEntry = p
End Function
Private Function getLastEntry()
Dim p
Set p = root
If Not (p Is Nothing)Then
Do While Not (p.rightChild Is Nothing)
Set p = p.rightChild
Loop
End If
Set getLastEntry = p
End Function
Private Function getHigherEntry(ByRef key)
Dim cmp
Dim p, parent, ch
Set p = root
Do While Not (p Is Nothing)
cmp = keyCpr.compare(key, p.key)
If cmp < 0 Then
If Not (p.leftChild Is Nothing)Then
Set p = p.leftChild
Else
Set getHigherEntry = p
Exit Function
End If
Else
If Not (p.rightChild Is Nothing)Then
Set p = p.rightChild
Else
Set parent = p.parent
Set ch = p
Do While Not (parent Is Nothing)
If Not (ch Is parent.rightChild) Then Exit Do
Set ch = parent
Set parent = parent.parent
Loop
Set getHigherEntry = parent
Exit Function
End If
End If
Loop
Set getHigherEntry = Nothing
End Function
Private Function getLowerEntry(ByRef key)
Dim cmp
Dim p, parent, ch
Set p = root
Do While Not (p Is Nothing)
cmp = keyCpr.compare(key, p.key)
If cmp > 0 Then
If Not (p.rightChild Is Nothing)Then
Set p = p.rightChild
Else
Set getLowerEntry = p
Exit Function
End If
Else
If Not (p.leftChildIs Nothing)Then
Set p = p.leftChild
Else
Set parent = p.parent
Set ch = p
Do While Not (parent Is Nothing)
If Not (ch Is parent.leftChild) Then Exit Do
Set ch = parent
Set parent = parent.parent
Loop
Set getLowerEntry = parent
Exit Function
End If
End If
Loop
Set getLowerEntry = Nothing
End Function
Private Function getCeilingEntry(ByRef key)
Dim cmp
Dim p, parent, ch
Set p = root
Do While Not (p Is Nothing)
cmp = keyCpr.compare(key, p.key)
If cmp < 0 Then
If not (p.leftChild Is Nothing)Then
Set p = p.leftChild
Else
Set getCeilingEntry = p
Exit Function
End If
ElseIf cmp > 0 Then
If not (p.rightChild Is Nothing)Then
Set p = p.rightChild
Else
Set parent = p.parent
Set ch = p
Do While Not (parent Is Nothing)
If Not (ch Is parent.rightChild) Then Exit Do
Set ch = parent
Set parent = parent.parent
Loop
Set getCeilingEntry = parent
Exit Function
End If
Else
Set getCeilingEntry = p
Exit Function
End If
Loop
Set getCeilingEntry = Nothing
End Function
Private Function getFloorEntry(ByRef key)
Dim cmp
Dim p, parent, ch
Set p = root
Do While Not (p Is Nothing)
cmp = keyCpr.compare(key, p.key)
If cmp > 0 Then
If not (p.rightChildIs Nothing)Then
Set p = p.rightChild
Else
Set getFloorEntry = p
Exit Function
End If
ElseIf cmp < 0 Then
If not (p.leftChild Is Nothing)Then
Set p = p.leftChild
Else
Set parent = p.parent
Set ch = p
Do While Not (parent Is Nothing)
If Not (ch Is parent.leftChild) Then Exit Do
Set ch = parent
Set parent = parent.parent
Loop
Set getFloorEntry = parent
Exit Function
End If
Else
Set getFloorEntry = p
Exit Function
End If
Loop
Set getFloorEntry = Nothing
End Function
Private Function selectEntry(ByVal index)
If index < 0 or index >= size Then
Set selectEntry = Nothing
Exit Function
End If
Dim p
dim i
If index < size \ 2 Then
i = 0
Set p = getFirstEntry()
Do While Not (p Is Nothing)
If i = index Then
Set selectEntry = p
Exit Function
End If
Set p = successor(p)
i = i + 1
Loop
Set selectEntry = Nothing
Else
i = size - 1
Set p = getLastEntry()
Do While Not (p Is Nothing)
If i = index Then
Set selectEntry = p
Exit Function
End If
Set p = predecessor(p)
i = i - 1
Loop
Set selectEntry = Nothing
End If
End Function
Private Sub unlink(ByVal p)
If p Is Nothing Then
Exit Sub
End If
Call unlink(p.leftChild)
Call unlink(p.rightChild)
Set p.parent = Nothing
End Sub
End Class
'测试
Set o = New TreeMap'创建一个红黑树
'o.setKeyCompare keyCpr 设置key比较器 这里注释掉 使用默认比较器
'o.setValueCompare valueEQ 设置value比较器 这里注释掉 使用默认比较器
For i = 10 To 0 Step - 1 '插入11个键值对 key value
o.add i, i
Next
key = 5
value = 5
i = 5
WScript.Echo o.isEmpty'判断树是否为空
WScript.Echo o.count'获取键值对数量
WScript.Echo o.containsKey(key)'判断key是否存在
WScript.Echo o.containsValue(value)'判断key是否存在
WScript.Echo o.getValue(key)'key对应的value
WScript.Echo o.higherKey(key)'刚好大于key的key
WScript.Echo o.lowerKey(key)'刚好小于key的key
WScript.Echo o.ceilingKey(key)'刚好大于等于key的key
WScript.Echo o.floorKey(key)'刚好小于等于key的key
WScript.Echo o.indexOf(key)'key的排名
WScript.Echo o.selectKey(i)'排名i对应的key
WScript.Echo o.firstKey '最小的key
WScript.Echo o.lastKey '最大的key
o.remove 6'删除key
For Each x In o.newEnum'顺序遍历
WScript.Echo x.key & "=" & x.value
Next
o.clear '清空树
WScript.Echo o.isEmpty'判断树是否为空
Set oo = o.clone'克隆该对象
这种要是改，会改成VB.NET比较合适 原来是VBS哦，不错不错，但是有个很严重的问题，那就是VBS是基于COM的计数引用机制，对象之间循环会导致无法被释放BUG。
改成VB.NET的话肯定不错，.NET是GC引用机制可以避免这个问题，至于Left和Right被关键字占用的问题，VB.NET可以用方括号解决：Public As XXX, As XXX。 系统消息 发表于 2020-11-9 09:50
原来是VBS哦，不错不错，但是有个很严重的问题，那就是VBS是基于COM的计数引用机制，对象之间循环会导致无 ...
可以释放，删除节点x 删除后x的引用计数为0，清空所有节点，需要写一个递归函数就可以
页:
[1]