Labyrinthe tableau

Le 23/08/2023 à 10:26

Bonjour

j'ai téléchargé le fichier labyrinthe sur ce site genlabyv2

mais je voudrais que la macro qui cherche le résultat soit une seconde macro, j'ai fais quelques modifs mais la 2nde macro bloque avec stack(st, 0) = TA(x, y).Value et plus précisément TA(x, y)

si vous avez une idée

16genlabyv2.xlsm (30.35 Ko)
Sub Labyrinthe()
    Dim TA() As Integer, stack() As Integer
    s = Val(InputBox("Génération d'un labyrinthe carré" & Chr(10) & "Dimension du coté"))
    Randomize Timer
    ReDim TA(s, s) As Integer
    ReDim stack(s * s, 2) As Integer
    Cells.Clear
    With Range(Cells(2, 2), Cells(s + 1, s + 1))
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Borders(xlEdgeBottom).Weight = xlThick
        .Borders(xlEdgeTop).Weight = xlThick
        .Borders(xlEdgeLeft).Weight = xlThick
        .Borders(xlEdgeRight).Weight = xlThick
        .Borders(xlInsideVertical).Weight = xlThick
        .Borders(xlInsideHorizontal).Weight = xlThick
    End With
    '------------------------
    'génération du labyrinthe
    '------------------------
    x = Application.RandBetween(1, s)
    y = 1
    kx = 1
    ky = 0
    sx = x: sy = y
    Cells(x + 1, y + 1).Borders(xlEdgeLeft).LineStyle = xlNone
    ncase = s * s - 1
    While Not fini
        nc = Application.RandBetween(1, 2 * s)
        np = 0
        possible = True
        While nc > 0 And possible
            d = Application.RandBetween(1, 4)
            Select Case d
            Case 1    ' go down
                If x < s Then
                    If TA(x + 1, y) = 0 Then
                        TA(x, y) = TA(x, y) Or 4
                        Cells(x + 1, y + 1).Borders(xlEdgeBottom).LineStyle = xlNone
                        x = x + 1
                        TA(x, y) = TA(x, y) Or 1
                        Cells(x + 1, y + 1).Borders(xlEdgeTop).LineStyle = xlNone
                        nc = nc - 1: ncase = ncase - 1
                    Else
                        np = np Or 1
                    End If
                Else
                    np = np Or 1
                End If
            Case 2    ' go left
                If y > 1 Then
                    If TA(x, y - 1) = 0 Then
                        TA(x, y) = TA(x, y) Or 2
                        Cells(x + 1, y + 1).Borders(xlEdgeLeft).LineStyle = xlNone
                        y = y - 1
                        TA(x, y) = TA(x, y) Or 8
                        Cells(x + 1, y + 1).Borders(xlEdgeRight).LineStyle = xlNone
                        nc = nc - 1: ncase = ncase - 1
                    Else
                        np = np Or 2
                    End If
                Else
                    np = np Or 2
                End If
            Case 3    'go up
                If x > 1 Then
                    If TA(x - 1, y) = 0 Then
                        TA(x, y) = TA(x, y) Or 1
                        Cells(x + 1, y + 1).Borders(xlEdgeTop).LineStyle = xlNone
                        x = x - 1
                        TA(x, y) = TA(x, y) Or 4
                        Cells(x + 1, y + 1).Borders(xlEdgeBottom).LineStyle = xlNone
                        nc = nc - 1: ncase = ncase - 1
                    Else
                        np = np Or 4
                    End If
                Else
                    np = np Or 4
                End If
            Case 4    ' go right
                If y < s Then
                    If TA(x, y + 1) = 0 Then
                        TA(x, y) = TA(x, y) Or 8
                        Cells(x + 1, y + 1).Borders(xlEdgeRight).LineStyle = xlNone
                        y = y + 1
                        TA(x, y) = TA(x, y) Or 2
                        Cells(x + 1, y + 1).Borders(xlEdgeLeft).LineStyle = xlNone
                        nc = nc - 1: ncase = ncase - 1
                    Else
                        np = np Or 8
                    End If
                Else
                    np = np Or 8
                End If
            End Select
            If np = 15 Then possible = False
        Wend
        If ncase = 0 Then
            fini = True
        Else
            Do
                If ncase / (s * s) > 0.1 Then
                x = Application.RandBetween(1, s)
                y = Application.RandBetween(1, s)

                DoEvents
                Else
                 ky = ky + 1: If ky > s Then ky = 1: kx = kx + 1: If kx > s Then kx = 1: ky = 0
                 x = kx: y = ky
                End If
                DoEvents
            Loop Until TA(x, y) <> 0
        End If
    Wend
    x = Application.RandBetween(1, s): fx = x
    y = s: fy = y
    Cells(x + 1, y + 1).Borders(xlEdgeRight).LineStyle = xlNone
    x = sx: y = sy

