28
$\begingroup$

In designing a routine for making a simple three dimensional (5x5x5) labyrinth, I realized that my solutions (a solution is a labyrinth includes a single path from {1, 1, 1} to {5, 5, 5} in a 5 x5x5 grid) almost never wandered or "doubled back". This feature makes for a somewhat uninteresting labyrinth (see a labyrinth and its solution path, below); a person in the labyrinth can find the exit rather quickly by avoiding subpaths that turn back.

grids

Here's why the solution did not require doubling back: FindShortestPath was used to determine the solution path between {1,1,1} and {5,5,5}, that is, between vertex 1 and vertex 125 (see the labyrinth as a graph in the plane below), before circuits within the path were pruned. The shortest path will generally be the path that reaches the exit most directly.

labyrinth

How can I find a paths between start and finish vertices that are ostensibly not the shortest path? This is easy enough through visual inspection. But I'd like to compute a path that is not the shortest path.

Note: The above graph and its respective labyrinth have not yet been pruned. By pruning I mean the removal of alternative paths for reaching vertex 125 from vertex 1. Once a labyrinth has been properly pruned, one can only reach the finish vertex by traversing the unique solution path (and perhaps making some wrong turns into dead ends).


Code for above graph:

edges= {1 \[UndirectedEdge] 2, 2 \[UndirectedEdge] 3, 3 \[UndirectedEdge] 4,  1 \[UndirectedEdge] 6, 2 \[UndirectedEdge] 7, 6 \[UndirectedEdge] 7,  6 \[UndirectedEdge] 11, 7 \[UndirectedEdge] 12,  11 \[UndirectedEdge] 12, 12 \[UndirectedEdge] 13,  10 \[UndirectedEdge] 15, 11 \[UndirectedEdge] 16, 12 \[UndirectedEdge] 17, 16 \[UndirectedEdge] 17, 13 \[UndirectedEdge] 18, 17 \[UndirectedEdge] 18,  18 \[UndirectedEdge] 19, 17 \[UndirectedEdge] 22, 19 \[UndirectedEdge] 24, 24 \[UndirectedEdge] 25, 1 \[UndirectedEdge] 26, 3 \[UndirectedEdge] 28, 4 \[UndirectedEdge] 29, 28 \[UndirectedEdge] 29, 29 \[UndirectedEdge] 30, 6 \[UndirectedEdge] 31, 26 \[UndirectedEdge] 31, 7 \[UndirectedEdge] 32, 31 \[UndirectedEdge] 32, 29 \[UndirectedEdge] 34, 10 \[UndirectedEdge] 35, 30 \[UndirectedEdge] 35, 34 \[UndirectedEdge] 35, 11 \[UndirectedEdge] 36, 31 \[UndirectedEdge] 36, 12 \[UndirectedEdge] 37,  32 \[UndirectedEdge] 37, 36 \[UndirectedEdge] 37, 13 \[UndirectedEdge] 38, 37 \[UndirectedEdge] 38, 34 \[UndirectedEdge] 39, 38 \[UndirectedEdge] 39, 15 \[UndirectedEdge] 40, 35 \[UndirectedEdge] 40,  39 \[UndirectedEdge] 40, 16 \[UndirectedEdge] 41, 36 \[UndirectedEdge] 41, 17 \[UndirectedEdge] 42,  37 \[UndirectedEdge] 42, 41 \[UndirectedEdge] 42, 18 \[UndirectedEdge] 43, 38 \[UndirectedEdge] 43,  42 \[UndirectedEdge] 43, 40 \[UndirectedEdge] 45, 43 \[UndirectedEdge] 48, 24 \[UndirectedEdge] 49, 48 \[UndirectedEdge] 49, 25 \[UndirectedEdge] 50, 45 \[UndirectedEdge] 50, 49 \[UndirectedEdge] 50, 26 \[UndirectedEdge] 51, 28 \[UndirectedEdge] 53, 29 \[UndirectedEdge] 54, 53 \[UndirectedEdge] 54,  30 \[UndirectedEdge] 55, 54 \[UndirectedEdge] 55, 31 \[UndirectedEdge] 56, 51 \[UndirectedEdge] 56, 32 \[UndirectedEdge] 57, 56 \[UndirectedEdge] 57,  53 \[UndirectedEdge] 58, 57 \[UndirectedEdge] 58,  35 \[UndirectedEdge] 60, 55 \[UndirectedEdge] 60,  36 \[UndirectedEdge] 61, 56 \[UndirectedEdge] 61,  40 \[UndirectedEdge] 65, 60 \[UndirectedEdge] 65,  41 \[UndirectedEdge] 66, 61 \[UndirectedEdge] 66, 42 \[UndirectedEdge] 67, 66 \[UndirectedEdge] 67,  45 \[UndirectedEdge] 70, 65 \[UndirectedEdge] 70, 69 \[UndirectedEdge] 70, 66 \[UndirectedEdge] 71, 67 \[UndirectedEdge] 72, 71 \[UndirectedEdge] 72, 48 \[UndirectedEdge] 73, 72 \[UndirectedEdge] 73, 55 \[UndirectedEdge] 80, 56 \[UndirectedEdge] 81, 57 \[UndirectedEdge] 82, 77 \[UndirectedEdge] 82, 81 \[UndirectedEdge] 82, 60 \[UndirectedEdge] 85,  80 \[UndirectedEdge] 85, 84 \[UndirectedEdge] 85,  61 \[UndirectedEdge] 86, 81 \[UndirectedEdge] 86,  84 \[UndirectedEdge] 89, 88 \[UndirectedEdge] 89,  66 \[UndirectedEdge] 91, 86 \[UndirectedEdge] 91, 67 \[UndirectedEdge] 92, 91 \[UndirectedEdge] 92,  88 \[UndirectedEdge] 93, 92 \[UndirectedEdge] 93, 69 \[UndirectedEdge] 94, 89 \[UndirectedEdge] 94,  93 \[UndirectedEdge] 94, 71 \[UndirectedEdge] 96,  91 \[UndirectedEdge] 96, 72 \[UndirectedEdge] 97,  92 \[UndirectedEdge] 97, 96 \[UndirectedEdge] 97, 73 \[UndirectedEdge] 98, 93 \[UndirectedEdge] 98,  97 \[UndirectedEdge] 98, 94 \[UndirectedEdge] 99, 98 \[UndirectedEdge] 99, 81 \[UndirectedEdge] 106, 101 \[UndirectedEdge] 106, 82 \[UndirectedEdge] 107, 106 \[UndirectedEdge] 107, 85 \[UndirectedEdge] 110,  86 \[UndirectedEdge] 111, 106 \[UndirectedEdge] 111, 107 \[UndirectedEdge] 112, 111 \[UndirectedEdge] 112,  88 \[UndirectedEdge] 113, 112 \[UndirectedEdge] 113,  89 \[UndirectedEdge] 114, 113 \[UndirectedEdge] 114,  110 \[UndirectedEdge] 115, 114 \[UndirectedEdge] 115,  93 \[UndirectedEdge] 118, 113 \[UndirectedEdge] 118,  94 \[UndirectedEdge] 119, 114 \[UndirectedEdge] 119, 118 \[UndirectedEdge] 119, 96 \[UndirectedEdge] 121, 97 \[UndirectedEdge] 122, 121 \[UndirectedEdge] 122, 98 \[UndirectedEdge] 123, 118 \[UndirectedEdge] 123, 122 \[UndirectedEdge] 123, 99 \[UndirectedEdge] 124, 119 \[UndirectedEdge] 124, 123 \[UndirectedEdge] 124, 124 \[UndirectedEdge] 125}


