Mathematica:True Labyrinth(827文字)
もともと、{1,1,1}から{5,5,5}へのパスを作成しましたが、間違ったターンをする可能性がなかったため、分岐または「決定ポイント」(次数> 2)を導入しました。どちらに行くかを決める必要があります。結果は、真の迷路または迷路です。
「盲目の路地」は、単純で直接的な道を見つけるよりもはるかに解決が困難でした。最も困難なことは、パス内のサイクルを排除し、ソリューションパスからのサイクルを許可することでした。
次の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}への障害のないパスができるまで、ランダムキューブを削除します。
「labyrinth」は、削除されたユニットキューブが与えられた場合の最短経路です(複数可能な場合)。
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"}}
技術的には、間違った方向転換はできないため、これはまだ真の迷路ではありません。しかし、グラフ理論に依存しているので、出発点としてそれが面白いと思いました。
このルーチンは実際に迷路を作りますが、サイクルを引き起こす可能性のある空の場所をすべて塞ぎました。サイクルを削除する方法を見つけたら、ここにそのコードを含めます。