XLS : Arbre de Recherche BinaiRe Equilibré ou Arbre AVL

[Lu76Fer]

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.​

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 :

'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.

'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 Function

Le langage VBA étant un langage Pseudo-objet, il existe des limitations dans l'utilisation des références aux objets :
Voici un exemple du cas d'adaptation de code auquel j'ai eu à faire :

Dim nodT As UcNode
'(...)
Delete = Delete(key, nod.Right)
'DEVIENT :
Set nodT = nod.Right: Delete = Delete(key, nodT): Set nod.Right = nodT

Le 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.​

'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

Rajoutons maintenant une nouvelle fonction d'interface FilterElt pour faire une suppression plus sélective à l'aide de la fonction RemoveTipElt :

'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 Sub

Sur 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.​

 

[Lu76Fer]

Ajout d'une Interface

Je vous propose une version de l'arbre AVL utilisant une interface IfTree qui permet de créer une 'liaison directe' avec la classe UcTree.
Dans cette version, des exemples permettent de gérer les doublons car l'arbre ne permet pas de stocker des doublons. Cependant, en utilisant l'interface à partir de la fonction AddCompare on pourra ajouter les doublons à une collection de doublons depuis l'objet UcNumber.
Enfin, le code vous permettra aussi de tenir compte de ces doublons dans la propriété de comptage de l'arbre : Total.​

 

[Lu76Fer]

Mini patch & Performance
En réalisant un test pour évaluer la performance des principales opérations, je suis tombé sur 2 anomalies mineures dont voici le détail :

• RemoveElement : RefNode n'est pas toujours réinitialisé
• RemoveTipElt : quand le dernier nœud de l'arbre est supprimé, il n'est pas décompté

Voici donc les deux fonctions à remplacer dans le module de classe UcTree :

'CODE A REMPLACER
'Retire et renvoie l'Elément identifié par key ou Nothing si non présent
Function RemoveElement(key As Variant) As IfTree
    Delete key, Tree
    If RefElt Is Nothing Then Exit Function
    Set RemoveElement = RefElt: Set RefElt = Nothing: Set RefNode = 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 IfTree
    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: Total = Total - 1
        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

J'ai ensuite réalisé un test pour connaitre le temps moyen d’exécution des fonctions d'insertion, de suppression et de suppression du minimum (RemoveTipElt). J'ai ajouté une feuille S_Res pour y copier les résultat et créé une fonction pour remplir un tableau avec 10 000 valeurs de 0 à 9999 de façon non séquentiel.

'MODULE Perf :
Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long

Private LngStartTimer As Long   'Défini l'instant de départ
Private CrtTreeNumbers As UcTree

Sub BoucleDeTest()
Dim cnt As Integer
    Application.Cursor = xlNorthwestArrow
    For cnt = 1 To 50
        Perf_RemoveElement
    Next cnt
    For cnt = 1 To 50
        Perf_RemoveTipElt
    Next cnt
    Application.Cursor = xlDefault
    Debug.Print "Phase de Test terminée !!"
End Sub

'Remplit le tableau tb avec 10000 valeurs de 0 à 9999 selon un ordre non séquentiel
'   shift{n} décale chaque digit de rang n de cette valeur au départ
Sub Gen10000(tb() As Integer, shift0 As Integer, shift1 As Integer, shift2 As Integer, shift3 As Integer)
Dim pos As Integer, dec As Integer, d(3) As Integer, n As Integer
Dim cnt0 As Integer, cnt1 As Integer, cnt2 As Integer, cnt3 As Integer
    d(0) = shift0: d(1) = shift1: d(2) = shift2: d(3) = shift3
    For cnt3 = 0 To 9
        For cnt2 = 0 To 9
            For cnt1 = 0 To 9
                For cnt0 = 0 To 9
                    For dec = 0 To 3
                        d(dec) = (d(dec) + 3) Mod 10
                    Next dec
                    n = d(3) * 1000 + d(2) * 100 + d(1) * 10 + d(0)
                    tb(pos) = n: pos = pos + 1
                Next
                d(0) = d(0) + 1
            Next
            d(1) = d(1) + 1
        Next
        d(2) = d(2) + 1
    Next
