4
|
13147 Views
|
7 Replies
|
14 Total Likes
View groups...
Share
GROUPS:

Other Way Maze

Posted 8 years ago
 Consider the following maze. Here's a directional grid for anyone that would like to try to solve this with a program, followed by a mapping for all the arrows and code to draw the grid. bg = {{{-1, 0}, {1, 1}, {1, 1}, {1, 1}, {-1, -1}}, {{0, -1}, {0, 1}, {1, -1}, {0, 1}, {1, 0}}, {{0, 1}, {-1, -1}, {-1, 0}, {-1, 1}, {1, 1}}, {{1, -1}, {0, -1}, {0, 1}, {-1, 0}, {0, -1}}, {{0, 1}, {-1, 0}, {1, -1}, {1, 0}, {1, 0}}}; map = Thread[{{-1, -1}, {-1, 0}, {-1, 1}, {0, -1}, {0, 1}, {1, -1}, {1, 0}, {1, 1}} -> {"\[UpperLeftArrow]", "\[UpArrow]", "\[UpperRightArrow]", "\[LeftArrow]", "\[RightArrow]", "\[LowerLeftArrow]", "\[DownArrow]", "\[LowerRightArrow]"}]; Style[Grid[bg /. map, Frame -> All, FrameStyle -> Directive[Thickness[4]]], 70, Bold]  So how might this be solved? It's a 5x5 grid, and there are two coins, so there is a maximum of 25x25=625 positions. These position can be represented by {1,1,1,1} to {5,5,5,5}, with the first two slots for coin 1. The next step is to build all the connections between those positions, and then to make a graph out of it. positions = Tuples[Range[5], {4}]; grids = {bg, bg}; connects = Join[ Flatten[Table[Select[# \[DirectedEdge] # + Join[{0, 0}, grids[[1, j, k]]] & /@ Select[positions, Take[#, 2] == {j, k} &], Max[#[[2]]] <= 5 && Min[#[[2]]] >= 1 &],{j, 1, 5}, {k, 1, 5}], 3], Flatten[Table[Select[# \[DirectedEdge] # + Join[grids[[2, j, k]], {0, 0}] & /@ Select[positions, Drop[#, 2] == {j, k} &], Max[#[[2]]] <= 5 && Min[#[[2]]] >= 1 &],{j, 1, 5}, {k, 1, 5}], 3]]; pat = Sort[FindCycle[{Graph[connects], {3, 3, 3, 3}}, {2, 500}, 50000]]; Length /@ Take[pat, 10] {145, 167, 168, 171, 172, 173, 174, 174, 175, 175}  According to the code run, the shortest solution requires 145 moves. There are thousands of longer solutions. That's incredibly complicated for a 5x5 maze. What does a map of the coins moving for the solution look like? With[{route = Transpose[MapIndexed[{Append[Take[#1, 2], #2[[1]]/35], Append[Drop[#1, 2], #2[[1]]/35]} &, Append[First /@ pat[[1]], {3, 3, 3, 3}]]]}, Graphics3D[{Red, Line[route[[1]]], Blue, Line[route[[2]]]}]]  This particular maze was found randomly. Thousands of grids were randomly generated and evaluated for solution complexity, and then some of the superior grids got small random changes to see if anything better came out. Can anyone else make a more complex maze of this sort?
7 Replies
Sort By:
Posted 8 years ago
 - Congratulations! This post is now Staff Pick! Thank you for your wonderful contributions. Please, keep them coming!
Posted 8 years ago

Coin Permutation Game V2.0. Perfect 3x3 game ( on four arrows ), perfect 5x5 game ( on four arrows ), depictions of solutions and animations.

Game Instantiation

Play Functions

Move[state_, dxy_, n_] := Mod[Plus[state, dxy], n] /. {0 -> n}

SequentialUpdate[GameBoard_, state_, n_] := With[{
next1 =
Move[state[[1]], GameBoard[[ Sequence @@ state[[2]] ]], n ]},
{next1, Move[state[[2]], GameBoard[[ Sequence @@ next1 ]], n ]}
]

SimultaneousUpdate[GameBoard_, state_, n_] := Mod[Plus[state, {
GameBoard[[ Sequence @@ state[[2]] ]],
GameBoard[[ Sequence @@ state[[1]] ]]
}], n] /. {0 -> n}


Board Creation Functions

AllGameBoards[AlphN_, n_] :=
Partition[#, n] & /@ Tuples[Range[0, AlphN - 1], n^2]

Depict[GameBoard_] :=
GraphicsGrid[GameBoard /. {x_Integer, y_Integer} :> Graphics[{
Arrow[{-1/2 Normalize[{y, -x}], 1/2 Normalize[{y, -x}]}]
}, ImageSize -> {50, 50},
PlotRange -> {{-1.1, 1.1}, {-1.1, 1.1}}], Frame -> All]

OneBit = {0 -> {1, 0}, 1 -> {0, 1}};
TwoBit = Join[OneBit, {2 -> {-1, 0}, 3 -> {0, -1}}];
ThreeBit =
Join[TwoBit, {4 -> {1, 1}, 5 -> {-1, 1}, 6 -> {-1, -1},
7 -> {1, -1}}];
AllStates[n_] := Flatten[Outer[{{#1, #2}, {#3, #4}} &,
Range[n], Range[n], Range[n], Range[n]], 3]


Analysis Functions

CycleLengths[Game_, update_] := Length /@ (FindCycle[Graph[
GameGraph[Game /. ThreeBit, update]], Infinity, All])

GameGraph[board_, update_] := With[{n = Length[board]},
Position[AllStates[n], update[board, #, n]][[1, 1]] & /@
AllStates[n]}]
]


Games & Analysis

Validation and New Records

EdsGame = {
{0, 2, 3, 3, 2},
{2, 3, 2, 6, 0},
{2, 1, 2, 4, 5},
{3, 1, 1, 2, 3},
{1, 2, 3, 3, 2}};

ErrorGame = {
{1, 3, 2, 2, 3},
{3, 2, 3, 6, 1},
{3, 0, 3, 4, 7},
{2, 0, 0, 3, 2},
{0, 3, 2, 2, 3}};

Cycle625 = {
{2, 0, 0, 1, 0},
{3, 3, 2, 2, 0},
{3, 0, 2, 2, 3},
{0, 3, 3, 2, 0},
{1, 0, 0, 2, 0}} ;

Cycle81 = {
{0, 1, 3},
{3, 2, 0},
{0, 0, 3}};

CycleLengths[EdsGame, SequentialUpdate]
CycleLengths[ErrorGame, SequentialUpdate]
CycleLengths[Cycle625, SequentialUpdate]
CycleLengths[Cycle81, SequentialUpdate]

Out[]={2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 5, 8, 8, 9, 9, 23, 127, 204, 204}
Out[]={2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 6, 6, 585}
Out[]={625}
Out[]={81}

GameComparison = Grid[{Show[Depict[# /. ThreeBit], ImageSize -> 300],
Graph[GameGraph[# /. ThreeBit, SequentialUpdate],
EdgeStyle -> Darker[Blue], ImageSize -> 300],
Graph[GameGraph[# /. ThreeBit, SimultaneousUpdate],
EdgeStyle -> Darker[Red], ImageSize -> 300]
} & /@ {EdsGame, ErrorGame, Cycle625,Cycle81},
Frame -> All];


We find perfect games for 3x3 and 5x5 using a gameboard alphabet consisting of only the cardinal directions. Furthermore comparing the affect of sequential vs. simultaneous update accross many game boards, we see that sequential update leads to more cycle topology while simultaneous update leads to branching topology. The figures above show this for a few examples. The "error game" was found by serendipity, and can be obtained from Ed Pegg's earlier game by a map on the directional symbols.

Torus Map

EightyOneGames = {{{0, 1, 3}, {3, 2, 0}, {0, 0, 3}}, {{2, 3, 3}, {0,
3, 0}, {1, 3, 0}}, {{3, 1, 2}, {1, 0, 1}, {0, 0, 1}}}
tori = Row[Function[{a}, Graphics3D[{Thick,
Riffle[{Red, Blue},
Line /@ Transpose[
MapIndexed[#1 /.
{x_Integer, y_Integer} :> {
(1 + x) Cos[2 Pi #2[[1]]/81],
(1 + x) Sin[2 Pi #2[[1]]/81], y} &,

NestList[
SequentialUpdate[EightyOneGames[[a]] /. ThreeBit, #, 3] &,
{{1, 1}, {3, 3}}, 81]]]]}, Boxed -> False,
ImageSize -> 300
]] /@ Range[3]]


torus625 = Graphics3D[{Thick,
Riffle[{Red, Blue},
Line /@ Transpose[
MapIndexed[#1 /.
{x_Integer, y_Integer} :> {
(5 + x) Cos[2 Pi #2[[1]]/625],
(5 + x) Sin[2 Pi #2[[1]]/625], y} &,
NestList[SequentialUpdate[Cycle625 /. ThreeBit, #, 5] &,
{{1, 1}, {5, 5}}, 625]]]]}, Boxed -> False, ImageSize -> 800
]


Each line tracks the position of a coin through time, and repeats after 81 or 625 equal time intervals. Possibly a joke can be made here regarding KAM theory.

Game Animations

RedDisk = Graphics[{EdgeForm[Thick], Darker@Red, Opacity[.2], Disk[]}];
BlueDisk =
Graphics[{EdgeForm[Thick], Darker@Blue, Opacity[.2], Disk[]}];
RedBlueDisk = Graphics[{Darker@Blue, Disk[{0, 0}, 1, {-Pi/2, Pi/2}],
Darker@Red, Disk[{0, 0}, 1, {3 Pi/2, Pi/2}]}];

GameBoard = Depict[EightyOneGames[[1]] /. ThreeBit];

SequentialUpdate2[GameBoard_, state_, n_] := With[
{next1 =
Move[state[[1]], GameBoard[[ Sequence @@ state[[2]] ]], n ]},
Sow[{next1, state[[2]]}];
{next1, Move[state[[2]], GameBoard[[ Sequence @@ next1 ]], n ]}
]

GetMoves[GameBoard_] :=
With[{moves =
Reap[NestList[
SequentialUpdate2[GameBoard /. ThreeBit, #,
Length@GameBoard] &, {{1,
1}, (Length@GameBoard)*{1, 1}}, (Length@GameBoard)^4]]},
Riffle[moves[[1]], moves[[2, 1]]]
]

GetFrames[GameBoard_] :=
With[{GraphicBoard = Depict[GameBoard /. ThreeBit]},
GetMoves[GameBoard] /. {
{{x_, y_}, {x_, y_}} :>
ReplacePart[
GraphicBoard, {1, 2, x, y, 1} ->
Show[RedDisk, BlueDisk, GraphicBoard[[1, 2, x, y, 1]] ]],
{{x_, y_}, {u_, v_}} :> ReplacePart[GraphicBoard, {
{1, 2, x, y, 1} ->
Show[BlueDisk, GraphicBoard[[1, 2, x, y, 1]] ],
{1, 2, u, v, 1} -> Show[RedDisk, GraphicBoard[[1, 2, u, v, 1]] ]
}]}]

Frames81 = GetFrames[EightyOneGames[[1]] ];
Frames625 = GetFrames[ Cycle625 ];

Manipulate[Frames81[[i]], {i, 1, 2*81 + 1, 1}]

Manipulate[Frames625[[i]], {i, 1, 2*625 + 1, 1}]


In these animations, the initial condition is in opposing corners, as in a boxing match. Since each trajectory goes through every possible state, eventually some coincident state is reached. Furthermore all 9 or 25 coincident states are reached during time evolution. That's the game!

Conclusions

For a grid of 3x3 or 5x5, 8 directional symbols are not necessary to make a "perfect game", which visits every point in state space. For each of these domains we find perfect games using only four symbols. Is it possible to use only three symbols? Is there a perfect game for every NxN grid? If yes, how to construct?

Posted 8 years ago
 wow! very nice! How did you find these grids? randomly? Simultaneous updating seems a bit neater than alternating... I'll play around a bit more later. Great job. O btw, rather than Cos[...], Sin[...] to get polar points I would recommend using either CirclePoints or AngleVector or even FromPolarCoordinates.
Posted 8 years ago
 If you start at the center and move the coins in an alternating way you get: ClearAll[MoveMe, MoveMeFromStart] VisualizeBG[bg_List] := Graphics[MapIndexed[Arrow[{#2 - #1, #2 + #1}] &, 0.25 bg, {2}]] MoveMe[p1 : {x1_, y1_}, p2 : {x2_, y2_}, bg_] := Module[{newp2, mov}, (* note that the first (p1) determines position, and moves p2, outputs {p2,p1} note: REVERSED! *) mov = Extract[bg, p1]; newp2 = p2 + mov; newp2 = MapThread[Mod[#1, #2, 1] &, {newp2, Dimensions[bg, 2]}]; (* periodic boundaries *) {newp2, p1} ] MoveMeFromStart[bg_] := Module[{center, pos}, center = Floor[(Dimensions[bg, 2] + 1)/2]; (* position of center *) pos = NestWhileList[ MoveMe[Sequence @@ #, bg] &, {center, center}, # =!= {center, center} &, {2, 1}]; (* start from center, wait until at center again *) pos[[;; ;; 2]] = RotateLeft /@ pos[[;; ;; 2]]; (* flip the reverse ones\[Ellipsis] *) Transpose[pos] ] MoveMeFromStartLen[bg_] := Length[First[MoveMeFromStart[bg]]] - 1 bg = {{{1, 0}, {-1, -1}, {1, 0}, {-1, 0}, {0, 1}}, {{0, 1}, {-1, 0}, {-1, 1}, {1, 0}, {1, -1}}, {{-1, -1}, {1, 0}, {0, 1}, {-1, -1}, {1, -1}}, {{0, -1}, {0, 1}, {1, 1}, {1, 0}, {1, -1}}, {{0, -1}, {-1, 0}, {1, -1}, {0, -1}, {-1, 1}}}; VisualizeBG[bg] MoveMeFromStartLen[bg] it takes 202 steps to return back to the center. We can also find a random grid of arrow and find the length now quite easily, we do so until we find a grid with the longest route to return to the center: Dynamic[i] Dynamic[best[[2]]] best={{},-1}; dimensions={5,5}; directions=Select[Tuples[Range[-1,1],2],Norm[#]>0&]; Do[ newbg=RandomChoice[directions,dimensions]; len=MoveMeFromStartLen[newbg]; If[len>best[[2]],best={newbg,len}]; If[len==(Times@@dimensions)^2,Break[]] , {i,30000} ] Now plot the best solution (625 steps): VisualizeBG[best[[1]]] For a 3x3 grid we can also see what the loop-length are by calculating many grids and plotting a histogram of the lengths: Dynamic[i] dimensions={3,3}; directions=Select[Tuples[Range[-1,1],2],Norm[#]>0&]; lens=Table[ newbg=RandomChoice[directions,dimensions]; MoveMeFromStartLen[newbg] , {i,200000} ]; Histogram[lens, {1}, AspectRatio -> 1/5, ImageSize -> 1000] 81 (the maximum) happens relatively a lot.We can do the same for 5x5 grids:showing a rather flat distribution! This code also supports rectangular grids. So feel free to play around with it.One could also do the same in 3D (or even nD), and in 2D with hexagonal tiles, or with more coins...
Posted 8 years ago
 The superlong cycle wasn't minimal, so there was an unintended solution, as found by Reddit user mkglass. FindShortestPath works better for these. Here's a greatly improved puzzle. The vector file: bg = {{{1, 0}, {-1, 0}, {0, -1}, {0, -1}, {-1, 0}}, {{-1, 0}, {0, -1}, {-1, 0}, {-1, -1}, {1, 0}}, {{-1, 0}, {0, 1}, {-1, 0}, {1, 1}, {-1, 1}}, {{0, -1}, {0, 1}, {0, 1}, {-1, 0}, {0, -1}}, {{0, 1}, {-1, 0}, {0, -1}, {0, -1}, {-1, 0}}}; Code for the 94-move solution. positions = Tuples[Range[5], {4}]; grids = {bg, bg}; connects = Join[Flatten[Table[Select[# \[DirectedEdge] # + Join[{0, 0}, grids[[1, j, k]]] & /@ Select[positions, Take[#, 2] == {j, k} &], Max[#[[2]]] <= 5 && Min[#[[2]]] >= 1 &],{j, 1, 5}, {k, 1, 5}], 3], Flatten[Table[Select[# \[DirectedEdge] # + Join[grids[[2, j, k]], {0, 0}] & /@ Select[positions, Drop[#, 2] == {j, k} &], Max[#[[2]]] <= 5 && Min[#[[2]]] >= 1 &],{j, 1, 5}, {k, 1, 5}], 3]]; pat = FindShortestPath[Graph[connects], {2, 3, 3, 3}, {3, 3, 3, 3}] The solution looks like the following:
Posted 8 years ago
 Hi Ed, Wow I'm surprised about your find of such long cycles. I'm also slightly confused about the rules, so I just made up my own similar game. I'm using a simplified alphabet of move right and move down, so that all boards can be encoded binary. Furthermore, I am using simultaneous update, rather than turn-sequential. Also, I'm assuming the gameboard has the topology of a torus. The code is not that different from the symplectic integrator I have mentioned in other threads: UpdateState[GameBoard_, state_, n_] := Mod[Plus[state, { GameBoard[[ Sequence @@ state[[2]] ]], GameBoard[[ Sequence @@ state[[1]] ]] } /. {0 -> {1, 0}, 1 -> {0, 1}}], n] /. {0 -> n} AllGameBoards[n_] := Partition[#, n] & /@ Tuples[{0, 1}, n^2] AllStates[n_] := Flatten[Outer[{{#1, #2}, {#3, #4}} &, Range[n], Range[n], Range[n], Range[n]], 3] GameGraph[board_] := With[{n = Length[board]}, MapThread[DirectedEdge, {Range[(n^2)^2], Position[AllStates[n], UpdateState[board, #, n]][[1, 1]] & /@ AllStates[n]}]] and a few extra functions to filter gameboards: Reflections[GameBoard_, null_] := {GameBoard, Reverse /@ GameBoard} Rotations[GameBoard_, null_] := NestList[Reverse[Transpose[#]] &, GameBoard, 3] TorusX[GameBoard_, n_] := Function[{a}, RotateRight[#, a] & /@ GameBoard] /@ Range[n] TorusY[GameBoard_, n_] := Function[{a}, Transpose[RotateRight[#, a] & /@ Transpose[GameBoard]]] /@ Range[n] Inversions[GameBoard_, n_] := {Mod[GameBoard + 1, 2], GameBoard} AllTransforms[GameBoard_, n_] := Fold[Union@ Flatten[Function[{a}, #2[a, n]] /@ #1, 1] &, {GameBoard}, {Reflections, Rotations, TorusX, TorusY, Inversions} ] SymFilter[AllBoards_, n_] := DeleteDuplicates[AllBoards, SameQ[AllTransforms[#1, n], AllTransforms[#2, n]] &] Then we can look through all games for cycles SomeGameBoards[n_] := SymFilter[AllGameBoards[n], n] AbsoluteTiming[ GB2 = SomeGameBoards[2]; ] AbsoluteTiming[ GB3 = SomeGameBoards[3]; ] Grid[Transpose[{Graph[GameGraph[#], ImageSize -> 100], ArrayPlot[#, ImageSize -> 75]} & /@ GB2]] Column[{Grid[ Transpose[{Graph[GameGraph[#], ImageSize -> 100], ArrayPlot[#, ImageSize -> 75]} & /@ GB3[[1 ;; 7]]]], Grid[Transpose[{Graph[GameGraph[#], ImageSize -> 100], ArrayPlot[#, ImageSize -> 75]} & /@ GB3[[8 ;; 13]]]]}]  We can also plot random games: Column[{Graph[GameGraph[#], ImageSize -> 800], ArrayPlot[#]}, Center] &@Partition[RandomInteger[{0, 1}, 5^2], 5] Or count the cycles: CycleLengths[Game_] := Length /@ (FindCycle[Graph[GameGraph[Game]], Infinity, All]) (1/2) CycleLengths /@ GB2 (1/3) CycleLengths /@ GB3 And finally we can do some inductive reasoning. It appears that all cycles on NxN board are multiples of N, and that all graphs have some relatively small cycles. Though I can't say what will happen on a large board, random searching didn't return anything too interesting. A negative result for my constraint system, but also an interesting start to exploring some fundamental questions for this type of dynamical system: how is output affected by: turn / sequential updating VS. simultaneous updating ? Alphabet: (up,right) VS. (N,S,E,W) VS. (N,NE,E,SE,S,SW,W,NW) ?
Posted 8 years ago
 I'm not quite sure if I fully understand the problem; what happens if one of the coins falls off? Does it have periodic BC? Or will it be forced to stay on?Very neat dynamics!How can there be different cycles? it is deterministic and the history is not important right? so if you start at {3,3,3,3} it can only go 'one' way right? And from that point you can also go one way only?