Message Boards Message Boards

Other Way Maze

Posted 8 years ago

Consider the following maze.

The Other Way 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]]]}]]  

other way solution map

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?

POSTED BY: Ed Pegg
7 Replies

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]]]]}]

two by two three by three

We can also plot random games:

Column[{Graph[GameGraph[#], ImageSize -> 800], ArrayPlot[#]}, 
Center] &@Partition[RandomInteger[{0, 1}, 5^2], 5] 

enter image description here

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 BY: Brad Klee

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[{
Arrowheads[Medium], 
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]},
MapThread[DirectedEdge, {Range[(n^2)^2],
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];

Game Comparison

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]]

Tori

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
]

Torus625

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}]

81 anim

625 anim

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 BY: Brad Klee

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]

enter image description here

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]]]

enter image description here

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]

enter image description here

81 (the maximum) happens relatively a lot.

We can do the same for 5x5 grids:

enter image description here

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 BY: Sander Huisman

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?

POSTED BY: Sander Huisman

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.

OtherWayMaze 2

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:

otherwaysolution

POSTED BY: Ed Pegg

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 BY: Sander Huisman

enter image description here - Congratulations! This post is now Staff Pick! Thank you for your wonderful contributions. Please, keep them coming!

POSTED BY: EDITORIAL BOARD
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract