Encore un Labyrinthe :)

[JCGL]

Re : Encore un Labyrinthe

Bonjour à tous,

Pour ceux que cela peut intéresser, un code de Maître Ti :

Option Explicit'Thierry Pourtier [email]tpourtier@wanadoo.fr[/email]
'transcription d'un programme QBasic de N. Bernier


Const Noir = 1
'taille du labyrinthe
Const NbLgn = 31
Const NbCol = 31


Dim PlageLaby As Range


Private Sub Trace(Lgn As Long, Col As Long)
    With PlageLaby
        .Cells(Lgn, Col).Interior.ColorIndex = xlNone
    End With
End Sub


Private Function EstMur(Lgn As Long, Col As Long) As Boolean
    With PlageLaby
        EstMur = .Cells(Lgn, Col).Interior.ColorIndex <> xlNone
    End With
End Function


Private Sub GenereLabyrinthe()
    Dim NbSens As Byte, Lgn As Long, Col As Long
    Dim NbBlancs As Long, MaxBlancs As Long
    Dim Dir(1 To 4) As Byte


    Randomize
    MaxBlancs = ((NbLgn - 2) * (NbCol - 2)) - ((NbLgn - 3) * ((NbCol - 2) \ 2))
    Lgn = 2
    Col = 2


    Trace Lgn, Col
    NbBlancs = 1


    Do
        NbSens = 0
        If Not EstMur(Lgn, Col) Then    ' Si je suis sur une case blanche...
            If Lgn + 2 < NbLgn Then    ' Je peux aller en bas ?
                If EstMur(Lgn + 2, Col) Then
                    NbSens = NbSens + 1
                    Dir(NbSens) = 1
                End If
            End If
            If Col + 2 < NbCol Then    ' Je peux aller à droite ?
                If EstMur(Lgn, Col + 2) Then
                    NbSens = NbSens + 1
                    Dir(NbSens) = 2
                End If
            End If
            If Lgn - 2 > 1 Then    ' Je peux aller en haut ?
                If EstMur(Lgn - 2, Col) Then
                    NbSens = NbSens + 1
                    Dir(NbSens) = 3
                End If
            End If
            If Col - 2 > 1 Then    ' Je peux aller à gauche ?
                If EstMur(Lgn, Col - 2) Then
                    NbSens = NbSens + 1
                    Dir(NbSens) = 4
                End If
            End If


            If NbSens > 0 Then
                Select Case Dir(Int(Rnd * NbSens) + 1)    ' Choix d'une direction possible
                    Case 1    ' en bas
                        Trace Lgn + 1, Col
                        Trace Lgn + 2, Col
                        Lgn = Lgn + 2
                        NbBlancs = NbBlancs + 2
                    Case 2    ' à droite
                        Trace Lgn, Col + 1
                        Trace Lgn, Col + 2
                        Col = Col + 2
                        NbBlancs = NbBlancs + 2
                    Case 3    ' en haut
                        Trace Lgn - 1, Col
                        Trace Lgn - 2, Col
                        Lgn = Lgn - 2
                        NbBlancs = NbBlancs + 2
                    Case 4    ' à gauche
                        Trace Lgn, Col - 1
                        Trace Lgn, Col - 2
                        Col = Col - 2
                        NbBlancs = NbBlancs + 2
                End Select
            End If
        End If


        If NbSens = 0 Then    ' Si aucune direction possible ...
            Lgn = Lgn + 2    ' ... case suivante
            If Lgn > NbLgn - 1 Then
                Lgn = 2
                Col = Col + 2
            End If
            If Col > NbCol - 1 Then Col = 2
        End If
    Loop Until NbBlancs = MaxBlancs
End Sub


Sub NouveauLabyrinthe()
    Dim Depart As Long, Arrivee As Long
    'nettoyage de la PlageLaby maximale
    Set PlageLaby = Range("A1").Resize(NbLgn, NbCol)
    With PlageLaby
        .Interior.ColorIndex = Noir
        .Value = ""
    End With


    GenereLabyrinthe


    ' Dessine une entrée ...
    Depart = Int(Abs(Rnd * NbLgn / 2 - 1)) * 2 + 2
    Arrivee = Int(Abs(Rnd * NbLgn / 2 - 1)) * 2 + 2
    Trace Depart, 1
    PlageLaby.Cells(Depart, 1) = "D"
    ' ... et une sortie
    Trace Arrivee, NbCol
    PlageLaby.Cells(Arrivee, NbCol) = "A"
End Sub

A+ à tous

 

[tototiti2008]

Re : Encore un Labyrinthe

Bonjour à toutes et tous,

@Modeste GD : Sympa ton labyrinthe, j'ai à peu près compris ton principe de traçage même si des détails m'échappent encore , le pacman est tout simplement bluffant .
@JC : Encore du code à tester, je vais voir si je comprend le principe en faisant tourner ça en pas à pas