End Sub

'Démarrage du Chrono
Sub StartTimer()
    LngStartTimer = GetTickCount()
End Sub

'Arrêt du Chrono
Function StopTimer() As Long
    StopTimer = GetTickCount() - LngStartTimer
End Function

'Mesure la durée de l'ajout de 10 000 valeurs puis de la suppression de celles-ci
Sub Perf_RemoveElement()
Dim tb(9999) As Integer, cnt As Integer, timePeriod As Long, tot As Integer
Dim treeNbrs As New UcTree, numb As UcNumber, key As Integer
'Insertion
    Set CrtTreeNumbers = treeNbrs
    Gen10000 tb, 0, 2, 4, 6
    'Debug.Print "Start Insertion !"
    StartTimer
    For cnt = 0 To 9999
        Set numb = New UcNumber
        numb.Val = tb(cnt)
        treeNbrs.AddElement numb, False
    Next cnt
    timePeriod = StopTimer()
    tot = treeNbrs.Total
    'Debug.Print "Stop : " & tot & " valeurs ajoutées en " & timePeriod & " ms !"
    AjoutePerf 0, timePeriod
'Suppression
    Erase tb
    Gen10000 tb, 5, 2, 3, 8
    'Debug.Print "Start Suppression !"
    StartTimer
    For cnt = 0 To 9999
        key = tb(cnt)
        treeNbrs.RemoveElement key
    Next cnt
    timePeriod = StopTimer()
    tot = tot - treeNbrs.Total
    'Debug.Print "Stop : " & tot & " valeurs supprimées en " & timePeriod & " ms !"
    AjoutePerf 1, timePeriod
End Sub

'Mesure la durée de l'ajout de 10 000 valeurs puis de la suppression de celles-ci en prenant toujours l'élément minimum
Sub Perf_RemoveTipElt()
Dim tb(9999) As Integer, cnt As Integer, timePeriod As Long, tot As Integer
Dim treeNbrs As New UcTree, numb As UcNumber ', key As Integer
'Insertion
    Set CrtTreeNumbers = treeNbrs
    Gen10000 tb, 0, 2, 4, 6
    'Debug.Print "Start Insertion !"
    StartTimer
    For cnt = 0 To 9999
        Set numb = New UcNumber
        numb.Val = tb(cnt)
        treeNbrs.AddElement numb, False
    Next cnt
    timePeriod = StopTimer()
    tot = treeNbrs.Total
    'Debug.Print "Stop : " & tot & " valeurs ajoutées en " & timePeriod & " ms !"
    AjoutePerf 0, timePeriod
'Suppression
    'Debug.Print "Start Suppression !"
    StartTimer
    For cnt = 0 To 9999
        treeNbrs.RemoveTipElt True
    Next cnt
    timePeriod = StopTimer()
    tot = tot - treeNbrs.Total
    'Debug.Print "Stop : " & tot & " valeurs supprimées en " & timePeriod & " ms !"
    AjoutePerf 2, timePeriod
End Sub

'typ 0(col 1) => Insertion, typ 1(col 2) => Suppresion, typ 2(col 3) => Suppression par le minimum
Sub AjoutePerf(typ As Integer, perf As Long)
Static nbLig(2) As Integer
Dim wkt As Worksheet
    Set wkt = S_Res 'A Adapter
    If nbLig(typ) = 0 Then nbLig(typ) = 2
    S_Res.Cells(nbLig(typ), typ + 1) = perf
    nbLig(typ) = nbLig(typ) + 1
    DoEvents
End Sub

Voici le bilan de ce test de performance sur ma machine qui commence à dater un peu; du coup prière de ne pas se moquer...

A noter que sans interface, l'insertion est 3X plus lente, la suppression 4X plus lente et la suppression du minimum 2X plus lente.

Pour finir voici un dernier correctif dans Delete ou je propose de retirer la modification de l'algorithme que j'avais rajouté à l'algorithme d'origine et qui n'apporte rien, voir est un chouya plus lente. Et je retire la dernière instruction qui ne sert plus à rien car elle est désormais dans RemoveElement. C'était comme cela dans deux autres algos, il y avait forcément une raison même si cela me semblait plus logique ...

