Jeu sous Excel - VBA : "Le Boogle" [tactile/souris]

Introduction

Ce tutoriel est la conséquence de cette discussion. J'en profite pour remercier tous les participants et, tout particulièrement, les trois protagonistes que sont Carlvb, ucfoutu et Whismeril.
Pour comprendre ce tutoriel, inutile d'être un expert en VBA. Cependant, certaines notions doivent être assimilées au préalable. Notamment, les variables tableaux, les Objets Range & Dictionary, les bases des classes en VBA sont des notions qui se doivent d'être connues.

Présentation

Ce jeu est une adaptation, au logiciel de bureautique Excel via VBA, du célèbre jeu de lettres « Boggle » conçu par Alan Turoff et déposé par Parker Brothers / Hasbro.
Pour en saisir le fonctionnement, il nous faut tout d'abord en définir les règles du jeu (Extrait de l'article Wikipédia).

Règles

Le jeu commence par le mélange d'un plateau (carré) de 16 dés à 6 faces, généralement en le secouant. Chaque dé possède une lettre différente sur chacune de ses faces. Les dés sont rangés sur le plateau 4 par 4, et seule leur face supérieure est visible. Le joueur cherche, en 3 minutes, le plus possible de mots pouvant être formés à partir de lettres adjacentes du plateau. Par « adjacentes », il est sous-entendu horizontalement, verticalement, ou en diagonale. Le « chemin » parcouru pour former un mot peut être un mélange de ces trois directions, le sens emprunté au départ n'est pas nécessairement conservé. Les mots doivent être de 3 lettres au minimum, peuvent être au singulier ou au pluriel, conjugués ou non, mais ne doivent pas utiliser plusieurs fois le même dé pour un même mot.

Attribution des points

Les points sont attribués suivant la taille des mots trouvés. Les mots de 3 et 4 lettres comptabilisent 1 point, ceux de 5 lettres 2 points, 6 lettres 3 points, 7 lettres 5 points et 8 lettres (et plus) 11 points.

Le tirage aléatoire des 16 dés

Description

Les lettres composant les 6 faces de ces 16 dés sont fixées :
"ETUKNO", "EVGTIN", "DECAMP", "IELRUW", "EHIFSE", "RECALS", "ENTODS", "OFXRIA", "NAVEDZ", "EOIATA", "GLENYU", "BMAQJO", "TLIBRA", "SPULTE", "AIMSOR", "ENHRIS".
Le tirage de ces dés doit être aléatoire, c'est-à-dire que chaque dé doit retomber, sur une face aléatoire ET dans une case de notre grille de manière aléatoire également. Pour cela, nous allons avant tout fixer notre grille ainsi que les différentes possibilités de lettres pour les dés.

Set Grille = Worksheets("Tirage").Range("A1:D4")
cubes = Array("ETUKNO", "EVGTIN", "IELRUW", "DECAMP", "EHIFSE", "RECALS", _
"ENTDOS", "OFXRIA", "NAVEDZ", "EIOATA", "GLENYU", "BMAQJO", "TLIBRA", _
"SPULTE", "AIMSOR", "ENHRIS")

Mélanger les dés

La procedure de mélange

Nous voulons mélanger les dés afin qu'ils ne tombent pas systématiquement sur la même case (cellule) de notre grille (Range). Placer les dés équivaut, dans notre code, à les mélanger dans leur numérotation. Nous allons donc mélanger les valeurs de l'Array cubes :

Private Sub touille_cubes(ByRef cubes)
 Dim i As Integer, nb As Integer, ou As Integer, temp As String
 nb = UBound(cubes)
'le mélange se fait 2 par 2, donc la boucle se fait sur la moitié 
 For i = 0 To nb / 2
  'ou = variable déterminant l'indice auquel est situé le dé dans l'array cubes
   ou = Int(((15 - i) * Rnd))
  'variable de stockage temporaire
   temp = cubes(ou)
  'on « déplace » les deux dés = mélanger l'array cubes
   cubes(ou) = cubes(nb - i)
   cubes(nb - i) = temp
 Next
End Sub

Variante

Il ne s'agit que d'une variante de la procédure précédente.

For i = 1 To 16
        j = 1 + Int(16 * Rnd())
        While Cubes_Touilles(j) <> ""
            j = 1 + Int(16 * Rnd())
        Wend
        Cubes_Touilles(j) = Cubes(i)
    Next i

Tirage au sort des lettres

Une fois cette répartition des cubes réalisée, ne reste plus qu'à tirer, par dé, une lettre aléatoirement en fonction de sa position et la placer dans une cellule de notre Range Grille :

Randomize Timer
  For Each Cel In Grille
      carac = CInt((5 * Rnd()) + 1)
      Cel.Value = Mid(cubes(cpt), carac, 1)
      cpt = cpt + 1
  Next Cel

Code complet

Les deux procédures vues précédemment, avec les déclarations de variable nous donnent les codes suivants :

Sub Tirage()
Dim cubes As Variant
Dim cpt As Byte, carac As Integer
Dim Grille As Range, Cel As Range

Set Grille = Worksheets("Tirage").Range("A1:D4")
cubes = Array("ETUKNO", "EVGTIN", "IELRUW", "DECAMP", "EHIFSE", "RECALS", _
"ENTDOS", "OFXRIA", "NAVEDZ", "EIOATA", "GLENYU", "BMAQJO", "TLIBRA", _
"SPULTE", "AIMSOR", "ENHRIS")

  Randomize Timer
  touille_cubes cubes 
  For Each Cel In Grille
      carac = CInt((5 * Rnd()) + 1)
      Cel.Value = Mid(cubes(cpt), carac, 1)
      cpt = cpt + 1
  Next Cel
End Sub
Private Sub touille_cubes(ByRef cubes)
 Dim i As Integer, nb As Integer, ou As Integer, temp As String
 nb = UBound(cubes)
 For i = 0 To nb / 2
   ou = Int(((15 - i) * Rnd))
   temp = cubes(ou)
   cubes(ou) = cubes(nb - i)
   cubes(nb - i) = temp
 Next
End Sub

Le dictionnaire

Comme pour tout jeu de lettres, cet élément est indispensable au bon déroulement du jeu. Nous avons donc besoin d'un dictionnaire le plus complet possible, comprenant les conjugaisons des verbes, les pluriels et singuliers des mots de 3 à 16 lettres.
Nous souhaitons obtenir un fichier texte composé d'un mot par ligne. Il existe plusieurs solutions pour la création de ce dictionnaire. Nous allons en détailler ici deux : à partir d'un fichier texte existant et à partir d'un site Internet.

Création à partir d'un fichier texte

Cf tutoriel : Lecture Modification Enregistrement txt

Création à partir d'un site Internet

Cf tutoriel : Dictionnaire texte à partir de données Internet

Chargement du dictionnaire

Compilation du dictionnaire

Cf tutoriel : Compilation d'un dictionnaire en structure d'arbre

Chargement en mémoire

Pour charger en mémoire un dictionnaire, nous avons deux possibilités. Soit nous chargeons un dictionnaire brut (texte avec un mot par ligne), soit nous chargeons un dictionnaire compilé avec une structure d'arbre.
Pour charger un dictionnaire brut en mémoire, il nous suffit de reprendre la méthode utilisée dans le chapitre précédent pour construire un dictionnaire compilé, en y enlevant la partie d'écriture du fichier texte.
Pour charger un dictionnaire compilé en structure d'arbre, il suffit de suivre les indications du dictionnaire compilé. A savoir :
- "[" indique qu'on descend d'un niveau pour parcourir un noeud fils,
- "(" indique qu'on passe au noeud suivant le noeud actuel,
- "]" indique qu'on remonte d'un niveau vers le noeud parent,
- "." indique la fin d'un chemin, et donc d'un mot.
Ce qui nous donne le code suivant :