HighlightGraph[lab=Graph[edges],  PathGraph[s = FindShortestPath[lab, 1, 125]], 
   VertexLabels -> "Name", ImagePadding -> 10, 
   GraphHighlightStyle -> "Thick", ImageSize -> 600]

Update

I posted below a CW response that lays out some ideas as to how to generate a labyrinth. Feel free to make your own edits to that code.

$\endgroup$
2
  • 1
    $\begingroup$ A simple solution would be to first find the shortest path, then select a point not on that shortest path, and find the shortest path between the starting point and that point, and the shortest path between that point and the end point after removing the vertices of the previous path. Note however that removing those vertices might remove the connection to the end point. In that case, just try again with another intermediate point. $\endgroup$
    – celtschk
    Apr 10, 2012 at 21:07
  • $\begingroup$ @celtschk Your solution would lead to a detour. I'm trying to get the path to actually double-back (without introducing a circuit). However, your idea raises an interesting possibility that would likely entail doubling back: choose 2 or 3 random stopping points that require visiting (in the order randomly chosen). I'll have to think more about this. $\endgroup$
    – DavidC
    Apr 10, 2012 at 22:31

4 Answers 4

14
$\begingroup$

You can try giving your edges random weights so that FindShortestPath is forced to take a different path. Here are some different possible paths —