Cells(1, 22) = "X"
Cells(1, 23) = "Y"
Cells(1, 1) = x
Cells(1, 2) = y
a = 2

For i = LBound(TA) To UBound(TA)
Cells(a, 22) = TA(1, i)
Cells(a, 23) = TA(2, i)
a = a + 1
Next i

End Sub

Sub recherche_solution()
Dim TA() As Variant, stack() As Variant

DERLNG = Cells(2, 22).End(xlDown).Row
x = Range(Cells(2, 22), Cells(DERLNG, 22)).Value
y = Range(Cells(2, 23), Cells(DERLNG, 23)).Value

'x = Cells(1, 1)
'y = Cells(1, 2)
'a = Cells(1, 3)
st = 1
'ReDim TA(s, s) As Integer
'stack = Range(Cells(2, 22), Cells(DERLNG, 23)).Value
'stack(st, 0) = TA(x, y)
stack(st, 0) = TA(x, y).Value

stack(st, 1) = x
stack(st, 2) = y
    Do
        If stack(st, 0) <> 0 Then
            If stack(st, 0) And 1 Then
                Cells(x + 1, y + 1) = ">": Cells(x + 1, y + 1).Orientation = 90
                stack(st, 0) = stack(st, 0) - 1: st = st + 1: x = x - 1: stack(st, 0) = TA(x, y) - 4
            ElseIf stack(st, 0) And 2 Then
                Cells(x + 1, y + 1) = "<": Cells(x + 1, y + 1).Orientation = 0
                stack(st, 0) = stack(st, 0) - 2: st = st + 1: y = y - 1: stack(st, 0) = TA(x, y) - 8
            ElseIf stack(st, 0) And 4 Then
                Cells(x + 1, y + 1) = ">": Cells(x + 1, y + 1).Orientation = -90
                stack(st, 0) = stack(st, 0) - 4: st = st + 1: x = x + 1: stack(st, 0) = TA(x, y) - 1
            ElseIf stack(st, 0) And 8 Then
                Cells(x + 1, y + 1) = ">": Cells(x + 1, y + 1).Orientation = 0
                stack(st, 0) = stack(st, 0) - 8: st = st + 1: y = y + 1: stack(st, 0) = TA(x, y) - 2
            End If
            stack(st, 1) = x
            stack(st, 2) = y
            'Cells(x + 1, y + 1) = "o"
        Else
            While stack(st, 0) = 0
                Cells(stack(st, 1) + 1, stack(st, 2) + 1) = ""
                st = st - 1
            Wend
            x = stack(st, 1)
            y = stack(st, 2)
        End If

    Loop Until x = fx And y = fy
    Cells(x + 1, y + 1) = ">": Cells(x + 1, y + 1).Orientation = 0
End Sub
Le 23/08/2023 à 12:09

Bonjour,

ta(x,y) est une array vba et pas une plage de cellules. ta() est définie au niveau de la procédure et disparait à la fin de la procédure. Tu ne peux donc pas simplement réutiliser cette variable sans modifier les macros.

Une manière simple de faire en sorte qu'une variable soit visible pour toutes les procédures d'un module, est de les définir en tête de module avant toute sub et toute fonction, et ne plus les définir à l'intérieur de chaque module.

