This is a quick implementation of a Numberphile video called The Dumbest Way To Solve A Maze in Mathematica. The idea is to “solve” a maze by simulating a bunch of particles following Brownian motion and diffusing throughout the maze until one gets lucky and makes its way out.
In the video, they use Mathematica to generate the maze and visualize the results, but here I run the simulation in Mathematica too, which only takes a few seconds (and has fancy dynamic graphics to visualize the progress!)
In the video, they use Mathematica to generate the maze and visualize the results, but here I run the simulation in Mathematica too, which only takes a few seconds (and has fancy dynamic graphics to visualize the progress!)
Set constants:
In[]:=
dims={8,12};hallwayThickness=0.8;ballCount=1000;
Generate a random spanning tree for the passages:
In[]:=
spanningTree=FindSpanningTree[GridGraph[dims,EdgeWeight{_:>RandomReal[]}]]
Out[]=
Generate the region representing the walls:
In[]:=
outerRegion=Rectangle[{1,1}-1+hallwayThickness,Reverse[dims]+1];
In[]:=
wallsRegion=RegionDifference[RegionDifference[Rectangle[{1,1}-1+hallwayThickness,Reverse[dims]+1],RegionDilation[DiscretizeGraphics[Line[GraphEmbedding[spanningTree][[#]]]&/@List@@@EdgeList[spanningTree]],Rectangle[{0,0},{1,1}*hallwayThickness]]],Rectangle[{dims[[2]],hallwayThickness},{dims[[2]],0}+{hallwayThickness,1}]]
Out[]=
Precompute some things for the simulation:
wallMember=RegionMember[wallsRegion];mazeMember=RegionMember[outerRegion];
In[]:=
initPs={1+hallwayThickness/2,dims[[1]]+hallwayThickness/2};
Run the simulation:
In[]:=
positionSeries=Module[{ps,vs},Monitor[ps=ConstantArray[initPs,ballCount];Reap[Sow[ps];While[And@@mazeMember[ps],vs=RandomPoint[Circle[],ballCount]*0.1;ps+=vs;ps-=vs*Boole[wallMember[ps]];Sow[ps]]][[2,1]],Graphics[{wallsRegion,Orange,PointSize[Large],Point[ps]},ImageSize->Large]]];
Find the index of the winning ball:
In[]:=
winningIndex=FirstPosition[mazeMember@Last@positionSeries,False][[1]]
Out[]=
508
Plot its path:
In[]:=
Graphics[{wallsRegion,Orange,Line[positionSeries[[All,winningIndex]]]},ImageSize->Large]
Out[]=
Visualize the simulation, highlighting the winning ball toward the end:
In[]:=
Manipulate[Graphics[{wallsRegion,If[i>Length[positionSeries]*2/3,{Red,Thick,Circle[positionSeries[[i,winningIndex]],0.2],Thin,Blue,Line[positionSeries[[All,winningIndex]]]},{}],Orange,PointSize[Medium],Point[positionSeries[[i]]]},ImageSize->Large],{i,1,Length[positionSeries],1}]
Out[]=
Compute the maximum distance each ball makes it from the starting point:
In[]:=
ballMaxDistances=Max/@Total[(Threaded[initPs]-Transpose[positionSeries])^2,{3}];
In[]:=
ballDistanceRanking=Ordering[ballMaxDistances];
Show the paths of the balls the went the furthest vs. the least far:
CITE THIS NOTEBOOK
CITE THIS NOTEBOOK
Brownian Motion Maze Solving (based on "The Dumbest Way To Solve A Maze")
by Christopher Wolfram
Wolfram Community, STAFF PICKS, October 3, 2022
https://community.wolfram.com/groups/-/m/t/2628034
by Christopher Wolfram
Wolfram Community, STAFF PICKS, October 3, 2022
https://community.wolfram.com/groups/-/m/t/2628034