Table[HighlightGraph[lab = Graph[edges, EdgeWeight -> RandomInteger[1000, Length[edges]]], 
    PathGraph[s = FindShortestPath[lab, 1, 125]], VertexLabels -> "Name",
    ImagePadding -> 10, GraphHighlightStyle -> "Thick", ImageSize -> 600], {6}
] ~Partition~ 3 // Grid

enter image description here

$\endgroup$
4
  • 1
    $\begingroup$ Very clever idea! The weights seem to act as if they were distances between cities, right? $\endgroup$
    – DavidC
    Apr 9, 2012 at 21:08
  • $\begingroup$ @DavidCarraher That's correct. The documentation for FindShortestPath says this: "For a weighted graph, edge length is taken to be the weight." $\endgroup$
    – rm -rf
    Apr 9, 2012 at 21:15
  • 1
    $\begingroup$ Your approach introduces a bit of additional variation doesn't appear to result in doubling back. You can check this with HighlightGraph[gg = GridGraph[ConstantArray[5, 3]], yourGraph]. It may be necessary to remove some cost of doubling back by assigning certain edges very low weights. Or by taking a different approach altogether. $\endgroup$
    – DavidC
    Apr 10, 2012 at 1:58
  • $\begingroup$ @DavidCarraher I can think of a few things that might work with FindShortestTour (if you want to be really mean and make the person have to wander a lot before reaching the exit), but the problem — or at least, what I haven't been able to achieve when I played with it before — is to specify start and end points... $\endgroup$
    – rm -rf
    Apr 10, 2012 at 2:03
15
$\begingroup$

If you want to be really nasty, traverse the entire graph (trying various vertices as starting points) and restrict the search for a shortest path to the traverse tree. Some of these will be quite long.

edges = {1 \[UndirectedEdge] 2, 2 \[UndirectedEdge] 3, ... 124 \[UndirectedEdge] 125};
g = Graph[edges];
h = Reap[DepthFirstScan[g, 7, {"FrontierEdge" -> Sow}]][[2, 1]]);
t = FindShortestPath[Graph[h], 1, 125];

(This use of DepthFirstScan is from an example on its help page.) This solution, obtained by a traversal starting at vertex 7, uses 75 of the 151 edges. It was found by varying the starting vertex of h from 1 through 125 and picking the one for which the length of t is as long as possible.

HighlightGraph[g, {PathGraph[t], Style[{1, 125}, Yellow], 
    Labeled[{1, 125}, "*"]}, GraphHighlightStyle -> "Thick"]

Long path

$\endgroup$
2
  • 2
    $\begingroup$ +Nice use of DepthFirstScan. I pruned your result to ensure that the person could not take shortcuts from 1 to 125. (I will show this in an update.) $\endgroup$
    – DavidC
    Apr 10, 2012 at 16:16
  • 1
    $\begingroup$ @David, Several promising alternative approaches appear in Bader et al., Alternative Route Graphs in Road Networks. One approach is to find an optimal path, increase the edge weights within a tubular neighborhood of that path (to steer solutions away from it), and try again. This can be done repeatedly to generate a set of alternatives to the optimal route. The whole thing could be automated by selecting an alternative having the highest edge count. $\endgroup$
    – whuber
    Apr 15, 2012 at 14:37
5
$\begingroup$

Here's an approach based on R.M's response and on celtschk's idea of pushing the labyrinth toward vertices known not to be on the shortest path. I removed the constraint that parallel tunnels should be avoided. I also set aside the issue of dead ends and misleading paths for later. It struck me as cleaner to find an elaborate labyrinth directly within the complete 5x5x5 grid, and then add misleading paths later. Perhaps you have some ideas on how to add false paths.