MonDico = "C:\dicos compiles\MonDico.txt" 'A ADAPTER BIEN SUR
 Open MonDico For Input As #FF
    Line Input #1, Lettre
    'Vérification de l'entête du fichier et récupération du nombre de mots dans le dictionnaire compilé
    If Left(Lettre, 6) <> "NBMOTS" Then
        MsgBox "Le fichier sélectionné n'est pas un dictionnaire compilé", vbCritical
        Close #FF
        Exit Sub
    End If
    Set Noeud_Actuel = Debut
    While Not EOF(FF)
        Line Input #1, Lettre
'On construit l'arbre à partir des indications dans le dictionnaire compilé
        If Lettre = "[" Then
            Line Input #1, Lettre
            Set Noeud_Actuel = Ajouter_Fils(Noeud_Actuel, Lettre)
        End If
        If Lettre = "(" Then
            Line Input #1, Lettre
            Set Noeud_Actuel = Ajouter_Suivant(Noeud_Actuel, Lettre)
        End If
        If Lettre = "]" Then
            Set Noeud_Actuel = Noeud_Actuel.Parent
        End If
    Wend
    Close #FF

La recherche des solutions

Il existe plusieurs possibilités pour trouver toutes les solutions, contenues dans le dictionnaire, à partir des lettres de notre grille. Nous avons retenu pour ce projet la solution la plus rapide, à savoir la recherche dans un dictionnaire structuré en arbre. Nous aurions également pu choisir une recherche récursive des mots à partir d'une liste restreinte de notre dictionnaire.

La recherche récursive

La question, à cette étape, se pose : Qu'elle méthode utiliser pour la recherche des solutions ? Il est évident qu'une procédure récursive exige, au préalable, la réduction du dictionnaire. Nous ne pouvons effectivement pas réaliser une boucle sur chacune des lettres de plus de 300000 mots. Il s'avère que malgré une réduction drastique de ce dernier, la recherche dure encore beaucoup trop longtemps pour être réellement fonctionnelle dans un jeu.
Pour information, lors du développement, nous avons abandonné cette piste avec des résultats entre 7 et 30 secondes selon les différentes grilles testées. Ces temps nous ont alors poussé vers la solution de recherche dans une structure d'arbre, solution proposée par Carlvb.

La recherche « dans l'arbre »

Pour effectuer cette recherche, nous allons avoir besoin d'un module de classe Classe_Solutions et de plusieurs fonctions.

Le Module de classe

Tout comme la Classe_Noeud (Cf tutoriel : Compilation d'un dictionnaire en structure d'arbre), le code en est très simple, et se réduit à deux déclarations de variables constituant un « Objet ».

'Cette classe représentent un noeud dans la liste des solutions triées par ordre alphabétique
Public Valeur As String
Public Fils As Classe_Solution

Les fonctions

La fonction principale

Cette procédure recherche les mots dans le dictionnaire qu'on peut former à partir de la grille tout en respectant les règles.

Sub Lister_Solution()
    Dim pris() As Boolean
    Dim i As Integer, j As Integer, c As Integer
    'Initialisation de la chaine des solutions
    Set Solution = New Classe_Solution
    Solution.Valeur = "AAA"
    'On recherche les mots commençant par les 16 lettres du tirage successivement
    Dim z As Boolean
    For i = 1 To 4
    For j = 1 To 4
        ReDim pris(1 To 4, 1 To 4)
        pris(i, j) = True
        z = trouve(Debut, TIRAGE(i, j))
        Lister TIRAGE(i, j), i, j, pris
    Next j
    Next i
End Sub

La recherche proprement dite

Sub Lister(Racine As String, ByVal Ligne As Integer, ByVal Colonne As Integer, Grille() As Boolean)
    Dim X As Integer, Y   As Integer
    Dim Nouvelle_Racine As String
    Dim Nouvelle_Grille(1 To 4, 1 To 4) As Boolean
    Copier_Grille Grille, Nouvelle_Grille
    'Une grille de 4x4 est utilisée pour noter les lettres déjà utilisées afin de ne pas pouvoir les réutiliser
    
    'On parcourt de manière récursive les cases adjaçantes à une case pour rechercher les mots
    For X = Ligne - 1 To Ligne + 1
    For Y = Colonne - 1 To Colonne + 1
        If X >= 1 Then
        If X <= 4 Then
            If Y >= 1 Then
            If Y <= 4 Then
                'On n'utilise la lettre dans une case qu'une seule fois
                If Not Nouvelle_Grille(X, Y) Then
                    'Si un chemin peut mener à un mot du dictionnaire, on le suit
                   If trouve(Noeud_Actuel, TIRAGE(X, Y)) Then
                        Nouvelle_Racine = Racine & TIRAGE(X, Y)
                        Nouvelle_Grille(X, Y) = True
                        'Si le chemin aboutit à un noeud final c'est qu'il s'agit d'un mot valide
                        'Si le mot ainsi trouvé a une taille d'au moins trois lettres, on l'insère dans la chaîne des solutions
                        If trouve(Noeud_Actuel, ".") Then
                            If Len(Nouvelle_Racine) >= 3 Then
                                Ajouter_Solution Nouvelle_Racine
                            End If
                            Set Noeud_Actuel = Noeud_Actuel.Parent
                        End If
                        Lister Nouvelle_Racine, X, Y, Nouvelle_Grille
                        Set Noeud_Actuel = Noeud_Actuel.Parent
                        Nouvelle_Grille(X, Y) = False
                    End If
                End If
            End If
            End If
        End If
        End If
    Next Y
    Next X
End Sub

Les fonctions d'ajout des solutions

La liste des solutions est stockée sous forme de chaine dont les maillons représentent une solution trouvée. Le tri et la suppression des doublons se font par insertion :
On parcourt la chaine pour repérer l'endroit où la nouvelle solution doit être insérée et si une occurrence de cette solution est déjà dans la chaîne on ne l'y insère plus.

Sub Ajouter_Solution(Nouvelle_Solution As String)
    Dim Ancien_Fils As Classe_Solution, Nouveau_Fils As Classe_Solution

    Set Maillon = Solution
    
    While Not Maillon.Fils Is Nothing
        If Maillon.Fils.Valeur = Nouvelle_Solution Then Exit Sub
        If Maillon.Fils.Valeur > Nouvelle_Solution Then
            Set Ancien_Fils = Maillon.Fils
            Set Nouveau_Fils = Inserer(Maillon, Nouvelle_Solution)
            Set Nouveau_Fils.Fils = Ancien_Fils
            Exit Sub
        End If
        Set Maillon = Maillon.Fils
    Wend
        
    Set Maillon = Inserer(Maillon, Nouvelle_Solution)
    Set Ancien_Fils = Nothing
    Set Nouveau_Fils = Nothing
End Sub

Public Function Inserer(ByVal Noeud As Classe_Solution, Mot As String) As Classe_Solution
    'Cette fonction rajoute une nouvelle solution à la fin de la chaine des solutions
    Set Inserer = New Classe_Solution
    Inserer.Valeur = Mot
    Set Noeud.Fils = Inserer
End Function

Fonction secondaire

Cette procédure copie le contenu d'un tableau vers un autre

Sub Copier_Grille(source() As Boolean, Destination() As Boolean)
    Dim i As Integer, j As Integer
    For i = 1 To 4
    For j = 1 To 4
        Destination(i, j) = source(i, j)
    Next j
    Next i
End Sub

Laisser la main au joueur

Cf tutoriel : DoEvents en boucle : Problème de surcharge du processeur

Le design d'un jeu sous VBA Excel

Cf discussion : https://forums.commentcamarche.net/forum/affich-29822256-realisation-d-une-image-pour-le-design-d-un-jeu
Tutoriel en construction

Téléchargement

Le jeu complet est disponible au format .zip (3,69 Mo) ici : https://www.cjoint.com/c/DHflX2rRnOQ
Vous y retrouverez les codes décrits ici ainsi que pas mal d'autres petites subtilités.
Le jeu se déroule depuis un UserForm. Pour revenir sur les feuilles du classeur et ainsi pouvoir accéder au code, vous pouvez aller dans l'Userform Menu, bouton "Crédits" => bouton "retour"

N'hésitez pas à me signaler tous bugs et/ou dysfonctionnements éventuellement rencontrés...
Merci à vous.