'CODE A REMPLACER
'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)
    Set nodT = nod.Left: Delete = RmvMaxLeaf(nodT): Set nod.Left = nodT 'Toujours à gauche !
    If Delete Then Delete = BalAfterLeftDel(nod)
End Function

 

[oguruma]

Mini patch & Performance
En réalisant un test pour évaluer la performance des principales opérations, je suis tombé sur 2 anomalies mineures dont voici le détail :

• RemoveElement : RefNode n'est pas toujours réinitialisé
• RemoveTipElt : quand le dernier nœud de l'arbre est supprimé, il n'est pas décompté

Voici donc les deux fonctions à remplacer dans le module de classe UcTree :

'CODE A REMPLACER
'Retire et renvoie l'Elément identifié par key ou Nothing si non présent
Function RemoveElement(key As Variant) As IfTree
    Delete key, Tree
    If RefElt Is Nothing Then Exit Function
    Set RemoveElement = RefElt: Set RefElt = Nothing: Set RefNode = 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 IfTree
    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: Total = Total - 1
        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

J'ai ensuite réalisé un test pour connaitre le temps moyen d’exécution des fonctions d'insertion, de suppression et de suppression du minimum (RemoveTipElt). J'ai ajouté une feuille S_Res pour y copier les résultat et créé une fonction pour remplir un tableau avec 10 000 valeurs de 0 à 9999 de façon non séquentiel.

'MODULE Perf :
Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long

Private LngStartTimer As Long   'Défini l'instant de départ
Private CrtTreeNumbers As UcTree

Sub BoucleDeTest()
Dim cnt As Integer
    Application.Cursor = xlNorthwestArrow
    For cnt = 1 To 50
        Perf_RemoveElement
    Next cnt
    For cnt = 1 To 50
        Perf_RemoveTipElt
    Next cnt
    Application.Cursor = xlDefault
    Debug.Print "Phase de Test terminée !!"
End Sub

'Remplit le tableau tb avec 10000 valeurs de 0 à 9999 selon un ordre non séquentiel
'   shift{n} décale chaque digit de rang n de cette valeur au départ
Sub Gen10000(tb() As Integer, shift0 As Integer, shift1 As Integer, shift2 As Integer, shift3 As Integer)
Dim pos As Integer, dec As Integer, d(3) As Integer, n As Integer
Dim cnt0 As Integer, cnt1 As Integer, cnt2 As Integer, cnt3 As Integer
    d(0) = shift0: d(1) = shift1: d(2) = shift2: d(3) = shift3
    For cnt3 = 0 To 9
        For cnt2 = 0 To 9
            For cnt1 = 0 To 9
                For cnt0 = 0 To 9
                    For dec = 0 To 3
                        d(dec) = (d(dec) + 3) Mod 10
                    Next dec
                    n = d(3) * 1000 + d(2) * 100 + d(1) * 10 + d(0)
                    tb(pos) = n: pos = pos + 1
                Next
                d(0) = d(0) + 1
            Next
            d(1) = d(1) + 1
        Next
        d(2) = d(2) + 1
    Next
End Sub

'Démarrage du Chrono
Sub StartTimer()
    LngStartTimer = GetTickCount()
End Sub

'Arrêt du Chrono
Function StopTimer() As Long
    StopTimer = GetTickCount() - LngStartTimer
End Function

'Mesure la durée de l'ajout de 10 000 valeurs puis de la suppression de celles-ci
Sub Perf_RemoveElement()
Dim tb(9999) As Integer, cnt As Integer, timePeriod As Long, tot As Integer
Dim treeNbrs As New UcTree, numb As UcNumber, key As Integer
'Insertion
    Set CrtTreeNumbers = treeNbrs
    Gen10000 tb, 0, 2, 4, 6
    'Debug.Print "Start Insertion !"
    StartTimer
    For cnt = 0 To 9999
        Set numb = New UcNumber
        numb.Val = tb(cnt)
        treeNbrs.AddElement numb, False
    Next cnt
    timePeriod = StopTimer()
    tot = treeNbrs.Total
    'Debug.Print "Stop : " & tot & " valeurs ajoutées en " & timePeriod & " ms !"
    AjoutePerf 0, timePeriod