Feel free to contribute your own improvements.

Also, I know that there is still a glitch or two that occasionally causes the program to fail to find a shortest path.

mazes

The commented code follows:

ClearAll[f, maze]

(* Randomly selects two vertices to pass through, avoiding those near \
 start or finish *)
stops := 
  RandomSample[
  Complement[
    Range[125], {1, 2, 6, 7, 26, 27, 31, 32, 95, 99, 100, 119, 120, 
       125, 124}], 2]

 (* The 5 x 5 x 5 grid *)

g1 := GridGraph[ConstantArray[5, 3], EdgeStyle -> Thin, 
  VertexSize -> Small, ImagePadding -> 15, 
  EdgeWeight -> RandomInteger[{1, 1000}, 300];

(* Generate an indirect path from start to end that does not visit \
  any vertices in path *)

f[v1_, v2_, path_: {}] := 
   Join[path, 
        FindShortestPath[
        VertexDelete[g1, 
        DeleteDuplicates@If[Length[path] == 0, path, Most[path]]], v1, v2]]

(* Maze that goes from 1 to stops[[1]] to stops[[2]] to 125 *)
maze :=
  Module[{st = stops, 
     s = DeleteDuplicates[
     f[st[[2]], 125, f[st[[1]], st[[2]], f[1, st[[1]], {}]]]]},
     HighlightGraph[g1, PathGraph[s], 
     VertexLabels -> s /. {v_Integer :> v -> v}, ImagePadding -> 10, 
     GraphHighlightStyle -> "Thick", ImageSize -> 250]]

Table[maze, {6}]
$\endgroup$
2
$\begingroup$

I'm a bit unclear as to why this works .... however, using FindPath instead of FindShortestPathyields a route through 71 of the 88 vertices which definitely doubles back on itself.

HighlightGraph[lab = Graph[edges], PathGraph[s = Last@Sort@FindPath[lab, 1, 125]], 
   VertexLabels -> "Name", ImagePadding -> 10, GraphHighlightStyle -> "Thick", ImageSize -> 600]

enter image description here

HighlightGraph[GridGraph[{5, 5, 5}, EdgeStyle -> LightGray, VertexStyle -> LightGray, 
                VertexSize -> 0.3, BaseStyle -> EdgeForm[White]], 
                PathGraph[s], VertexLabels -> "Name", ImagePadding -> 10, 
                GraphHighlightStyle -> "Thick", ImageSize -> 400]

enter image description here

Using the form FindPath[start,end,Infinity,All] will find all paths through the graph. Although, for a 5x5x5 grid there are likely to be 10,000's of paths and generating this list may take several hours... Trimming such a list to only include longer paths (e.g. FindPath[start,end,{55,60},All]) might yield a more manageable, yet still interesting set of paths to play with.


Making a labyrinth

... here is an attempt at a all-in-one labyrinth maker:

mesh = GridGraph[{4, 4, 4}];

(*generating a pseudorandom subset of edges that include the start and end vertices*)

edgelab = EdgeList[mesh][[Union[{1, 144}~Join~RandomInteger[{1, 144}, 130]]]];

(*graph of the subset of edges*)

labset = Graph[edgelab];

(*finding a path...*)

path = Last@Sort@FindPath[labset, 1, 64, {30, 45}];

HighlightGraph[labset, PathGraph[path], VertexLabels -> "Name", ImagePadding -> 10, 
               GraphHighlightStyle -> "Thick", ImageSize -> 600]

enter image description here

Varying the number of RandomInteger's generated (in this case 130) is the key control on the connectivity of the labyrinth. Of course it is possible to create disconnected 'chambers', but this may not be such a problem (depending on the final application).

$\endgroup$
2
  • $\begingroup$ My goodness, this really does work. I never used FindPath and am curious to get a sense of how it works. $\endgroup$
    – DavidC
    Feb 5, 2015 at 13:39
  • $\begingroup$ @DavidCarraher It seems to be very fast too, see e.g. here. $\endgroup$
    – Juho
    Apr 8, 2015 at 20:55

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.