Labyrinthe et ses mobiles

[markopolo]

Salutation,
Voila le code vba ou il y a intégré la création du labyrinthe, le déplacement du mobile aléatoire, le déplacement du mobile intelligent et un d'un mobile évolué.

J'aurais voulu savoir comment les séparer en macro différentes, c'est a dire: une macro sub maze, une macro mobaléa, une macro mobévolué et une macro mobintelligent. Parce que mon code est basé sur la logique précédente donc je sais pas si c'est possible.

Merci d'avance
Markopolo

 

[markopolo]

Re : Labyrinthe et ses mobiles

Const visitaleatoircolor = 27 'couleur des cases visitées par le mobile aléatoire
Const visitevoluecolor = 28 'couleur des cases visitées par le mobile évolué
Const visitintelligentcolor = 26 'couleur des cases visitées par le mobile intelligent
Const bloqueportecolor = 10 'couleur des portes bloquées par le mobile intelligent
Const mazecolor = 56 ' Couleur du labyrinthe
Const mox0 = 14 ' Ligne de départ du labyrinthe(coin nord-ouest)
Const moy0 = 8 ' Colonne de départ du labyrinthe (coin nord-ouest)


' Création du labyrinthe

Sub MakeMaze()
Dim xb As Integer, yb As Integer
Dim xs As Integer, ys As Integer
Dim xc As Integer, yc As Integer
Dim xa As Integer, ya As Integer
Dim x0 As Integer, y0 As Integer
Dim x1 As Integer, y1 As Integer
Dim xd As Integer, yd As Integer
Dim xi As Integer, yi As Integer
Dim cellsleft As Integer, movedir As Integer, moveindex As Integer
Dim nbecases As Integer
Dim xvis As Integer, yvis As Integer
Dim xprec As Integer, yprec As Integer
Dim tempsparcours As Long, casesvisitees As Integer
Dim depart As String
Dim fermeporte As Integer, nbeportes As Integer





' Définition du labyrinthe et création de l'entré du laby
Set shdata = Sheets("Data")
Set shmaze = Sheets("Maze")
Randomize (Timer)
xb = mox0 'ligne du coin en haut à gauche du laby
yb = moy0 ' colonne du coin en haut gauche du laby
xs = 0
ys = 0
While 2 * Int(xs / 2) = xs Or 2 * Int(ys / 2) = ys
xs = InputBox("Entrer la taille impaire en longueur") 'définition de la taille en ligne du laby dans la feuille data (taille laby xs*xy)
ys = InputBox("Entrer la taille impaire en hauteur") 'definition de la taille en hauteur(colonne) du laby dans la feuille data
Wend
shmaze.Cells.Interior.ColorIndex = xlNone
With shmaze
.Range(.Cells(yb, xb), .Cells(yb + ys - 1, xb + xs - 1)).Interior.ColorIndex = mazecolor 'carré(exemple 7x7) de la meme couleur définie en haut const mazecolor=56
End With

'etape suivante definition de l'entrée qui est aléatoire
xc = Int(xs / 2) 'arrondie en entier avec int sinon chiffre a virgule si nombre impaire
yc = Int(ys / 2) '
x0 = xb + Int(Rnd * xc) * 2 + 1 ' point d'ouverture du laby (ligne)xb explication formule: point de départ sur la ligne de la zone du laby definie precedenment +
y0 = yb + 1 ' point d'ouverture du laby (colonne)
nbecases = 2

shdata.Range("a3").Value = x0
shdata.Range("a4").Value = x0
shdata.Range("b4").Value = y0
shdata.Range("c4").Value = 2
shmaze.Cells(y0 - 1, x0).Interior.ColorIndex = xlNone
shmaze.Cells(y0, x0).Interior.ColorIndex = xlNone
xa = x0
ya = y0
cellsleft = xc * yc - 1
xi = 2
yi = 2

' Boucle du laby. Definie une direction aléatoire et voit si on peut y aller