'Suppression
    Erase tb
    Gen10000 tb, 5, 2, 3, 8
    'Debug.Print "Start Suppression !"
    StartTimer
    For cnt = 0 To 9999
        key = tb(cnt)
        treeNbrs.RemoveElement key
    Next cnt
    timePeriod = StopTimer()
    tot = tot - treeNbrs.Total
    'Debug.Print "Stop : " & tot & " valeurs supprimées en " & timePeriod & " ms !"
    AjoutePerf 1, timePeriod
End Sub

'Mesure la durée de l'ajout de 10 000 valeurs puis de la suppression de celles-ci en prenant toujours l'élément minimum
Sub Perf_RemoveTipElt()
Dim tb(9999) As Integer, cnt As Integer, timePeriod As Long, tot As Integer
Dim treeNbrs As New UcTree, numb As UcNumber ', key As Integer
'Insertion
    Set CrtTreeNumbers = treeNbrs
    Gen10000 tb, 0, 2, 4, 6
    'Debug.Print "Start Insertion !"
    StartTimer
    For cnt = 0 To 9999
        Set numb = New UcNumber
        numb.Val = tb(cnt)
        treeNbrs.AddElement numb, False
    Next cnt
    timePeriod = StopTimer()
    tot = treeNbrs.Total
    'Debug.Print "Stop : " & tot & " valeurs ajoutées en " & timePeriod & " ms !"
    AjoutePerf 0, timePeriod
'Suppression
    'Debug.Print "Start Suppression !"
    StartTimer
    For cnt = 0 To 9999
        treeNbrs.RemoveTipElt True
    Next cnt
    timePeriod = StopTimer()
    tot = tot - treeNbrs.Total
    'Debug.Print "Stop : " & tot & " valeurs supprimées en " & timePeriod & " ms !"
    AjoutePerf 2, timePeriod
End Sub

'typ 0(col 1) => Insertion, typ 1(col 2) => Suppresion, typ 2(col 3) => Suppression par le minimum
Sub AjoutePerf(typ As Integer, perf As Long)
Static nbLig(2) As Integer
Dim wkt As Worksheet
    Set wkt = S_Res 'A Adapter
    If nbLig(typ) = 0 Then nbLig(typ) = 2
    S_Res.Cells(nbLig(typ), typ + 1) = perf
    nbLig(typ) = nbLig(typ) + 1
    DoEvents
End Sub

Voici le bilan de ce test de performance sur ma machine qui commence à dater un peu; du coup prière de ne pas se moquer...
Regarde la pièce jointe 1191744
A noter que sans interface, l'insertion est 3X plus lente, la suppression 4X plus lente et la suppression du minimum 2X plus lente.

Pour finir voici un dernier correctif dans Delete ou je propose de retirer la modification de l'algorithme que j'avais rajouté à l'algorithme d'origine et qui n'apporte rien, voir est un chouya plus lente. Et je retire la dernière instruction qui ne sert plus à rien car elle est désormais dans RemoveElement. C'était comme cela dans deux autres algos, il y avait forcément une raison même si cela me semblait plus logique ...

'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)
    Set nodT = nod.Left: Delete = RmvMaxLeaf(nodT): Set nod.Left = nodT 'Toujours à gauche !
    If Delete Then Delete = BalAfterLeftDel(nod)
End Function

hi, ça me rappelle mes débuts de programmation en C (natif qui plus est ) avec les tables de pointeurs à deux niveaux hi hi ça pique....

 

[Lu76Fer]

hi, ça me rappelle mes débuts de programmation en C (natif qui plus est ) avec les tables de pointeurs à deux niveaux hi hi ça pique....

L'algo en C que j'ai converti au départ n'était pas coton à lire avec les noms des paramètres seuls dans chaque fonction et leur déclaration en dessous sans compter tous les retours à la ligne. J'ai dû le réécrire de façon plus moderne pour comprendre quelque chose puis renommer les fonctions et surtout commenter ...
Est-ce que ce n'est pas cela du C natif ?

