Mathematica:真正的迷宫(827个字符)
最初,我产生了从{1,1,1}到{5,5,5}的路径,但是由于不可能进行错误的转弯,我引入了分叉或“决策点”(度数顶点> 2),其中一个人需要决定走哪条路。结果是真正的迷宫或迷宫。
解决“盲巷”要比找到一条简单直接的道路更具挑战性。最具挑战性的事情是消除路径内的循环,同时允许解决方案路径外的循环。
以下两行代码仅用于呈现绘制的图形,因此该代码不计算在内,因为该解决方案未使用该代码。
o = Sequence[VertexLabels -> "Name", ImagePadding -> 10, GraphHighlightStyle -> "Thick",
ImageSize -> 600];
o2 = Sequence[ImagePadding -> 10, GraphHighlightStyle -> "Thick", ImageSize -> 600];
使用的代码:
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]
样品输出
{{“ 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“}}
引擎盖下
下图显示了与({{"ooxoo",...}}
上面显示的解决方案相对应的迷宫或迷宫:
这是插入5x5x5中的相同迷宫GridGraph
。编号的顶点是迷宫中最短路径上的节点。请注意位于34、64和114的分叉或决策点。即使它不是解决方案的一部分,我也将包括用于渲染图形的代码:
HighlightGraph[gg = GridGraph[ConstantArray[5, 3]], g,
GraphHighlightStyle ->"DehighlightFade",
VertexLabels -> Rule @@@ Transpose[{s, s}] ]
此图仅显示迷宫的解决方案:
HighlightGraph[gg = GridGraph[ConstantArray[5, 3]],
Join[s, e[s]], GraphHighlightStyle -> "DehighlightFade", VertexLabels -> Rule @@@ Transpose[{s, s}] ]
最后,一些定义可能有助于阅读代码:
原始解决方案(432个字符,产生了一条路径,但不是真正的迷宫或迷宫)
想象一个由不同的单位立方体组成的5x5x5大型实心立方体。以下内容从{1,1,1}和{5,5,5}的单位立方开始,因为我们知道它们必须是解决方案的一部分。然后,它将删除随机立方体,直到从{1,1,1}到{5,5,5}的路径畅通无阻为止。
给定已删除的单位立方体,“迷宫”是最短的路径(如果可能的话)。
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]
例:
{{"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"}}
从技术上讲,这还不是真正的迷宫,因为不会出现任何错误的转弯。但是我认为这很有趣,因为它依赖于图论。
该例程实际上使人迷宫,但我堵塞了所有可能引起周期的空白位置。如果我找到消除循环的方法,则将在此处包含该代码。