LNextPassage:
movedir = Int(Rnd * 4)
For moveindex = 1 To 4
xd = 0
yd = 0
If movedir = 0 Then
yd = -1
ElseIf movedir = 1 Then
xd = -1
ElseIf movedir = 2 Then
yd = 1
Else
xd = 1
End If
x1 = x0 + xd * 2
y1 = y0 + yd * 2
If x1 < xb Or y1 < yb Or x1 > xb + xs - 2 Or y1 > yb + ys - 2 Then
GoTo LDoHunt
ElseIf shmaze.Cells(y1, x1).Interior.ColorIndex = xlNone Then
GoTo LNextMove
Else

' Cherche un passage non taillé à côté d'un taillé, si le laby se prolonge

shmaze.Cells(y0 + yd, x0 + xd).Interior.ColorIndex = xlNone
shmaze.Cells(y1, x1).Interior.ColorIndex = xlNone
nbecases = nbecases + 2
cellsleft = cellsleft - 1
If cellsleft < 1 Then
GoTo LDone
End If
x0 = x1
y0 = y1
GoTo LNextPassage
End If
' Aucun partie du labyrinthe défait dans cette endroit. Tourne et essaye la direction suivante.

LNextMove:
movedir = movedir + 1
If movedir >= 4 Then
movedir = 0
End If
Next moveindex

' Regarde dans le labyrinthe pour un passage non taillé

LDoHunt:
x0 = x0 + xi
If x0 < xb Or x0 > xb + xs - 2 Then
x0 = x0 - xi
y0 = y0 + yi
xi = -xi
If y0 < yb Or y0 > yb + ys - 2 Then
y0 = y0 - yi
yi = -yi
End If
End If
If shmaze.Cells(y0, x0).Interior.ColorIndex <> xlNone Then
GoTo LDoHunt
End If
GoTo LNextPassage

' Finitions laby et sorti

LDone:
x1 = xb + Int(Rnd * xc) * 2 + 1
shmaze.Cells(yb + ys - 1, x1).Interior.ColorIndex = xlNone
nbecases = nbecases + 1
shdata.Range("b3").Value = x1
shdata.Range("a5").Value = 0
shdata.Range("a6").Value = nbecases

'parcours du labyrinthe par le mobile aléatoire

depart = InputBox("Donner le départ du mobile aléatoire")
ymob = yb
xmob = shdata.Range("a3").Value
shmaze.Cells(ymob, xmob).Interior.ColorIndex = visitaleatoircolor 'positionnement du mobile à l'entrée
xvis = xmob
yvis = ymob + 1
tempsparcours = 1
casesvisitees = 1
While casesvisitees < nbecases 'on recommence jusqu'a ce que toutes les cases soient visitées
xmob = xvis
ymob = yvis
tempsparcours = tempsparcours + 1
If shmaze.Cells(ymob, xmob).Interior.ColorIndex = xlNone Then
casesvisitees = casesvisitees + 1
shmaze.Cells(ymob, xmob).Interior.ColorIndex = visitaleatoircolor 'coloriage de toute case visitée pour la première fois
End If
movedir = Int(Rnd * 4) 'choix de la direction aléatoire
xd = 0
yd = 0
If movedir = 0 Then
yd = -1
ElseIf movedir = 1 Then
xd = -1
ElseIf movedir = 2 Then
yd = 1
Else
xd = 1
End If
xvis = xmob + xd
yvis = ymob + yd
While xvis < xb Or xvis > xb + xs - 2 Or yvis < yb Or yvis > yb + ys - 1 Or shmaze.Cells(yvis, xvis).Interior.ColorIndex = mazecolor
movedir = Int(Rnd * 4)
xd = 0
yd = 0
If movedir = 0 Then
yd = -1
ElseIf movedir = 1 Then
xd = -1
ElseIf movedir = 2 Then
yd = 1
Else
xd = 1
End If 'verification que la nouvelle case à visiter est dans le labyrinthe
xvis = xmob + xd
yvis = ymob + yd
Wend


Wend
shdata.Range("a7").Value = tempsparcours

'parcours du labyrinthe par le mobile évolué (ne revient en arrière qu'au fond d'une impasse)
depart = InputBox("Donner le départ du mobile évolué")
ymob = yb
xmob = shdata.Range("a3").Value
shmaze.Cells(ymob, xmob).Interior.ColorIndex = visitevoluecolor
xvis = xmob
yvis = ymob + 1
tempsparcours = 1
casesvisitees = 1