void*
nodereplace (record, cmpfunc, node, userparm)
void    *record;
int    (*cmpfunc)();
ppNODE    node;
int    userparm;
{
    inserted = NULL;
    insert (record, cmpfunc, node, userparm, TRUE);
    return inserted;
}

 

[Lu76Fer]

Comme on me l'a fait remarquer, mon générateur n'est pas un générateur de nombre non séquentiel mais plutôt un générateur de séquence de nombre non Incrémentale.

Du coup, j'ai écrit une version plus générique : Génère une séquence décimale non incrémentale

 

[Lu76Fer]

2ème Mini patch = Grande conséquence
En poursuivant un autre projet d'animation, j'ai constaté que mon arbre n'était plus équilibré et du coup ne jouait pas du tout son rôle. Tous les algorithmes déjà publiés sur cette discussion sont concernés !
En faite, j'avais fait mes tests sur un tout petit jeu de données mais j'ai ensuite optimisé le code sans refaire les tests ...
Concrètement, j'ai décalé les valeurs d'équilibre de l'objet UcNode mais il fallait du coup initialiser la valeur d'équilibre au moment de la création d'un nouveau UcNode :

'CODE A CORRIGER dans le module de classe UcNode
Private Function Insert(elt As IfTree, 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: nod.Bal = 2: Set nod.Element = elt: Set RefElt = elt

nod.Bal = 2 a été ajouté.

Afin de simplifier les tests pour contrôler le bon fonctionnement de son interfaçage avec cette structure d'arbre AVL, j'ai ajouté une fonction d'affichage simplifié de l'arbre sur une feuille de classeur. J'ai dû modifier légèrement la fonction de recherche FindElement pour donner la possibilité d'afficher un sous-arbre à partir d'une valeur key. Enfin, j'ai ajouté dans l'interface une fonction qui permet d'accéder à la valeur clé d'un élément de l'arbre :

'CODE A RAJOUTER dans ifTree :
Property Get Value() As Variant
'Récupérer la valeur de l'élément souvent Value = Key
End Property

'CODE A REMPLACER dans UcTree :
'Renvoie l'Elément identifié par key dans l'arbre Tree ou Nothing si non présent
Function FindElement(key As Variant) As IfTree
    Set FindElement = FindNodElt(key, Tree): Set RefNode = Nothing
End Function

'Partie récursive de la fonction FindElement
Private Function FindNodElt(key As Variant, nod As UcNode) As IfTree
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: Set RefNode = nod
End Function

'CODE A AJOUTER dans UcTree :
'Affiche les valeurs de l'arbre à partir de la cellule fromCell
Sub DisplayTree(fromCell As Range, Optional key As Variant = Null)
Dim nod As UcNode
    If IsNull(key) Then
        Set RefNode = Tree
    Else
        FindNodElt key, Tree
        If RefNode Is Nothing Then Exit Sub
    End If
    DisplayNode fromCell, RefNode
    Set RefNode = Nothing
End Sub

'Partie récursive de la procédure DisplayTree
Private Sub DisplayNode(area As Range, nod As UcNode)
Dim col As Range
    Set col = area.Worksheet.Columns(area.Column)
    If Not (nod Is Nothing) Then
        If Not (nod.Left Is Nothing) Then col.Insert xlToRight: DisplayNode area.Offset(1, -1), nod.Left
        area = nod.Element.Value
        If Not (nod.Right Is Nothing) Then col.Offset(, 1).Insert xlToRight: DisplayNode area.Offset(1, 1), nod.Right
    End If
End Sub

Performances réelles de cette structure
Après correction, j'ai donc dû refaire les tests et j'obtiens des résultats différents et globalement beaucoup plus satifaisant :

Exploitation de cette structure d'arbre AVL
Si vous êtes intéressez par ce code et que vous souhaitez une version fichier xlsm synthétique et prête à l'emploie n'hésitez pas à me demandez le fichier; je le mettrais alors à votre disposition.

 

[Lu76Fer]

Encore un correctif, j'espère le dernier
Il restait une anomalie qui n'était pas visible sur le test massif et concerne la fonction RemoveTipElt.
Le calcul des valeurs de balance est fait par la fonction récursive et BalAfterLeftDel et BalAfterRightDel n'ont rien à faire dans cette fonction :

'CODE A REMPLACER dans UcTree :
Function RemoveTipElt(isMin As Boolean, Optional filter As Boolean = False) As IfTree
    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: Total = Total - 1
        Exit Function
    End If
    If isMin Then RmvMinLeaf Tree, filter Else RmvMaxLeaf Tree, filter
    Set RemoveTipElt = RefNode.Element: Set RefNode = Nothing: Total = Total - 1
End Function

J'entend déjà le bruit muet des critiques ...

 

[SAMUAL_2023]

Salut à toi Lu76Fer, certes c'est du fer solide ce que tu proposes...
Pour moi, j'utiliserai ton test scripts AVL + dictionary afin d'optimiser l'utilisation de ton code encore le challenge et que l'on utilise des classes objects modules afin de rendre la boîte insta'ciée plus stable premièrement et secondo, il serait aussi intéressant d'utiliser des fonctions array afin de rendre le tri au niveau du micro process plus rapide à lire et à traiter avant de le balancer sur la matrice de la feuille (traitements + suppression + addition + déplacement up/down) associée un type de Function Quick Sort sur plusieurs paliers de UDF (Fonctions personnalisées) pour optimiser le calcul au niveau du shipset + compilation et interprètation de la machine...
C'est bien d'être un peu fou pour garder une certains noblesse et être humble ...

À toi de jouer et

 

[Lu76Fer]

Salut à toi Lu76Fer, certes c'est du fer solide ce que tu proposes...
Pour moi, j'utiliserai ton test scripts AVL + dictionary afin d'optimiser l'utilisation de ton code encore le challenge et que l'on utilise des classes objects modules afin de rendre la boîte insta'ciée plus stable premièrement et secondo, il serait aussi intéressant d'utiliser des fonctions array afin de rendre le tri au niveau du micro process plus rapide à lire et à traiter avant de le balancer sur la matrice de la feuille (traitements + suppression + addition + déplacement up/down) associée un type de Function Quick Sort sur plusieurs paliers de UDF (Fonctions personnalisées) pour optimiser le calcul au niveau du shipset + compilation et interprètation de la machine...
C'est bien d'être un peu fou pour garder une certains noblesse et être humble ...

À toi de jouer et

Merci Samual_2023 pour ton intérêt,

Ton idée m'échappe un peu, de mon côté j'ai utilisé cet arbre pour interfacer des "minuteries" et créer des animations. J'ai dû ajouter une gestion spécifique pour gérer les déclenchements simultanés car un arbre ne permet pas de gérer les données égales et pour cela j'utilise un dictionnaire au niveau de mon interface.
Je peux te laisser la dernière version de mon arbre mais il se limite aux méthodes classiques d'un algo de ce type ainsi que quelques méthodes que j'ai ajoutées pour l'affichage de l'arbre sur une feuille, la recherche ou la suppression du plus petit ou plus grand élément.
Pour le reste c'est à toi de jouer et si besoin je suis toujours là pour apporter ma contribution ... Je me suis absenté du site un moment mais je serais connecté à l'avenir si besoin.
Je vais laisser une nouvelle version de l'arbre AVL avec la classe Number pour montrer comment utiliser l'interface dans mon prochain message après avoir fait du ménage et corrigé la méthode RemoveTipElt.
A suivre ...​

 

[Lu76Fer]

Bonjour à toutes et tous,

En réponse au dernier message voici la dernière version de l'arbre AVL avec une classe Number comme application pratique de l’interfaçage d'un modèle objet avec cette structure.
J'ai corrigé 2 erreurs sur le filtre qui ne fonctionnait pas correctement. Celui-ci permet lors d'une suppression ou d'une recherche d'exclure les valeurs répondant VRAI à la condition de la méthode de l'interface IfTree_FilterElt.​