Pour rendre visible dans tout le module, donc accessible par toutes les procédures et fonctions du module

dim ta() as variant

Pour rendre visible dans tous les modules

public ta() as variant ou global ta() as variant

Cet algorithme de recherche est loin d'être optimum, n'est valable que pour un labyrinthe qui n'a qu'une seule solution et utilise la méthode "longer le mur toujours du même côté, jusqu'à trouver la sortie".

Le 23/08/2023 à 12:29

je ne dois pas être très doué j'ai rajouté public ta() as variant tout en haut en désactivant dim TA dans les modules et le problème est le même

pour mon info perso je ne vois pas quelle est la différence entre array et un tableau sur internet il est indiqué qu'un tableau a une taille fixe, or on peut le redimensionner, comprends pas

Le 23/08/2023 à 12:53

re

array vba ou (tableau en français) vba c'est la même chose, pour vba ce ne sont pas des objets (donc pas de méthode ou de propriété telle que .value). A ne pas confondre avec un tableau excel, qui est une plage de cellules structurée, qui pour VBA est considérée comme un objet (avec des propriétés et des méthodes telles que .value).

voici une adaptation possible, vite faite.

Dim TA() As Integer, s As Integer, sx As Integer, sy As Integer, fx As Integer, fy As Integer
Sub Labyrinthe()

    s = Val(InputBox("Génération d'un labyrinthe carré" & Chr(10) & "Dimension du coté"))
    Randomize Timer
    ReDim TA(s, s) As Integer

    Cells.Clear
    With Range(Cells(2, 2), Cells(s + 1, s + 1))
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Borders(xlEdgeBottom).Weight = xlThick
        .Borders(xlEdgeTop).Weight = xlThick
        .Borders(xlEdgeLeft).Weight = xlThick
        .Borders(xlEdgeRight).Weight = xlThick
        .Borders(xlInsideVertical).Weight = xlThick
        .Borders(xlInsideHorizontal).Weight = xlThick
    End With
    '------------------------
    'génération du labyrinthe
    '------------------------
    x = Application.RandBetween(1, s)
    y = 1
    kx = 1
    ky = 0
    sx = x: sy = y
    Cells(x + 1, y + 1).Borders(xlEdgeLeft).LineStyle = xlNone
    ncase = s * s - 1
    While Not fini
    nc = Application.RandBetween(1, 2 * s)
    np = 0
    possible = True
    While nc > 0 And possible
    d = Application.RandBetween(1, 4)
    Select Case d
        Case 1    ' go down
            If x < s Then
                If TA(x + 1, y) = 0 Then
                    TA(x, y) = TA(x, y) Or 4
                    Cells(x + 1, y + 1).Borders(xlEdgeBottom).LineStyle = xlNone
                    x = x + 1
                    TA(x, y) = TA(x, y) Or 1
                    Cells(x + 1, y + 1).Borders(xlEdgeTop).LineStyle = xlNone
                    nc = nc - 1: ncase = ncase - 1
                Else
                    np = np Or 1
                End If
            Else
                np = np Or 1
            End If
        Case 2    ' go left
            If y > 1 Then
                If TA(x, y - 1) = 0 Then
                    TA(x, y) = TA(x, y) Or 2
                    Cells(x + 1, y + 1).Borders(xlEdgeLeft).LineStyle = xlNone
                    y = y - 1
                    TA(x, y) = TA(x, y) Or 8
                    Cells(x + 1, y + 1).Borders(xlEdgeRight).LineStyle = xlNone
                    nc = nc - 1: ncase = ncase - 1
                Else
                    np = np Or 2
                End If
            Else
                np = np Or 2
            End If
        Case 3    'go up
            If x > 1 Then
                If TA(x - 1, y) = 0 Then
                    TA(x, y) = TA(x, y) Or 1
                    Cells(x + 1, y + 1).Borders(xlEdgeTop).LineStyle = xlNone
                    x = x - 1
                    TA(x, y) = TA(x, y) Or 4
                    Cells(x + 1, y + 1).Borders(xlEdgeBottom).LineStyle = xlNone
                    nc = nc - 1: ncase = ncase - 1
                Else
                    np = np Or 4
                End If
            Else
                np = np Or 4
            End If
        Case 4    ' go right
            If y < s Then
                If TA(x, y + 1) = 0 Then
                    TA(x, y) = TA(x, y) Or 8
                    Cells(x + 1, y + 1).Borders(xlEdgeRight).LineStyle = xlNone
                    y = y + 1
                    TA(x, y) = TA(x, y) Or 2
                    Cells(x + 1, y + 1).Borders(xlEdgeLeft).LineStyle = xlNone
                    nc = nc - 1: ncase = ncase - 1
                Else
                    np = np Or 8
                End If
            Else
                np = np Or 8
            End If
    End Select
    If np = 15 Then possible = False