While casesvisitees < nbecases
xprec = xmob
xmob = xvis
yprec = ymob
ymob = yvis

tempsparcours = tempsparcours + 1
If shmaze.Cells(ymob, xmob).Interior.ColorIndex = visitaleatoircolor Then
casesvisitees = casesvisitees + 1
shmaze.Cells(ymob, xmob).Interior.ColorIndex = visitevoluecolor
End If
culdesac = 1 'on ne revient en arrière que si on est face à trois murs
For k = 1 To 2
If (xmob <> xprec Or ymob + (-1) ^ k <> yprec) And ymob + (-1) ^ k >= yb And ymob + (-1) ^ k <= yb + ys - 1 And shmaze.Cells(ymob + (-1) ^ k, xmob).Interior.ColorIndex <> mazecolor Then
culdesac = 0
End If
If (ymob <> yprec Or xmob + (-1) ^ k <> xprec) And shmaze.Cells(ymob, xmob + (-1) ^ k).Interior.ColorIndex <> mazecolor Then
culdesac = 0
End If
Next
If culdesac = 1 Then 'si culdesac=1 il fait demi tour
xvis = xprec
yvis = yprec
Else
movedir = Int(Rnd * 4)
xd = 0
yd = 0
If movedir = 0 Then
yd = -1
ElseIf movedir = 1 Then
xd = -1
ElseIf movedir = 2 Then
yd = 1
Else
xd = 1
End If
xvis = xmob + xd
yvis = ymob + yd
While (xvis = xprec And yvis = yprec) Or xvis < xb Or xvis > xb + xs - 2 Or yvis < yb Or yvis > yb + ys - 1 Or shmaze.Cells(yvis, xvis).Interior.ColorIndex = mazecolor
movedir = Int(Rnd * 4)
xd = 0
yd = 0
If movedir = 0 Then
yd = -1
ElseIf movedir = 1 Then
xd = -1
ElseIf movedir = 2 Then
yd = 1
Else
xd = 1
End If
xvis = xmob + xd
yvis = ymob + yd
Wend
End If

Wend
shdata.Range("a8").Value = tempsparcours

'parcours du labyrinthe par le mobile intelligent (ne revient en arrière qu'au fond d'une impasse et marque alors l'entrée de cette impasse pour ne pas y retourner )
depart = InputBox("Donner le départ du mobile intelligent")
ymob = yb
xmob = shdata.Range("a3").Value
shmaze.Cells(ymob, xmob).Interior.ColorIndex = visitintelligentcolor
xvis = xmob
yvis = ymob + 1
tempsparcours = 1
casesvisitees = 1
fermeporte = 1

While casesvisitees < nbecases
xprec = xmob
xmob = xvis
yprec = ymob
ymob = yvis

tempsparcours = tempsparcours + 1
If shmaze.Cells(ymob, xmob).Interior.ColorIndex = visitevoluecolor Then
casesvisitees = casesvisitees + 1
shmaze.Cells(ymob, xmob).Interior.ColorIndex = visitintelligentcolor
End If
culdesac = 1
nbeportes = 0
For k = 1 To 2 'detecte le fond d'une impasse réelle ou fermée par les portes qu'il a créé
If (xmob <> xprec Or ymob + (-1) ^ k <> yprec) And ymob + (-1) ^ k >= yb And ymob + (-1) ^ k <= yb + ys - 1 And shmaze.Cells(ymob + (-1) ^ k, xmob).Interior.ColorIndex <> mazecolor And shmaze.Cells(ymob + (-1) ^ k, xmob).Interior.ColorIndex <> bloqueportecolor Then
culdesac = 0
nbeportes = nbeportes + 1
End If
If (ymob <> yprec Or xmob + (-1) ^ k <> xprec) And shmaze.Cells(ymob, xmob + (-1) ^ k).Interior.ColorIndex <> mazecolor And shmaze.Cells(ymob, xmob + (-1) ^ k).Interior.ColorIndex <> bloqueportecolor Then
culdesac = 0
nbeportes = nbeportes + 1
End If
Next
If fermeporte = 1 And nbeportes > 1 Then 'ferme la porte de l'impasse visitée
shmaze.Cells(yprec, xprec).Interior.ColorIndex = bloqueportecolor
fermeporte = 0
End If
If culdesac = 1 Then
xvis = xprec
yvis = yprec
fermeporte = 1
Else
movedir = Int(Rnd * 4)
xd = 0
yd = 0
If movedir = 0 Then
yd = -1
ElseIf movedir = 1 Then
xd = -1
ElseIf movedir = 2 Then
yd = 1
Else
xd = 1
End If
xvis = xmob + xd
yvis = ymob + yd
While (xvis = xprec And yvis = yprec) Or xvis < xb Or xvis > xb + xs - 2 Or yvis < yb Or yvis > yb + ys - 1 Or shmaze.Cells(yvis, xvis).Interior.ColorIndex = mazecolor Or shmaze.Cells(yvis, xvis).Interior.ColorIndex = bloqueportecolor
movedir = Int(Rnd * 4)
xd = 0
yd = 0
If movedir = 0 Then
yd = -1
ElseIf movedir = 1 Then
xd = -1
ElseIf movedir = 2 Then
yd = 1
Else
xd = 1
End If
xvis = xmob + xd
yvis = ymob + yd
Wend
End If

