Lu76Fer
XLDnaute Occasionnel
Bonjour à toutes et tous !
Vous utilisez sans doute souvent des collections ou dictionnaires mais ce sont des structures qui comportent des fonctionnalités très limitées. Personnellement je n'ai pas trouver d'algorithme classique codé pour le VB ou VBA du type Arbre AVL ou table de hachage; si vous avez des liens, je serais heureux de les connaitre. En attendant, je vous propose mon adaptation d'un arbre AVL écrit à l'origine en langage C qui utilise d'astucieux effets de bord et possède une grande adaptabilité grâce à une interface très ingénieuse pour un langage purement fonctionnel.
J'ai ajouté à cet algorithme une petite optimisation sur la partie suppression ainsi que d'autres fonctionnalités de recherche, de suppression et d'interface.
J'ai ajouté à cet algorithme une petite optimisation sur la partie suppression ainsi que d'autres fonctionnalités de recherche, de suppression et d'interface.
Les caractéristiques d'un arbre AVL : Wikipédia
Cet algorithme permet de classer des données d'une façon ordonnée tout en permettant l'ajout et la suppression de données. Pour réaliser une opération de recherche, d'ajout ou de suppression le niveau de complexité de cet algo est O(log2 n). Pour rechercher la donnée dans un arbre on parcours des Nœuds, voici un tableau qui montre la hauteur de l'arbre en fonction du nombre de données maximum qu'il peut contenir :
Le nombre de nœud moyen parcouru pour toute action sur l'arbre est égale à sa hauteur pour des grands nombres.
Il s'agit d'un algorithme très efficace pour gérer des données triées.
Implémentation
Au préalable, il est nécessaire de définir la structure de base qui compose l'arbre : le Nœud qui sera un module de Classe :
VB:
'CLASSE : 'UcNode'
Public Left As UcNode, Right As UcNode
Public Element As Object
Public Bal As Byte '1 :Penche à gauche, 2 : Equilibré, 3 : Penche à droite
'1: O 2: O 3: O
' / / \ \
' O O O O
'Les valeurs d'équibre sont décalées de +2 afin d'optimiser le code.Ci-dessous la structure principale, l'arbre qui est composé de nœud(s), un module de classe capable de stocker des Objets génériques, Object, s'interfaçant grâce à des liaisons tardives.
VB:
'CLASSE : 'UcTree'
'Arbre de Recherche BinaiRe Equilibré ou Arbre AVL
Private Tree As UcNode 'Nœud principal de l'arbre (il peut se déplacer à gauche ou à droite)
Private RefNode As UcNode 'Référence à un nœud (Pointe dessus)
Private RefElt As Object 'Référence à un objet (Pointe dessus)
Private Replace As Boolean 'Mode remplacement pour l'ajout d'un élément
Public Total As Long 'Compteur de Nœud (ou d'élément : si doublon à gérer)
'Tree
Private Sub Class_Initialize()
Set Tree = Nothing
End Sub
'Supprimer l'Arbre
Sub DeleteTree()
Set Tree = Nothing
End Sub
'Ajoute l'Elément elt et renvoie (la référence à) celui-ci
' Renvoie Nothing si déjà présent sauf si pReplace=True
Function AddElement(elt As Object, pReplace As Boolean) As Object
Replace = pReplace
Insert elt, Tree
If RefElt Is Nothing Then Exit Function
Set AddElement = RefElt: Set RefElt = Nothing: Total = Total + 1
End Function
'Retire et renvoie l'Elément identifié par key ou Nothing si non présent
Function RemoveElement(key As Variant) As Object
Delete key, Tree
If RefElt Is Nothing Then Exit Function
Set RemoveElement = RefElt: Set RefElt = Nothing: Total = Total - 1
End Function
'Retire et renvoie l'Elément Min(si isMin=True) ou MAX ou Nothing si non présent
' filter : si True appel la fonction d'interface : Function FilterElt() As Boolean
Function RemoveTipElt(isMin As Boolean, Optional filter As Boolean = False) As Object
If Tree Is Nothing Then Exit Function
If Tree.Left Is Nothing And Tree.Right Is Nothing Then
Set RemoveTipElt = Tree.Element: Set Tree = Nothing
Exit Function
End If
If isMin Then
If RmvMinLeaf(Tree, filter) Then BalAfterLeftDel Tree
Else
If RmvMaxLeaf(Tree, filter) Then BalAfterRightDel Tree
End If
If RefNode Is Nothing Then Exit Function
Set RemoveTipElt = RefNode.Element: Set RefNode = Nothing: Total = Total - 1
End Function
'Renvoie l'Elément identifié par key dans l'arbre Tree ou Nothing si non présent
Function FindElement(key As Variant) As Object
Set FindElement = FindNodElt(key, Tree)
End Function
'Renvoie l'Elément Min(si isMin=True) ou MAX, ou encore Nothing si non présent
' filter : si True appel la fonction d'interface : Function FilterElt() As Boolean
Function FindTipElt(isMin As Boolean, Optional filter As Boolean = False) As Object
Dim nod As UcNode
If Tree Is Nothing Then Exit Function
Set nod = Tree
If isMin Then
Do: Set RefNode = nod: Set nod = nod.Left: Loop Until nod Is Nothing
Else
Do: Set RefNode = nod: Set nod = nod.Right: Loop Until nod Is Nothing
End If
If flt Then If nod.Element.FilterElt() Then Exit Function
Set FindTipElt = RefNode.Element: Set RefNode = Nothing
End Function
'Enumère les éléments de l'arbre dans l'ordre croissant (ou décroissant si rev=True)
'jusqu'au bout ou jusqu'à ce que votre fonction d'interface renvoie False
'Interface : Function EnumEltCallBack(param As Variant) As Boolean
Function EnumElement(param As Variant, Optional rev As Boolean = False) As Boolean
If rev Then EnumElement = EnumNodEltRev(Tree, param) Else EnumElement = EnumNodElt(Tree, param)
End Function
'Partie récursive de la fonction FindElement
Private Function FindNodElt(key As Variant, nod As UcNode) As Object
Dim cmpVal As Long
If nod Is Nothing Then Exit Function
cmpVal = nod.Element.Compare(key)
If cmpVal < 0 Then Set FindNodElt = FindNodElt(key, nod.Left): Exit Function
If cmpVal > 0 Then Set FindNodElt = FindNodElt(key, nod.Right): Exit Function
Set FindNodElt = nod.Element
End Function
'Partie récursive de la fonction EnumNodElt : ordre croissant
Private Function EnumNodElt(nod As UcNode, param As Variant)
EnumNodElt = True
If Not (nod Is Nothing) Then
If Not (nod.Left Is Nothing) Then EnumNodElt = EnumNodElt(nod.Left, param)
If EnumNodElt Then EnumNodElt = nod.Element.EnumEltCallBack(param)
If (EnumNodElt And Not (nod.Right Is Nothing)) Then EnumNodElt = EnumNodElt(nod.Right, param)
End If
End Function
'Ordre décroissant
Private Function EnumNodEltRev(nod As UcNode, param As Variant)
EnumNodEltRev = True
If Not (nod Is Nothing) Then
If Not (nod.Right Is Nothing) Then EnumNodEltRev = EnumNodEltRev(nod.Right, param)
If EnumNodEltRev Then EnumNodEltRev = nod.Element.EnumEltCallBack(param)
If (EnumNodEltRev And Not (nod.Left Is Nothing)) Then EnumNodEltRev = EnumNodEltRev(nod.Left, param)
End If
End Function
'Ajoute un nouveau noeud dans l'arbre nod qui référencera l'Elément elt
Private Function Insert(elt As Object, ByRef nod As UcNode) As Boolean
Dim cmpVal As Long, nodT As UcNode
If nod Is Nothing Then 'Affecte elt au noeud créé
Set nod = New UcNode: Set nod.Element = elt: Set RefElt = elt
Insert = True: Exit Function
End If
cmpVal = elt.AddCompare(nod.Element)
If cmpVal < 0 Then 'Insère elt à gauche
Set nodT = nod.Left: Insert = Insert(elt, nodT): Set nod.Left = nodT
If Insert Then Insert = BalAfterLeftIns(nod)
Exit Function
End If
If cmpVal > 0 Then 'Insère elt à droite
Set nodT = nod.Right: Insert = Insert(elt, nodT): Set nod.Right = nodT
If Insert Then Insert = BalAfterRightIns(nod)
Exit Function
End If
If Replace Then Set RefElt = nod.Element: Set nod.Element = elt
End Function
'Equilibre le noeud nod après une insertion à gauche
Private Function BalAfterLeftIns(nod As UcNode) As Boolean
Dim nod1 As UcNode, nod2 As UcNode
On nod.Bal GoTo toLeft, equi, toRight
Exit Function
toLeft: '*Penche à gauche*
Set nod1 = nod.Left
If nod1.Bal = 1 Then 'Single L rotation
Set nod.Left = nod1.Right: Set nod1.Right = nod
nod.Bal = 2: Set nod = nod1
Else 'Double LR rotation
Set nod2 = nod1.Right: Set nod1.Right = nod2.Left: Set nod2.Left = nod1
Set nod.Left = nod2.Right: Set nod2.Right = nod
If nod2.Bal = 1 Then nod.Bal = 3 Else nod.Bal = 2
If nod2.Bal = 3 Then nod1.Bal = 1 Else nod1.Bal = 2
Set nod = nod2
End If
nod.Bal = 2 'BalAfterLeftIns = False
Exit Function
equi: '*Equilibré*
nod.Bal = 1: BalAfterLeftIns = True
Exit Function
toRight: '*Penche à droite*
nod.Bal = 2 'BalAfterLeftIns = False
End Function
'Equilibre le noeud nod après une insertion à droite
Private Function BalAfterRightIns(nod As UcNode) As Boolean
Dim nod1 As UcNode, nod2 As UcNode
On nod.Bal GoTo toLeft, equi, toRight
Exit Function
toLeft: '*Penche à gauche*
nod.Bal = 2 'BalAfterRightIns = False
Exit Function
equi: '*Equilibré*
nod.Bal = 3: BalAfterRightIns = True
Exit Function
toRight: '*Penche à droite*
Set nod1 = nod.Right
If nod1.Bal = 3 Then 'Single R rotation
Set nod.Right = nod1.Left: Set nod1.Left = nod
nod.Bal = 2: Set nod = nod1
Else 'Double RL rotation
Set nod2 = nod1.Left: Set nod1.Left = nod2.Right: Set nod2.Right = nod1
Set nod.Right = nod2.Left: Set nod2.Left = nod
If nod2.Bal = 3 Then nod.Bal = 1 Else nod.Bal = 2
If nod2.Bal = 1 Then nod1.Bal = 3 Else nod1.Bal = 2
Set nod = nod2
End If
nod.Bal = 2 'BalAfterRightIns = False
End Function
'Supprime le noeud dans l'arbre nod contenant l'Elément identifié par key
' et référence l'élément supprimé
Private Function Delete(key As Variant, nod As UcNode) As Boolean
Dim cmpVal As Long, nodT As UcNode
If nod Is Nothing Then Delete = False: Exit Function
cmpVal = nod.Element.Compare(key)
If cmpVal < 0 Then
Set nodT = nod.Left: Delete = Delete(key, nodT): Set nod.Left = nodT
If Delete Then Delete = BalAfterLeftDel(nod)
Exit Function
End If
If cmpVal > 0 Then
Set nodT = nod.Right: Delete = Delete(key, nodT): Set nod.Right = nodT
If Delete Then Delete = BalAfterRightDel(nod)
Exit Function
End If
Set RefNode = nod: Set RefElt = nod.Element 'Référence l'élément supprimer
If nod.Right Is Nothing Then Set nod = nod.Left: Delete = True: Exit Function
If nod.Left Is Nothing Then Set nod = nod.Right: Delete = True: Exit Function
'Remplacer le noeud supprimer par une 'feuille' (ou noeud à une feuille)
If nod.Bal = 3 Then 'si nod penche à droite (rajouter à l'algo d'origine)
Set nodT = nod.Right: Delete = RmvMinLeaf(nodT): Set nod.Right = nodT
If Delete Then Delete = BalAfterRightDel(nod)
Else 'Equilibré ou penche à gauche
Set nodT = nod.Left: Delete = RmvMaxLeaf(nodT): Set nod.Left = nodT
If Delete Then Delete = BalAfterLeftDel(nod)
End If
Set RefNode = Nothing
End Function
'Retire le noeud contenant l'élément MIN d'un sous-arbre nod, NON VIDE
' Si un noeud est référencé on stocke l'élément de nod dans ce noeud sinon on référence nod (si non filtré)
Private Function RmvMinLeaf(nod As UcNode, Optional flt As Boolean = False) As Boolean
Dim nod1 As UcNode
If nod.Left Is Nothing Then
If RefNode Is Nothing Then 'Non référencé
If flt Then If nod.Element.FilterElt() Then Exit Function 'Filtrage
Set RefNode = nod
Else 'Stocke Elt dans RefNode
Set RefNode.Element = nod.Element
End If
Set nod = nod.Right 'L'élément supprimer peut aussi être un NOEUD n'ayant qu'une feuille
RmvMinLeaf = True
Else
Set nod1 = nod.Left: RmvMinLeaf = RmvMinLeaf(nod1): Set nod.Left = nod1
If RmvMinLeaf Then RmvMinLeaf = BalAfterLeftDel(nod)
End If
End Function
'Retire le noeud contenant l'élément MAX d'un sous-arbre nod, NON VIDE
' Si un noeud est référencé on stocke l'élément de nod dans ce noeud sinon on référence nod (si non filtré)
Private Function RmvMaxLeaf(nod As UcNode, Optional flt As Boolean = False) As Boolean
Dim nod1 As UcNode
If nod.Right Is Nothing Then
If RefNode Is Nothing Then 'Non référencé
If flt Then If nod.Element.FilterElt() Then Exit Function 'Filtrage
Set RefNode = nod
Else 'Stocke Elt dans RefNode
Set RefNode.Element = nod.Element
End If
Set nod = nod.Left 'L'élément supprimer peut aussi être un NOEUD n'ayant qu'une feuille
RmvMaxLeaf = True
Else
Set nod1 = nod.Right: RmvMaxLeaf = RmvMaxLeaf(nod1): Set nod.Right = nod1
If RmvMaxLeaf Then RmvMaxLeaf = BalAfterRightDel(nod)
End If
End Function
'Equilibre le noeud nod après une suppression à gauche
Private Function BalAfterLeftDel(nod As UcNode) As Boolean
Dim nod1 As UcNode, nod2 As UcNode
On nod.Bal GoTo toLeft, equi, toRight
Exit Function
toLeft: '*Penche à gauche*
nod.Bal = 2: BalAfterLeftDel = True
Exit Function
equi: '*Equilibré*
nod.Bal = 3
Exit Function
toRight: '*Penche à droite*
Set nod1 = nod.Right
If nod1.Bal = 1 Then 'Double RL rotation
Set nod2 = nod1.Left: Set nod1.Left = nod2.Right: Set nod2.Right = nod1
Set nod.Right = nod2.Left: Set nod2.Left = nod
If nod2.Bal = 3 Then nod.Bal = 1 Else nod.Bal = 2
If nod2.Bal = 1 Then nod1.Bal = 3 Else nod1.Bal = 2
Set nod = nod2: nod.Bal = 2: BalAfterLeftDel = True
Else 'Single R rotation
Set nod.Right = nod1.Left: Set nod1.Left = nod
If nod1.Bal = 2 Then
nod.Bal = 3: nod1.Bal = 1
Else
nod.Bal = 2: nod1.Bal = 2: BalAfterLeftDel = True
End If
Set nod = nod1
End If
End Function
'Equilibre le noeud nod après une suppression à droite
Private Function BalAfterRightDel(nod As UcNode) As Boolean
Dim nod1 As UcNode, nod2 As UcNode
On nod.Bal GoTo toLeft, equi, toRight
Exit Function
toLeft: '*Penche à gauche*
Set nod1 = nod.Left
If nod1.Bal = 3 Then 'Double LR rotation
Set nod2 = nod1.Right: Set nod1.Right = nod2.Left: Set nod2.Left = nod1
Set nod.Left = nod2.Right: Set nod2.Right = nod
If nod2.Bal = 1 Then nod.Bal = 3 Else nod.Bal = 2
If nod2.Bal = 3 Then nod1.Bal = 1 Else nod1.Bal = 2
Set nod = nod2: nod2.Bal = 2: BalAfterRightDel = True
Else 'Single L rotation
Set nod.Left = nod1.Right: Set nod1.Right = nod
If nod1.Bal = 2 Then
nod.Bal = 1: nod1.Bal = 3
Else
nod.Bal = 2: nod1.Bal = 2: BalAfterRightDel = True
End If
Set nod = nod1
End If
Exit Function
equi: '*Equilibré*
nod.Bal = 1
Exit Function
toRight: '*Penche à droite*
nod.Bal = 2: BalAfterRightDel = True
End FunctionVoici un exemple du cas d'adaptation de code auquel j'ai eu à faire :
VB:
Dim nodT As UcNode
'(...)
Delete = Delete(key, nod.Right)
'DEVIENT :
Set nodT = nod.Right: Delete = Delete(key, nodT): Set nod.Right = nodTLe passage de paramètre de nod.Right doit se faire par référence pour rendre effectif l'effet de bord du programme. Il s'avère que nod.Right est vue comme une expression et non une référence à un objet et VBA force le passage de paramètre à se faire par Valeur plutôt que par référence. Il suffit donc de passer par l'intermédiaire de nodT pour que l'interpréteur accepte le passage par référence.
Exemple sur la classe UcNumber, d'utilisation des fonctionnalités de UcTree
Voici un objet simple qui stocke une valeur entière et pour lequel il sera nécessaire de coder les fonctions d'interface AddCompare, Compare et EnumEltCallBack pour tester l'ajout, la suppression et l'affichage des éléments UcNumber stockés dans l'arbre.
Exemple sur la classe UcNumber, d'utilisation des fonctionnalités de UcTree
Voici un objet simple qui stocke une valeur entière et pour lequel il sera nécessaire de coder les fonctions d'interface AddCompare, Compare et EnumEltCallBack pour tester l'ajout, la suppression et l'affichage des éléments UcNumber stockés dans l'arbre.
VB:
'CLASSE : UcNumber
Public Val As Integer
'Comparaison de 2 éléments me et elt sur une opération d'ajout
Function AddCompare(elt As UcNumber) As Long
Dim oTmp As Object
AddCompare = Val - elt.Val
End Function
'Comparaison de 2 éléments me et elt sur les autres opérations
Function Compare(key As Variant) As Long
Compare = key - Val
End Function
'Fonction appelée par EnumElement pour chaque élément tant que retour=True
' param : vos arguments (par ex une collection)
Function EnumEltCallBack(param As Variant) As Boolean
Dim s As String
If Not (EqualsCl Is Nothing) Then s = " avec " & EqualsCl.Count + 1 & " exemplaires"
Debug.Print "Valeur=" & Val & s
EnumEltCallBack = True
End Function
__________________________________________________________________________________________________________
'MODULE : Number
Private CrtTreeNumbers As UcTree
Sub AjoutSuppressionDeNumbers()
Dim treeNbrs As New UcTree, numb As UcNumber, ar As Variant, v As Variant, cnt As Integer
Set CrtTreeNumbers = treeNbrs
ar = Array(8, 9, 5, 14, 5, 12, 78, 5, 85, 5, 112, 5, 3) '9 valeurs différentes (les doublons sont ignorés)
For Each v In ar
Set numb = New UcNumber
numb.Val = v
treeNbrs.AddElement numb, False
Next v
treeNbrs.EnumElement Null
Debug.Print "*** Compteur=" & treeNbrs.Total
For cnt = 0 To UBound(ar)
Set numb = treeNbrs.RemoveElement(ar(cnt))
Next cnt
Debug.Print "*** Après effacement, compteur=" & treeNbrs.Total
End Sub
VB:
'CLASSE : UcNumber
'Renvoyez vrai si l'élément est filtré(ignoré) sur les opérations avec l'argument filtre
Function FilterElt() As Boolean
If Val > 12 Then FilterElt = True
End Function
__________________________________________________________________________________________________________
'MODULE : Number
Sub SuppressionSelectiveDeNumbers()
Dim treeNbrs As New UcTree, numb As UcNumber, ar As Variant, v As Variant
Set CrtTreeNumbers = treeNbrs
ar = Array(8, 9, 5, 14, 5, 12, 78, 5, 85, 5, 112, 5, 3) '9 valeurs différentes (les doublons sont ignorés)
For Each v In ar
Set numb = New UcNumber
numb.Val = v
treeNbrs.AddElement numb, False
Next v
treeNbrs.EnumElement Null
Debug.Print "*** Compteur=" & treeNbrs.Total
Do
Set numb = treeNbrs.RemoveTipElt(True, True)
Loop Until numb Is Nothing
treeNbrs.EnumElement Null
Debug.Print "*** Après effacement sélectif, compteur=" & treeNbrs.Total
End SubSur la procédure ci-dessus, on supprime les éléments par ordre croissant jusqu'à ce que la fonction FltElt renvoie True. Ceci permet de supprimer tous les éléments inférieurs ou égale à 12 mais on pourrait modifier le code pour supprimer toutes les valeurs supérieures ou égales à 85... En passant par la fonction EnumElement, il est aussi possible de sélectionner les nombres paires par exemple, pour les supprimer.
Dernière édition:
) avec les tables de pointeurs à deux niveaux hi hi ça pique....