Wend
If ncase = 0 Then
    fini = True
Else
    Do
        If ncase / (s * s) > 0.1 Then
            x = Application.RandBetween(1, s)
            y = Application.RandBetween(1, s)

            DoEvents
        Else
            ky = ky + 1: If ky > s Then ky = 1: kx = kx + 1: If kx > s Then kx = 1: ky = 0
            x = kx: y = ky
        End If
        DoEvents
    Loop Until TA(x, y) <> 0
End If
Wend
x = Application.RandBetween(1, s): fx = x
y = s: fy = y
Cells(x + 1, y + 1).Borders(xlEdgeRight).LineStyle = xlNone
x = sx: y = sy

Cells(1, 22) = "X"
Cells(1, 23) = "Y"
Cells(1, 1) = x
Cells(1, 2) = y
a = 2

For i = LBound(TA) To UBound(TA)
    Cells(a, 22) = TA(1, i)
    Cells(a, 23) = TA(2, i)
    a = a + 1
Next i

End Sub

Sub recherche_solution()

    Dim stack() As Integer
    ReDim stack(s * s, 2) As Integer
    st = 1
    x = sx
    y = sy
    stack(st, 0) = TA(x, y)
    stack(st, 1) = x
    stack(st, 2) = y
    Do
        If stack(st, 0) <> 0 Then
            If stack(st, 0) And 1 Then
                Cells(x + 1, y + 1) = ">": Cells(x + 1, y + 1).Orientation = 90
                stack(st, 0) = stack(st, 0) - 1: st = st + 1: x = x - 1: stack(st, 0) = TA(x, y) - 4
            ElseIf stack(st, 0) And 2 Then
                Cells(x + 1, y + 1) = "<": Cells(x + 1, y + 1).Orientation = 0
                stack(st, 0) = stack(st, 0) - 2: st = st + 1: y = y - 1: stack(st, 0) = TA(x, y) - 8
            ElseIf stack(st, 0) And 4 Then
                Cells(x + 1, y + 1) = ">": Cells(x + 1, y + 1).Orientation = -90
                stack(st, 0) = stack(st, 0) - 4: st = st + 1: x = x + 1: stack(st, 0) = TA(x, y) - 1
            ElseIf stack(st, 0) And 8 Then
                Cells(x + 1, y + 1) = ">": Cells(x + 1, y + 1).Orientation = 0
                stack(st, 0) = stack(st, 0) - 8: st = st + 1: y = y + 1: stack(st, 0) = TA(x, y) - 2
            End If
            stack(st, 1) = x
            stack(st, 2) = y
            Cells(x + 1, y + 1) = "o"
        Else
            Do While stack(st, 0) = 0
                Cells(stack(st, 1) + 1, stack(st, 2) + 1) = ""
                st = st - 1
            Loop
            x = stack(st, 1)
            y = stack(st, 2)
        End If

    Loop Until x = fx And y = fy
    Cells(x + 1, y + 1) = ">": Cells(x + 1, y + 1).Orientation = 0
End Sub
Le 23/08/2023 à 14:00

ca fonctionne bien, merci beaucoup

Rechercher des sujets similaires à "labyrinthe tableau"