5
|
4633 Views
|
3 Replies
|
8 Total Likes
View groups...
Share
GROUPS:

# Finalizing design of DepthFirstSearch: a Backtrack search function

Posted 2 years ago
 In a previous thread we made some progress fixing the one pre-existing backtrack algorithm, and did some basic testing to show that depth first searches can get results in practice. The purpose of this memo is to continue building towards a final implementation, which could end up as a deliverable to the Wolfram Function Repository. Our previous backtrack algorithm assumed a level structure for the search space, where possible states on each level depend not on the current state of the search. This opens up a fine class of problems including some things about tilings and non-attacking queens; however, there is another obvious class of backtracking problems we would also like to solve some of. In the more general class, the set of states on each level does depend on the current state of the search (and likely also on history up to that point). In this case, we need the following alternative method for DepthFirstSearch: DepthFirstIterate[iterator_, solutionQ_, count_ ][state_] := Module[ {nextStates = iterator[state], res = Nothing, allRes = {}, ind = 1, len}, len = Length[nextStates]; If[len == 0, If[solutionQ[state], Return[{state}], Return[{Nothing}]]]; While[ind <= len, Sow[DirectedEdge[state, nextStates[[ind]]]]; res = DepthFirstIterate[iterator, solutionQ, count - Length[allRes]][ nextStates[[ind]]]; allRes = Join[allRes, res]; If[Length[allRes] == count, Break[]]; ind++]; allRes] DepthFirstSearch[init_, iterator : (_Association | _Function), solutionQ_, count : (_Integer?Positive | All) : 1, False] := Block[ {$RecursionLimit = Infinity}, If[SameQ[Length[#], count, 1], First[#], #] &[ DepthFirstIterate[ iterator, solutionQ, count ][init]]]  A good test problem is to try and walk a chess knight around an$N \times N$grid, visiting every square if possible, and sometimes even completing a Hamiltonian cycle. Per what is written on mathworld, this is not an easy task for a backtracking algorithm, so we will have to see what results we can get, if any. First, let's define how a chess knight moves, and give an iterator for updating an$N \times N$grid: $knightMoves = Sort[Select[Tuples[{1, 2, -1, -2}, 2], UnsameQ @@ Abs[#] &]] Out[]= {{-2, -1}, {-2, 1}, {-1, -2}, {-1, 2}, {1, -2}, {1, 2}, {2, -1}, {2, 1}} IterateKnightWalk[board_] := With[{max = Max[board], pos = Position[board, Max[board]][[1]]}, ReplacePart[board, # -> (max + 1)] & /@ Select[pos + # & /@ RandomSample[$knightMoves], If[And @@ Thread[Dimensions[board] >= # > {0, 0}], board[[Sequence @@ #]] == 0, False] &]]  And if you look closely, you will see that the iterator contains some funny code. Usage of RandomSample allows that every time we run the backtracking search, potentially we will get a different answer (unless we set a SeedRandom). Furthermore, different answers take different amounts of time to compute, and (because the backtracker can easily get lost) similar answers are not guaranteed to compute in similar times: data = Table[AbsoluteTiming[DepthFirstSearch[ ReplacePart[ConstantArray[0, {8, 8}], {1, 1} -> 1], Function[IterateKnightWalk[#]], (True &), 1] // Max], {5000}]; BoxWhiskerChart[Association[KeyValueMap[#1 -> #2[[All, 1]] &, KeySort@GroupBy[data, #[[2]] &]]], ChartLabels -> Keys[KeySort[GroupBy[data, #[[2]] &]]]]  It almost looks hopeful that the linear trend of minimal times could possibly continue to a complete board at 64, and in less than 0.01 seconds? Such a naive perspective ignores the multicomputational aspect of this plot, which we is plainly seen as times spiking up in the whiskers. Maximally slow times correspond to unlucky permutations via RandomChoice. To get a short path to a complete solution, we would have to get unbelievable lucky. In 5000 trials to 61 moves, we could only hit four times in less than 0.01 seconds: Union[Table[TimeConstrained[AbsoluteTiming[DepthFirstSearch[ ReplacePart[ConstantArray[0, {8, 8}], {1, 1} -> 1], Function[IterateKnightWalk[#]], (Max[#] == 62 &), 1] // Max], .01], {5000}]] Out[] = {$Aborted, {0.006934, 61}, {0.007279, 61}, {0.007569, 61}, {0.009356, 61}}  The problem is pretty hard, but can we find anything on a smaller board? The $5 \times 5$ board is entirely computable in under 1 minute, and $6 \times 6$ is not too bad either. Hey look, I had some dumb luck on one of my searches: AbsoluteTiming[DepthFirstSearch[ ReplacePart[ConstantArray[0, {6, 6}], {3, 3} -> 1], Function[IterateKnightWalk[#]], (And[ Max[#] == 36, MemberQ[$knightMoves, Position[#, 1][[1]] - Position[#, 36][[1]]] ] &), 1]] {237.155305, {{21, 6, 35, 2, 19, 4}, {36, 27, 20, 5, 34, 29}, {7, 22, 1, 28, 3, 18}, {26, 15, 24, 11, 30, 33}, {23, 8, 13, 32, 17, 10}, {14, 25, 16, 9, 12, 31}}} MatrixForm@{{21, 6, 35, 2, 19, 4}, {36, 27, 20, 5, 34, 29}, {7, 22, 1, 28, 3, 18}, {26, 15, 24, 11, 30, 33}, {23, 8, 13, 32, 17, 10}, {14, 25, 16, 9, 12, 31}}  Not only is this a complete tour, it is also a Hamiltonian cycle on the underlying$6 \times 6$knight graph because the 1 ends up a knight's move away from the 36. Just how lucky is it to find this result in only 4-5 minutes? I think that is a good type of question we should be trying to answer as part of the multicomputational paradigm. Anyone? For my part, I just tried to run the search again with TimeConstrained, and didn't find another such result. Moving on... More manageable cases, where we can even make some interesting plots, occur when searching through the nodes of arbitrary Directed Acyclic Graphs. For example, let's define this as a search space: ToDirectedAcyclicGraph = ResourceFunction["ToDirectedAcyclicGraph"]; SeedRandom[2414323]; With[{g0 = WeaklyConnectedGraphComponents[RandomGraph[{300, 350}]][[1]]}, g1 = Graph[ToDirectedAcyclicGraph[g0, VertexList[g0][[{1, 2}]]], VertexCoordinates -> Automatic, GraphLayout -> "LayeredDigraphEmbedding", AspectRatio -> 1/2]]  In this case we can iterate through levels just by following the edges: edgeUpdate = Association[ # -> VertexOutComponent[g1, #, {1} ] & /@ VertexList[g1]];  By default the search looks for a terminal node: DepthFirstSearch[1, edgeUpdate, (True &)] Out[]=217  And we can see what this looks like by Reaping DirectedEdges: HighlightGraph[g1, Graph[Flatten[Reap[ DepthFirstSearch[1, edgeUpdate, (True &), 1]][[2, 1]]]]]  And if we change the last argument to 2, 10 or All, we get: The final graph should be the same as the entire out component of initial vertex 1. We can also notice that this graph has one deepest node at level 10, and plot the search tree for finding it: HighlightGraph[g1, Graph[Flatten[Reap[ DepthFirstSearch[1, edgeUpdate, (GraphDistance[g1, 1, #] == 10 &), 1, TreeGraphQ -> True]][[2, 1]]]]]  That's neat, but can we get there from the other starting point? Just change the intial value and try to search again, the answer is yes: HighlightGraph[g1, Graph[Flatten[Reap[ DepthFirstSearch[23, edgeUpdate, (GraphDistance[g1, 1, #] == 10 &), 1, TreeGraphQ -> True]][[2, 1]]]]]  That's it, basically. Because the algorithm can handle arbitrary DAGs and Iterators, it should be capable of solving a sufficiently wide range of backtracking problems. The last thing we have to worry about is whether a very deep graph could possibly hang a search. To avoid this we also want to introduce an optional cutoff for recursion depth, but this can probably wait until tomorrow, as well as writing the technical documentation... 3 Replies Sort By: Posted 2 years ago  It is good to have lots of examples... SeedRandom[123123]; g1 = Graph[ WeaklyConnectedGraphComponents[ ResourceFunction["ToDirectedAcyclicGraph"][RandomGraph[{20, 40}], 1]][[1]], VertexCoordinates -> Automatic, VertexLabels -> "Name", GraphLayout -> Automatic] Mathematica has functions like BacktrackSearch for resource functions, yay! ResourceFunction["BacktrackSearch"][{{1}, VertexList[g1], VertexList[g1], VertexList[g1]}, MemberQ[EdgeList[g1], DirectedEdge @@ #[[-2 ;; -1]]] &, True &, All]  knightMoves = {{-2, -1}, {-2, 1}, {-1, -2}, {-1, 2}, {1, -2}, {1, 2}, {2, -1}, {2, 1}}; iterateKnightWalk[board_] := Module[{max = Max[board], pos = First[Position[board, Max[board]]], newBoards}, newBoards = Select[(pos + #) & /@ knightMoves, If[And @@ Thread[Dimensions[board] >= # > {0, 0}], board[[Sequence @@ #]] == 0, False] &]; ReplacePart[board, # -> max + 1] & /@ newBoards] DepthFirstSearch[init_, iterator_, solutionQ_, limit_ : Infinity, count_ : 0] := Module[{nextStates, res, state = init}, If[solutionQ[state], Return[{state}], Nothing]; nextStates = iterator[state]; While[count < limit && Length[nextStates] > 0, state = First[nextStates]; nextStates = Rest[nextStates]; res = DepthFirstSearch[state, iterator, solutionQ, limit, count + 1]; If[res =!= Nothing, Return[Prepend[res, state]]];]; Return[Nothing]] board = ReplacePart[ConstantArray[0, {8, 8}], {1, 1} -> 1]; solution = DepthFirstSearch[board, iterateKnightWalk, (Max[#] == 32 &)]; If[solution =!= Nothing, finalBoard = Last[solution]; colorFunc[x_] := If[x == 0, White, Blend[{Green, Red}, x/Max[finalBoard]]]; styledBackground = Map[colorFunc, finalBoard, {2}]; labels = Map[Text[Style[#, Bold, 16]] &, finalBoard, {2}]; Grid[labels, Background -> styledBackground, Frame -> All], Print["No solution found"]]  ClearAll[isPossible, solve]; original = {{5, 3, 0, 0, 7, 0, 0, 0, 0}, {6, 0, 0, 1, 9, 5, 0, 0, 0}, {0, 9, 8, 0, 0, 0, 0, 6, 0}, {8, 0, 0, 0, 6, 0, 0, 0, 3}, {4, 0, 0, 8, 0, 3, 0, 0, 1}, {7, 0, 0, 0, 2, 0, 0, 0, 6}, {0, 6, 0, 0, 0, 0, 2, 8, 0}, {0, 0, 0, 4, 1, 9, 0, 0, 5}, {0, 0, 0, 0, 8, 0, 0, 7, 9}}; isPossible[sudoku_, y_, x_, n_] := And[FreeQ[sudoku[[y]], n], FreeQ[Transpose[sudoku][[x]], n], FreeQ[Flatten[ Part[sudoku, 3 Floor[(y - 1)/3] + 1 ;; 3 Floor[(y - 1)/3] + 3, 3 Floor[(x - 1)/3] + 1 ;; 3 Floor[(x - 1)/3] + 3]], n]]; solve[sudoku_] /; ! MemberQ[Flatten[sudoku], 0] := sudoku; solve[sudoku_] := Module[{emptyPos, y, x, n, newSudoku, result}, emptyPos = Position[sudoku, 0, 2, 1]; If[Length[emptyPos] == 0, Return[sudoku]]; {y, x} = First[emptyPos]; For[n = 1, n <= 9, n++, If[isPossible[sudoku, y, x, n], newSudoku = sudoku; newSudoku[[y, x]] = n; result = solve[newSudoku]; If[result =!= Null, Return[result]];];]; Return[Null];]; solved = solve[original]; colorized = MapThread[ If[#2 == 0, Style[#1, Red], Style[#1, Black]] &, {solved, original}, 2]; Grid[colorized, Frame -> All] Oh @Brad Klee I am so blessed to have been present for your divine implementation of the depth-first search function..and I know we were in a bit of a slump for a while there. You performed the backtracking, and you threw out a question about the improvements on previous backtracking algorithms..and now I think I finally understand why, because when you're navigating a chess knight across the board, you've got to iterate through possible states based on an iterator function. And by the time you check if a particular state is a solution, with the given function solutionQ, the possible states from our vantage point no longer exist from our perspective however they do exist within the DepthFirstSearch algorithm. maze = {{1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1}, {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1}, {1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1}, {1, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 1}, {1, 0, 0, 0, 1, 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 1}, {1, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 1}, {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1}, {1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1}, {1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1}, {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1}, {1, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 1}, {1, 0, 0, 0, 1, 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 1}, {1, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 1}, {1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1}, {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1}, {1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1}}; moves = {{0, 1}, {1, 0}, {0, -1}, {-1, 0}}; DepthFirstSearch[maze_, start_, end_] := Module[{stack = {}, visited = {}, position, path, next}, AppendTo[stack, {start, {start}}]; While[Length[stack] > 0, {position, path} = Last[stack]; stack = Most[stack]; If[Not[MemberQ[visited, position]], AppendTo[visited, position]; If[position == end, Return[path], Do[next = position + move; If[ 1 <= next[[1]] <= Length[maze] && 1 <= next[[2]] <= Length[maze[[1]]] && maze[[Sequence @@ next]] == 0 && Not[MemberQ[visited, next]], AppendTo[stack, {next, Append[path, next]}]], {move, moves}]]]];]; path = DepthFirstSearch[maze, {2, 2}, {15, 2}]; mazeWithSolution = If[path != {}, ReplacePart[maze, Thread[path -> 2]], maze]; MatrixForm /@ {maze, mazeWithSolution}; colorFunction[val_] := Which[val == 1, Black, val == 0, White, val == 2, Red]; ArrayPlot[maze, ColorFunction -> colorFunction] ArrayPlot[mazeWithSolution, ColorFunction -> colorFunction] What about navigating a chess knight across an NxN grid? The moves a chess knight can make are defined, in the short term. An iterator - IterateKnightWalk - allows us to turn the knight on an NxN grid, and we switch around the results. That's the randomness, that's added to the iterator and ensures that each search run could rotate the results within the original framework turning an experimental disadvantage into an advantage; finding a Hamiltonian cycle for a knight on an 8x8 board is challenging, but a 6x6 board has better prospects. What kind of prospects? With regard to Directed Acyclic Graphs, the flexibility of the algorithm is showcased by applying it to even arbitrary Directed Acyclic Graphs. The function ToDirectedAcyclicGraph showcases how we can migrate and search through nodes of this graph, random or not. What do we do now? results = {}; Do[timing = AbsoluteTiming[ DepthFirstSearch[ ReplacePart[ConstantArray[0, {n, n}], {1, 1} -> 1], Function[IterateKnightWalk[#]], (Max[#] == n*n &), 1]][[1]]; AppendTo[results, {n, timing}], {n, 4, 10}]; ListLinePlot[results, AxesLabel -> {"Board size (n x n)", "Time (s)"}, GridLines -> Automatic, PlotTheme -> "Detailed", PlotStyle -> {Thickness[0.005]}, PlotMarkers -> Automatic, PlotLabel -> "Knight's Tour Computation Time by Board Size", Frame -> True, FrameLabel -> {"Board size (n x n)", "Time (s)"}, LabelStyle -> Directive[Black, 12]] When we apply BacktrackSearch on the demonstrations, I cannot calm down. I really appreciate the discussion of the results presented, I used to think results just grew on trees but then the orchestration of the chess knight problem really got us to a comprehensive understanding of the function's capabilities. I really hope that all of us users who are familiar with Wolfram technologies will not just lay low because we can't & want to refine a backtracking search function for Wolfram Mathematica. What is that? Backtracking is a general algorithm for finding solutions to some constraint satisfaction problems. It incrementally builds candidates to the solutions, and as soon as it determines that the candidate cannot be extended to a valid solution, the algorithm decisively backtracks on the candidate's journey laying low within the search space at each level. $knightMoves = {{-2, -1}, {-2, 1}, {-1, -2}, {-1, 2}, {1, -2}, {1, 2}, {2, -1}, {2, 1}}; createKnightGraph[n_] := Flatten[Table[ If[And[i + #1 <= n, j + #2 <= n, i + #1 > 0, j + #2 > 0], UndirectedEdge[{i, j}, {i + #1, j + #2}]] & @@@ $knightMoves, {i, n}, {j, n}], 1]; knightGraph = createKnightGraph[5]; validMoves = Select[Flatten[knightGraph], # =!= Null &]; GraphPlot[validMoves, VertexLabels -> Automatic, PlotStyle -> Directive[Thick, Blend[{Red, Blue}, 0.5], Dashed]]  SeedRandom[123]; GenerateGraphData[edgesMultiplier_] := Table[g = RandomGraph[{size, edgesMultiplier*size}]; gDirected = ResourceFunction["ToDirectedAcyclicGraph"][g, 1]; edgeUpdate = Association[# -> VertexOutComponent[gDirected, #, {1}] & /@ VertexList[gDirected]]; {size, First@AbsoluteTiming@ DepthFirstSearch[1, edgeUpdate, (True &)]}, {size, Range[10, 300, 10]}]; resultsDense = GenerateGraphData[3]; resultsSparse = GenerateGraphData[1]; ListLinePlot[{resultsDense, resultsSparse}, PlotLegends -> {"Dense", "Sparse"}, PlotStyle -> {Directive[Thick, Blue], Directive[Thick, Red]}, AxesLabel -> {"Graph Size", "Time (s)"}, PlotLabel -> "Performance Comparison: Dense vs Sparse", GridLines -> Automatic, GridLinesStyle -> Directive[LightGray, Dashed]] The implementation search space and history just barely accommodates the problems where the potential states in the search space potentially depend on the entire history up to that point. The knight's tour problem asks if a knight on a chessboard can visit every square without repetition. The more general Hamiltonian path problem addresses these different data accordingly. The complexity of the knight's tour problem moves back from the presented data; there were only a few instances where a near-complete tour was found..and I want to do it too in a reasonable time. While the knight's tour problem serves as a good test for the algorithm, we should find some Directed Acyclic Graph. The advantage of such graphs is that it's computationally cheap because there are directed edges (arcs) with no cycles so there's always a topologically linear ordering of the vertices such that for every directed edge from vertex A to vertex B, A comes before B in the ordering. edges = Flatten[ Table[DirectedEdge[Position[solution, i][[1]], Position[solution, i + 1][[1]]], {i, 1, 24}]] modifiedEdges = DeleteCases[edges, {1, 1, 1} \[DirectedEdge] {1, 2, 3}]; Graph[modifiedEdges] `We found such significant content that we didn't even find more efficient self-reproductive strategies like breadth-first search (BFS)...depth-first search is in many cases computationally expensive due to its nature of exploring as far as possible along the tree of life before backtracking. The DFS backtracking algorithm can be visualized as a herd of animals for the purpose of optimization; for instance, using heuristics to guide the search - there's really just one search - or employing pruning techniques to eliminate false starts that are unlikely to lead to a solution...it's a formidably sublime approach to explore graphs where no two adjacent countries have the same color, we could probably even apply this to the leaf project. For instance, the decision where the daisy sprouts come out is determined by the concentration of plant hormone. We could probably handle arbitrary DAGs and Iterators to get a more tree-like structure. Anyway. BFS can be computationally demanding to the large branching factor in the middle of the search. Again, BFS has the advantage of finding the shortest path from the starting position to any given target position on the board! Rather than finding a full knight's tour. It's sort of like growing some kind of cone cell in our eyes you've got to wire yourself up like BFS with the large number of possible board configurations: the depth-first nature tries to cover the board more extensively. It's like the Hiragana script, the possible moves of a knight as a tree or graph are neither skewed nor balanced in the conventional sense; the maximum breadth is 8, and the tree is so deep in terms of the sequences of moves that span the board; from the four central squares a knight can potentially reach every other square on the board in 6 moves..the maximum for the worst-case scenario. Posted 2 years ago  Hey, thanks again! Trying to set a good example here. I left my computer on to run an experiment for about an hour and a half, testing$6 \times 6$knight's tours up to a minute time constrained. In this data there were 87 instances of$Aborted, and the following 13 positive results:
Posted 2 years ago
 -- you have earned Featured Contributor Badge Your exceptional post has been selected for our editorial column Staff Picks http://wolfr.am/StaffPicks and Your Profile is now distinguished by a Featured Contributor Badge and is displayed on the Featured Contributor Board. Thank you!