Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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.

share|improve this question
1  
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. –  celtschk Apr 10 '12 at 21:07
    
@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. –  David Carraher Apr 10 '12 at 22:31
add comment

3 Answers 3

up vote 12 down vote accepted

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

share|improve this answer
1  
Very clever idea! The weights seem to act as if they were distances between cities, right? –  David Carraher Apr 9 '12 at 21:08
    
@DavidCarraher That's correct. The documentation for FindShortestPath says this: "For a weighted graph, edge length is taken to be the weight." –  rm -rf Apr 9 '12 at 21:15
    
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. –  David Carraher Apr 10 '12 at 1:58
    
@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... –  rm -rf Apr 10 '12 at 2:03
add comment

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

share|improve this answer
2  
+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.) –  David Carraher Apr 10 '12 at 16:16
1  
@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. –  whuber Apr 15 '12 at 14:37
add comment

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}]
share|improve this answer
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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