Mathematica: True Labyrinth (827 caractères)
A l'origine, je produisais un chemin de {1,1,1} à {5,5,5} mais comme il n'y avait pas de mauvais virages possibles à faire, j'ai introduit des fourches ou "points de décision" (sommets de degré> 2) où il faudrait décider de la voie à suivre. Le résultat est un véritable labyrinthe ou labyrinthe.
Les «ruelles aveugles» étaient beaucoup plus difficiles à résoudre que de trouver un chemin simple et direct. La chose la plus difficile était d'éliminer les cycles dans le chemin tout en autorisant les cycles hors du chemin de la solution.
Les deux lignes de code suivantes sont uniquement utilisées pour le rendu des graphiques dessinés, donc le code ne compte pas, car il n'est pas utilisé dans la solution.
o = Sequence[VertexLabels -> "Name", ImagePadding -> 10, GraphHighlightStyle -> "Thick",
ImageSize -> 600];
o2 = Sequence[ImagePadding -> 10, GraphHighlightStyle -> "Thick", ImageSize -> 600];
Code utilisé:
e[c_] := Cases[EdgeList[GridGraph[ConstantArray[5, 3]]], j_ \[UndirectedEdge] k_ /; (MemberQ[c, j] && MemberQ[c, k])]
m[] :=
Module[{d = 5, v = {1, 125}},
While[\[Not] MatchQ[FindShortestPath[Graph[e[v]], 1, 125], {1, __, 125}],
v = Join[v, RandomSample[Complement[Range[125], v], 1]]];
Graph[e[Select[ConnectedComponents[Graph[e[v]]], MemberQ[#, 1] &][[1]]]]]
w[gr_, p_] := EdgeDelete[gr, EdgeList[PathGraph[p]]]
y[p_, u_] := Select[Intersection[#, p] & /@ ConnectedComponents[u], Length[#] > 1 &]
g = HighlightGraph[lab = m[], PathGraph[s = FindShortestPath[lab, 1, 125]],o]
u = w[g, s]
q = y[s, u]
While[y[s, u] != {}, u = EdgeDelete[u, Take[FindShortestPath[u, q[[1, r = RandomInteger[Length@q[[1]] - 2] + 1]],
q[[1, r + 1]]], 2] /. {{a_, b_} :> a \[UndirectedEdge] b}];
q = y[s, u]]
g = EdgeAdd[u, EdgeList@PathGraph[s]];
Partition[StringJoin /@ Partition[ReplacePart[Table["x", {125}],
Transpose[{VertexList[g], Table["o", {Length[VertexList@g]}]}]/. {{a_, b_} :> a -> b}], {5}], 5]
Exemple de sortie
{{"oxooo", "xxooo", "xoxxo", "xoxxo", "xxoox"}, {"ooxoo", "xoooo", "ooxox", "oooxx", "xooxx"}, {"oooxx", "ooxxo", "ooxox", "xoxoo", "xxxoo"}, {"oxxxx", "oooox", "xooox", "xoxxx", "oooxx"}, {"xxxxx", "ooxox", "oooox "," xoxoo "," oooxo "}}
Sous la capuche
L'image ci-dessous montre le labyrinthe ou le labyrinthe qui correspond à la solution ({{"ooxoo",...}}
affichée ci-dessus:
Voici le même labyrinthe inséré dans un 5x5x5 GridGraph
. Les sommets numérotés sont des nœuds sur le chemin le plus court hors du labyrinthe. Notez les fourchettes ou points de décision à 34, 64 et 114. Je vais inclure le code utilisé pour le rendu du graphique même s'il ne fait pas partie de la solution:
HighlightGraph[gg = GridGraph[ConstantArray[5, 3]], g,
GraphHighlightStyle ->"DehighlightFade",
VertexLabels -> Rule @@@ Transpose[{s, s}] ]
Et ce graphique ne montre que la solution au labyrinthe:
HighlightGraph[gg = GridGraph[ConstantArray[5, 3]],
Join[s, e[s]], GraphHighlightStyle -> "DehighlightFade", VertexLabels -> Rule @@@ Transpose[{s, s}] ]
Enfin, quelques définitions qui peuvent aider à lire le code:
Solution originale (432 caractères, produit un chemin mais pas un vrai labyrinthe ou un vrai labyrinthe)
Imaginez un grand cube solide de 5x5x5 composé de cubes unitaires distincts. Ce qui suit commence sans cubes unitaires à {1,1,1} et {5,5,5}, car nous savons qu'ils doivent faire partie de la solution. Ensuite, il supprime des cubes aléatoires jusqu'à ce qu'il y ait un chemin libre de {1,1,1} à {5,5,5}.
Le "labyrinthe" est le chemin le plus court (si plus d'un est possible) étant donné les cubes unitaires qui ont été retirés.
d=5
v={1,d^3}
edges[g_,c_]:=Cases[g,j_\[UndirectedEdge] k_/;(MemberQ[c,j]&&MemberQ[c,k])]
g:=Graph[v,edges[EdgeList[GridGraph[ConstantArray[d,d]]],v]];
While[\[Not]FindShortestPath[g,1,d^3]!={},
v=Join[v,RandomSample[Complement[Range[d^3],v],1]]]
Partition[Partition[ReplacePart[
Table["x",{d^3}],Transpose[{FindShortestPath[g,1,d^3],Table["o",{Length[s]}]}]
/.{{a_,b_}:> a->b}],{d}]/.{a_,b_,c_,d_,e_}:> StringJoin[a,b,c,d,e],5]
Exemple:
{{"ooxxx", "xxxxx", "xxxxx", "xxxxx", "xxxxx"},
{"xoxxx", "xoooo", "xxxxo", "xxxxo", "xxxxo"},
{"xxxxx", "xxxxx", "xxxxx", "xxxxx", "xxxxo"},
{"xxxxx", "xxxxx", "xxxxx", "xxxxx", "xxxxo"},
{"xxxxx", "xxxxx", "xxxxx", "xxxxx", "xxxxo"}}
Techniquement, ce n'est pas encore un vrai labyrinthe, car il n'y a pas de mauvais virages que l'on puisse faire. Mais je l'ai trouvé intéressant pour commencer car il repose sur la théorie des graphes.
La routine fait en fait un labyrinthe mais j'ai bouché tous les emplacements vides qui pourraient donner lieu à des cycles. Si je trouve un moyen de supprimer les cycles, j'inclurai ce code ici.