Wend
shdata.Range("a9").Value = tempsparcours
End Sub

 

[Gruick]

Re : Labyrinthe et ses mobiles

Bonjour Markopolo,

Absolument fabuleux !

J'étais en train de décortiquer ton 1er programme pour chercher pourquoi un nombre pair boguait. Pas encore résolu, je poursuis.

Merci d'avoir mis la macro accessible pour des versions antérieures à 2007.

Le module aléatoire me colore tout en jaune
Le module évolué en vert,
le module intelligent me dissémine quelques cases vertes dans le rouge ambiant.

J'ai remplacé les inputbox par des msgbox, car je me suis demandé ce que je devais faire, et de toutes façons, quel que soit le bouton actionné, il fait la même chose, puisqu'il n'y a pas de test sur la réponse.
J'ai mis des DoEvents pour voir la progression du module.

Les modules devraient s'arrêter une fois la case de sortie atteinte, je pense, mais il poursuivent. Je ne comprends pas la finalité.
Le module intelligent dispose des cases vertes, mais je ne sais pas si c'est au bon endroit.

Ce ne sont que des remarques, pas des critiques, et je te félicite encore pour ton merveilleux travail. J'espère bien que tu arrives à un truc sensationnel et pouvoir y contribuer serait un honneur pour moi.

Je joints le dossier légèrement modifié.

Gruick, admiratif

 

[Efgé]

Re : Labyrinthe et ses mobiles

Bonjour markopolo, Gruick,
Merci Gruick d'avoir mis le fichier en Xls(par contre mon 2003 refuse d'ouvrir le second fichier).
Je n'ai pas les connaissances nécessaires pour décortiquer ce superbe boulot que j'ai découvert dans le précédent fil (qui parlait du problème des chiffres pairs). Je me permet juste une remarque de logique terre à terre :
Le lab commence par un mur et fini par un mur. A coté de chaque mur il y a un couloir. Donc il y a forcément un mur de plus que de couloir... donc les dimmensions sont forcément impaires.
En éspérant ne pas avoir enfoncé une porte ouverte...
Cordialement

 

[Gruick]

Re : Labyrinthe et ses mobiles

re,

Bien vu Efgé, je donne ton nom à ce théorème.

Je pense que l'articulation du programme est tel que le module intelligent se sert des renseignements du module évolué, qui lui même se sert des informations du module aléatoire.

Gruick

 

[Gruick]

Re : Labyrinthe et ses mobiles

Bonjour,

Je me suis permis de trouver une solution infaillible au superbe travail de Markopolo.
J'ai finalement pris le raisonnement inverse, partir des parcours impossibles pour les éliminer un par un et en déduire une seule et unique possibilité.
Vous comprendrez facilement en examinant la macro.
Sinon, tant pis... non, je plaisante, à votre disposition.

Gruick, jamais perdu grâce à son GPS (Gruick Porc Subtil)