Mathematica: Laberinto verdadero (827 caracteres)
Originalmente, produje un camino de {1,1,1} a {5,5,5} pero como no había posibles giros incorrectos, introduje bifurcaciones o "puntos de decisión" (vértices de grado> 2) donde uno tendría que decidir qué camino tomar. El resultado es un verdadero laberinto o laberinto.
Los "callejones sin salida" eran mucho más difíciles de resolver que encontrar un camino simple y directo. Lo más desafiante fue eliminar los ciclos dentro de la ruta mientras se permitían los ciclos fuera de la ruta de la solución.
Las siguientes dos líneas de código solo se usan para representar los gráficos dibujados, por lo que el código no cuenta, ya que no se emplea en la solución.
o = Sequence[VertexLabels -> "Name", ImagePadding -> 10, GraphHighlightStyle -> "Thick",
ImageSize -> 600];
o2 = Sequence[ImagePadding -> 10, GraphHighlightStyle -> "Thick", ImageSize -> 600];
Código usado:
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]
Salida de muestra
{{"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 "}}
Bajo el capó
La siguiente imagen muestra el laberinto o laberinto que corresponde a la solución que se ({{"ooxoo",...}}
muestra arriba:
Aquí está el mismo laberinto insertado en un 5x5x5 GridGraph
. Los vértices numerados son nodos en el camino más corto fuera del laberinto. Tenga en cuenta las bifurcaciones o los puntos de decisión en 34, 64 y 114. Incluiré el código utilizado para representar el gráfico aunque no sea parte de la solución:
HighlightGraph[gg = GridGraph[ConstantArray[5, 3]], g,
GraphHighlightStyle ->"DehighlightFade",
VertexLabels -> Rule @@@ Transpose[{s, s}] ]
Y este gráfico muestra solo la solución al laberinto:
HighlightGraph[gg = GridGraph[ConstantArray[5, 3]],
Join[s, e[s]], GraphHighlightStyle -> "DehighlightFade", VertexLabels -> Rule @@@ Transpose[{s, s}] ]
Finalmente, algunas definiciones que pueden ayudar a leer el código:
Solución original (432 caracteres, produjo un camino pero no un verdadero laberinto o laberinto)
Imagine un cubo sólido grande de 5x5x5 formado por cubos de unidades distintas. Lo siguiente comienza sin cubos unitarios en {1,1,1} y {5,5,5}, ya que sabemos que deben ser parte de la solución. Luego, elimina los cubos aleatorios hasta que haya una ruta sin obstáculos de {1,1,1} a {5,5,5}.
El "laberinto" es el camino más corto (si es posible más de uno) dados los cubos unitarios que se han eliminado.
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]
Ejemplo:
{{"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"}}
Técnicamente, esto aún no es un verdadero laberinto, ya que no hay giros incorrectos que uno pueda hacer. Pero, para empezar, me pareció interesante, ya que se basa en la teoría de grafos.
La rutina en realidad hace un laberinto, pero conecté todas las ubicaciones vacías que podrían dar lugar a ciclos. Si encuentro una manera de eliminar ciclos, incluiré ese código aquí.