I've tried to implement Breadth First Search algorithm in MMA, to attempt to solve the 8-puzzle game. But in some cases, I ran out of memory, but on other cases it solves without problem.
Here is the code I am using to make BFS, in the case of inicial = {{1, 6, 2}, {0, 4, 3}, {7, 5, 8}}; you get the desired answer, execute the following and see the result
mutacion[tablero_List] :=
Module[{posc, directions, newposs, olddigits},
posc = Flatten[Position[tablero, 0]];
directions = Select[Tuples[Range[-1, 1], 2], Norm[#] == 1 &];
newposs = (posc + #) & /@ directions;
newposs = Select[newposs, FreeQ[#, 4] \[And] FreeQ[#, 0] &];
olddigits = Extract[tablero, newposs];
MapThread[
ReplacePart[tablero, {#1 -> 0, posc -> #2}] &, {newposs,
olddigits}]]
q = {}; map = {};
inicial = {{1, 6, 2}, {0, 4, 3}, {7, 5, 8}};
final = {{1, 2, 3}, {4, 5, 6}, {7, 8, 0}};
AppendTo[q, {inicial, 0}]
AppendTo[map, {inicial, 0}]
While[q != {}, prim = First@MinimalBy[q, Last];
hijos = Flatten[Most[MapAt[mutacion, prim, 1]], 1];
If[Not@MemberQ[map, #, Infinity],
AppendTo[q, {#, Last[prim] + 1}]] & /@ hijos;
If[Not@MemberQ[map, #, Infinity],
AppendTo[map, {#, Last[prim] + 1}]] & /@ hijos;
q = DeleteCases[q, prim, Infinity];
If[MemberQ[hijos, final],
Print["Found at the level : ", Last[prim] + 1]; Break[]]]
but when inicial = {{2, 1, 5}, {6, 3, 4}, {8, 0, 7}};I have waited for more than 15 minutes without getting any response, maybe the problem is with the command MemberQ, since that command must make many comparisons in increasingly larger lists. I want to ask you please can you help me to correct my mistakes and thus be able to improve my code to obtain the solutions. Thanks in advance, your help is very necessary and important
Answer
For benchmarking let's turn code from OP to a function.
mutacion // ClearAll
mutacion@tablero_List := Module[{posc, directions, newposs, olddigits},
posc = Flatten@Position[tablero, 0];
directions = Select[Tuples[Range[-1, 1], 2], Norm@# == 1 &];
newposs = (posc + #) & /@ directions;
newposs = Select[newposs, FreeQ[#, 4] \[And] FreeQ[#, 0] &];
olddigits = Extract[tablero, newposs];
MapThread[ReplacePart[tablero, {#1 -> 0, posc -> #2}]&, {newposs, olddigits}]
]
solve8puzzleBullitohappy // ClearAll
solve8puzzleBullitohappy[inicial_, final_] := Module[{q, map},
q = {};
map = {};
AppendTo[q, {inicial, 0}];
AppendTo[map, {inicial, 0}];
While[q != {},
Module[{prim, hijos},
prim = First@MinimalBy[q, Last];
hijos = Flatten[Most@MapAt[mutacion, prim, 1], 1];
If[Not@MemberQ[map, #, Infinity], AppendTo[q, {#, Last@prim + 1}]]& /@ hijos;
If[Not@MemberQ[map, #, Infinity], AppendTo[map, {#, Last@prim + 1}]] & /@ hijos;
q = DeleteCases[q, prim, Infinity];
If[MemberQ[hijos, final],
(*Print["Found at the level : ", Last@prim + 1];*)
Break[]
]
]
];
{q, map}
]
I don't see any bugs in above code, it's just slow.
final = {{1, 2, 3}, {4, 5, 6}, {7, 8, 0}};
res = solve8puzzleBullitohappy[{{1, 0, 3}, {4, 2, 5}, {7, 8, 6}}, final]; // MaxMemoryUsed // RepeatedTiming
res[[2, -1, 2]]
(* {0.0019, 32672} *)
(* 3 *)
res = solve8puzzleBullitohappy[{{4, 1, 3}, {2, 0, 5}, {7, 8, 6}}, final]; // MaxMemoryUsed // RepeatedTiming
res[[2, -1, 2]]
(* {0.015, 60944} *)
(* 6 *)
res = solve8puzzleBullitohappy[{{4, 1, 3}, {2, 8, 0}, {7, 6, 5}}, final]; // MaxMemoryUsed // RepeatedTiming
res[[2, -1, 2]]
(* {0.210, 204752} *)
(* 9 *)
res = solve8puzzleBullitohappy[{{0, 4, 1}, {2, 8, 3}, {7, 6, 5}}, final]; // MaxMemoryUsed // RepeatedTiming
res[[2, -1, 2]]
(* {1.24, 506408} *)
(* 12 *)
In Mathematica appending to a list requires copying whole list. Also, as noted in OP, finding element using MemberQ requires, in worst case, traversing whole list. That's why doing above things in each iteration is not the best idea, and bare list is not the best implementation of a queue needed in BFS.
Mathematicas data structure that offers fast appending, membership test, and random access by key and by position is Association, so we can use it instead of lists.
Instead of "level" let's store, as value in our association, board from which board used as key was created. This way we'll be able to easily recover path from initial to final board.
$newPos = Table[
Select[({i, j} + #) & /@ {{-1, 0}, {0, -1}, {0, 1}, {1, 0}}, FreeQ[#, 4] \[And] FreeQ[#, 0] &],
{i, 3}, {j, 3}
];
(* https://mathematica.stackexchange.com/q/153689/14303 *)
getKey = First@Keys@#1[[{#2}]]&;
board8PuzzleQ = MatrixQ[#, IntegerQ] && Dimensions@# === {3, 3} && Union @@ # === Range[0, 8] &;
solve8puzzleJkuczmAssoc // ClearAll
solve8puzzleJkuczmAssoc[initial_?board8PuzzleQ, initial_] := {{initial}, <|initial -> None|>}
solve8puzzleJkuczmAssoc[initial_?board8PuzzleQ, final_?board8PuzzleQ] := Module[
{cameFrom = <|initial -> None|>, pos = 1}
,
While[pos <= Length@cameFrom,
Module[{board, zeroPos},
board = getKey[cameFrom, pos];
zeroPos = First@Position[board, 0, {2}, 1, Heads -> False];
Scan[
With[{newBoard = ReplacePart[board, {#1 -> 0, zeroPos -> Extract[board, #1]}]},
If[Not@KeyExistsQ[cameFrom, newBoard],
AppendTo[cameFrom, newBoard -> board];
If[newBoard === final, Break[]];
]
]&,
Extract[$newPos, zeroPos]
];
++pos;
]
];
{Reverse@Developer`ToPackedArray@Most@NestWhileList[cameFrom, getKey[cameFrom, -1], # =!= None &], cameFrom}
]
Let's check that solve8puzzleJkuczmAssoc returns correct paths.
validPathQ // ClearAll
validPathQ[initial_, initial_] := # === {initial}&
validPathQ[initial_, final_] := # === {} || First@# === initial && Last@# === final && AllTrue[
Differences@#,
With[{pos = Position[#, Except@0, {2}, Heads -> False]},
Total[#, 2] === 0 && Length@pos === 2 && MatchQ[Subtract @@ pos, {-1, 0} | {0, -1}]
]&
]&;
final = {{1, 2, 3}, {4, 5, 6}, {7, 8, 0}};
AllTrue[
{
{{1, 2, 3}, {4, 5, 6}, {7, 8, 0}}, {{1, 2, 3}, {4, 5, 0}, {7, 8, 6}},
{{1, 2, 0}, {4, 5, 3}, {7, 8, 6}}, {{1, 0, 2}, {4, 5, 3}, {7, 8, 6}},
{{1, 5, 2}, {4, 0, 3}, {7, 8, 6}}, {{1, 5, 2}, {0, 4, 3}, {7, 8, 6}},
{{0, 5, 2}, {1, 4, 3}, {7, 8, 6}}, {{5, 0, 2}, {1, 4, 3}, {7, 8, 6}},
{{5, 4, 2}, {1, 0, 3}, {7, 8, 6}}, {{5, 4, 2}, {0, 1, 3}, {7, 8, 6}},
{{5, 4, 2}, {7, 1, 3}, {0, 8, 6}}, {{5, 4, 2}, {7, 1, 3}, {8, 0, 6}},
{{5, 4, 2}, {7, 0, 3}, {8, 1, 6}}, {{5, 4, 2}, {7, 3, 0}, {8, 1, 6}},
{{5, 4, 2}, {7, 3, 6}, {8, 1, 0}}, {{5, 4, 2}, {7, 3, 6}, {8, 0, 1}},
{{5, 4, 2}, {7, 0, 6}, {8, 3, 1}}, {{5, 4, 2}, {7, 6, 0}, {8, 3, 1}}
},
validPathQ[#, final]@First@solve8puzzleJkuczmAssoc[#, final]&
]
(* True *)
It's faster:
res = solve8puzzleJkuczmAssoc[{{1, 0, 3}, {4, 2, 5}, {7, 8, 6}}, final]; // MaxMemoryUsed // RepeatedTiming
Length@First@res - 1
(* {0.00050, 31304} *)
(* 3 *)
res = solve8puzzleJkuczmAssoc[{{4, 1, 3}, {2, 0, 5}, {7, 8, 6}}, final]; // MaxMemoryUsed // RepeatedTiming
Length@First@res - 1
(* {0.0029, 62424} *)
(* 6 *)
res = solve8puzzleJkuczmAssoc[{{4, 1, 3}, {2, 8, 0}, {7, 6, 5}}, final]; // MaxMemoryUsed // RepeatedTiming
Length@First@res - 1
(* {0.0195, 222616} *)
(* 9 *)
res = solve8puzzleJkuczmAssoc[{{0, 4, 1}, {2, 8, 3}, {7, 6, 5}}, final]; // MaxMemoryUsed // RepeatedTiming
Length@First@res - 1
(* {0.0838, 556456} *)
(* 12 *)
but still a bit slow. Finding 28 element path from OP requires almost two and half hour.
First@solve8puzzleJkuczmAssoc[{{2, 1, 5}, {6, 3, 4}, {8, 0, 7}}, final] // AbsoluteTiming
(* {8387.69, {
{{2, 1, 5}, {6, 3, 4}, {8, 0, 7}}, {{2, 1, 5}, {6, 0, 4}, {8, 3, 7}},
{{2, 1, 5}, {6, 4, 0}, {8, 3, 7}}, {{2, 1, 0}, {6, 4, 5}, {8, 3, 7}},
{{2, 0, 1}, {6, 4, 5}, {8, 3, 7}}, {{2, 4, 1}, {6, 0, 5}, {8, 3, 7}},
{{2, 4, 1}, {6, 3, 5}, {8, 0, 7}}, {{2, 4, 1}, {6, 3, 5}, {8, 7, 0}},
{{2, 4, 1}, {6, 3, 0}, {8, 7, 5}}, {{2, 4, 1}, {6, 0, 3}, {8, 7, 5}},
{{2, 4, 1}, {0, 6, 3}, {8, 7, 5}}, {{2, 4, 1}, {8, 6, 3}, {0, 7, 5}},
{{2, 4, 1}, {8, 6, 3}, {7, 0, 5}}, {{2, 4, 1}, {8, 0, 3}, {7, 6, 5}},
{{2, 4, 1}, {0, 8, 3}, {7, 6, 5}}, {{0, 4, 1}, {2, 8, 3}, {7, 6, 5}},
{{4, 0, 1}, {2, 8, 3}, {7, 6, 5}}, {{4, 1, 0}, {2, 8, 3}, {7, 6, 5}},
{{4, 1, 3}, {2, 8, 0}, {7, 6, 5}}, {{4, 1, 3}, {2, 8, 5}, {7, 6, 0}},
{{4, 1, 3}, {2, 8, 5}, {7, 0, 6}}, {{4, 1, 3}, {2, 0, 5}, {7, 8, 6}},
{{4, 1, 3}, {0, 2, 5}, {7, 8, 6}}, {{0, 1, 3}, {4, 2, 5}, {7, 8, 6}},
{{1, 0, 3}, {4, 2, 5}, {7, 8, 6}}, {{1, 2, 3}, {4, 0, 5}, {7, 8, 6}},
{{1, 2, 3}, {4, 5, 0}, {7, 8, 6}}, {{1, 2, 3}, {4, 5, 6}, {7, 8, 0}}
}} *)
To make our code faster we can use the fact that our problem space is relatively small, there are only $9! = 362 \, 880$ possible permutations of board elements. Permutations can be easily enumerated, so we can store association, of rank of permutation to rank of permutation preceding it on searched path, in a $362 \, 880$-element array of integers. In each iteration we'll need to swap two elements in a permutation, but this can be done at the level of Lehmer code without full "unranking" of permutation. This will be the basis of our compiled solution.
Let's gather necessary building blocks.
ClearAll[quote, unquote, eval, inline]
SetAttributes[{quote, unquote}, HoldAllComplete]
quote@expr : Except@_Symbol := Unevaluated@expr /. {x : _unquote | _quote | _inline :> x, s_Symbol :> quote@s}
unquote@args___ := args
eval = # /. HoldPattern@quote@s_ :> s &;
inline::unsupported = "`1` is not one of function formats supported by inline.";
inline@HoldPattern@Function[args_ , body_, attrs_ | PatternSequence[]] := Function[args, quote@body, attrs]
inline@f_ := (Message[inline::unsupported, HoldForm@f]; $Failed)
qCompiledPartOptimize = # //.
quote[Part][quote[Part][x__], y__] :> quote[Part][x, y] /.
Part -> Compile`GetElement //.
quote[Set][quote[Compile`GetElement]@x__, y_] :> quote[Part@x = y] &;
qSubtractOptimize = # //.
quote[Plus][pre___, x_, quote[Times][-1, y_], post___] :> quote[Plus][pre, quote[Subtract][x, y], post] &;
permutationToRank = Function[{perm, n, factorial},
Module[{i, j, lehmerCode = perm, result = 1},
Do[
Do[
If[lehmerCode[[j]] > lehmerCode[[i]],
lehmerCode[[j]] = lehmerCode[[j]] - 1
],
{j, i + 1, n}
];
result += (lehmerCode[[i]] - 1) factorial[[n - i + 1]];
,
{i, n}
];
result
]
];
rankToPermutation = Function[{rank, n, permElements, factorial},
Module[{rem, s, i},
rem = Mod[rank - 1, factorial[[n + 1]]];
s = permElements;
Table[
Module[{revIndex, fac, q, el},
revIndex = n - i;
fac = factorial[[revIndex + 1]];
q = Quotient[rem, fac] + 1;
el = s[[q]];
rem = Mod[rem, fac];
Do[s[[j]] = s[[j + 1]], {j, q, revIndex}];
el
]
,
{i, n}
]
]
];
rankToLehmerCode = Function[{result, rank, n, factorial},
Module[{rem = Mod[rank - 1, factorial[[n + 1]]], i},
Do[
Module[{fac, q, k},
fac = factorial[[n - i + 1]];
result[[i]] = Quotient[rem, fac];
rem = Mod[rem, fac];
],
{i, n}
];
],
HoldFirst
];
lehmerCodeToSwappedRank = Function[{lehmerCode, swappedPos1, swappedPos2, n, factorial},
Module[{left, right, i, result},
If[swappedPos1 < swappedPos2,
left = swappedPos1;
right = swappedPos2;
(* else *),
left = swappedPos2;
right = swappedPos1;
];
result = 1;
Do[result += lehmerCode[[i]] factorial[[n - i + 1]];, {i, left - 1}];
Module[{leftLC, rightLC, oldLeftLC, min, max, d},
leftLC = oldLeftLC = lehmerCode[[left]];
rightLC = lehmerCode[[right]];
Do[If[rightLC >= lehmerCode[[i]], ++rightLC], {i, right - 1, left, -1}];
result += rightLC factorial[[n - left + 1]];
If[oldLeftLC < rightLC,
min = oldLeftLC;
max = rightLC;
d = 1;
(* else *),
min = rightLC;
max = oldLeftLC;
d = -1;
];
If[rightLC <= leftLC, --leftLC];
Do[
Module[{kthQ = lehmerCode[[i]]},
If[kthQ < max,
--max;
If[kthQ < min,
--min;
(* else *),
kthQ += d;
];
];
If[kthQ <= leftLC, --leftLC];
result += kthQ factorial[[n - i + 1]];
],
{i, left + 1, right - 1}
];
result += leftLC factorial[[n - right + 1]];
];
Do[result += lehmerCode[[i]] factorial[[n - i + 1]];, {i, right + 1, n}];
result
]
];
oneElSwapPermutationsBFS // ClearAll
oneElSwapPermutationsBFS[rankToLehmerCode_, lehmerCodeToSwappedRank_, breakWhenFound_ : True | False] := quote@Function[
{cameFrom, next, lehmerCode, found, last, initialRank, finalRank, newPosList, newPosBounds, n, factorial},
Module[{first, prevPos},
cameFrom[[initialRank]] = 0;
first = last = initialRank;
unquote@If[breakWhenFound, quote[found = initialRank === finalRank]];
prevPos = 0;
While[unquote@If[breakWhenFound, quote[first > 0 && Not@found], quote[first > 0]],
Module[{zeroPos},
rankToLehmerCode[lehmerCode, first, n, factorial];
zeroPos = 1;
While[lehmerCode[[zeroPos]] =!= 0, ++zeroPos];
Do[
Module[{newPos, newBoard, left, right, newRank},
newPos = newPosList[[i]];
If[newPos === prevPos, Continue[]];
newRank = lehmerCodeToSwappedRank[lehmerCode, zeroPos, newPos, n, factorial];
If[cameFrom[[newRank]] === -1,
cameFrom[[newRank]] = first;
next[[last]] = newRank;
last = newRank;
unquote@If[breakWhenFound, quote@If[newRank === finalRank, found = True; Break[]]];
]
],
{i, newPosBounds[[zeroPos]] + 1, newPosBounds[[zeroPos + 1]]}
];
first = next[[first]];
prevPos = zeroPos;
]
];
],
HoldAll
] // eval;
getPermutationsPath // ClearAll
getPermutationsPath[rankToPermutation_, reversed_ : True | False] := quote@Function[{cameFrom, initialRank, n, permElements, factorial},
Module[{bag, prev, resultRanks, resultLen},
bag = Internal`Bag@Most@{0};
prev = cameFrom[[initialRank]];
If[prev > -1,
Internal`StuffBag[bag, initialRank];
While[prev > 0,
Internal`StuffBag[bag, prev];
prev = cameFrom[[prev]];
];
];
resultRanks = Internal`BagPart[bag, All];
resultLen = Length@resultRanks;
Table[
rankToPermutation[
resultRanks[[unquote@If[reversed, quote[resultLen - i + 1], quote[i]]]],
n, permElements, factorial
],
{i, resultLen}
]
]
] // eval;
Now our final compiled function specialized for $3 \times 3$ boards.
boardToRank = Function[{board, n, factorial},
Module[{i, j, lehmerCode = Flatten@board, result = 1},
Do[
Do[
If[lehmerCode[[j]] > lehmerCode[[i]],
lehmerCode[[j]] = lehmerCode[[j]] - 1
],
{j, i + 1, n}
];
result += lehmerCode[[i]] factorial[[n - i + 1]];
,
{i, n}
];
result
]
];
rankToBoard = Function[{rank, n, l, factorial},
Module[{rem, s, i, j},
rem = Mod[rank - 1, factorial[[n + 1]]];
s = l;
Table[
Module[{revIndex, fac, q, el, k},
revIndex = n - (3 i + j);
fac = factorial[[revIndex + 1]];
q = Quotient[rem, fac] + 1;
el = s[[q]];
rem = Mod[rem, fac];
Do[s[[k]] = s[[k + 1]], {k, q, revIndex}];
el
],
{i, 0, 2},
{j, 3}
]
]
];
$8puzzleNewPos = {2, 4, 1, 3, 5, 2, 6, 1, 5, 7, 2, 4, 6, 8, 3, 5, 9, 4, 8, 5, 7, 9, 6, 8};
$8puzzleNewPosBounds = {0, 2, 5, 7, 10, 14, 17, 19, 22, 24};
solve8puzzleJkuczmCompiledInternalC = With[
{
newPos = $8puzzleNewPos, newPosBounds = $8puzzleNewPosBounds,
n = 9, elements = Range[0, 8], factorial = Factorial@Range[0, 9]
},
quote@Compile[{{initial, _Integer, 2}, {final, _Integer, 2}},
Module[{finalRank, initialRank, cameFrom, next, last, found, lehmerCode},
initialRank = inline[boardToRank][initial, n, factorial];
finalRank = inline[boardToRank][final, n, factorial];
cameFrom = Table[-1, unquote@Last@factorial];
next = Table[-1, unquote@Last@factorial];
lehmerCode = Table[-1, {n}];
inline[oneElSwapPermutationsBFS[
Unevaluated@inline@rankToLehmerCode, Unevaluated@inline@lehmerCodeToSwappedRank, True
]][
cameFrom, next, lehmerCode, found, last,
initialRank, finalRank, newPos, newPosBounds, n, factorial
];
inline[getPermutationsPath[Unevaluated@inline@rankToBoard, True]][
cameFrom, finalRank, n, elements, factorial
]
],
CompilationTarget -> "C", RuntimeOptions -> "Speed",
RuntimeAttributes -> {Listable}, Parallelization -> True
] // qCompiledPartOptimize // qSubtractOptimize // eval
];
solve8puzzleJkuczmCompiledInternalLib = solve8puzzleJkuczmCompiledInternalC // Last;
solve8puzzleJkuczmCompiled // ClearAll
solve8puzzleJkuczmCompiled[initial_, final_] := Module[{multiple = False, dimCheck},
dimCheck = Replace[Dimensions@#, {{x___, 3, 3} :> If[{x} =!= {}, multiple = True], _ :> Return[$Failed, Module]}]&;
dimCheck@initial;
dimCheck@final;
Check[
If[multiple, solve8puzzleJkuczmCompiledInternalC, solve8puzzleJkuczmCompiledInternalLib][
initial, final
],
$Failed
]
]
Let's check that it gives correct paths on 100 pairs of random boards:
randomBoard = Partition[RandomSample@Range[0, 8], 3]&;
SeedRandom@0
And @@ Table[
With[{initial = randomBoard[], final = randomBoard[]},
validPathQ[initial, final]@solve8puzzleJkuczmCompiled[initial, final]
],
100
] // AbsoluteTiming
(* {8.21514, True} *)
With compiled function, finding 28 element path, from OP, takes one tenth of a second:
solve8puzzleJkuczmCompiled[{{2, 1, 5}, {6, 3, 4}, {8, 0, 7}}, final] // RepeatedTiming
(* {0.101, {
{{2, 1, 5}, {6, 3, 4}, {8, 0, 7}}, {{2, 1, 5}, {6, 0, 4}, {8, 3, 7}},
{{2, 1, 5}, {6, 4, 0}, {8, 3, 7}}, {{2, 1, 0}, {6, 4, 5}, {8, 3, 7}},
{{2, 0, 1}, {6, 4, 5}, {8, 3, 7}}, {{2, 4, 1}, {6, 0, 5}, {8, 3, 7}},
{{2, 4, 1}, {6, 3, 5}, {8, 0, 7}}, {{2, 4, 1}, {6, 3, 5}, {8, 7, 0}},
{{2, 4, 1}, {6, 3, 0}, {8, 7, 5}}, {{2, 4, 1}, {6, 0, 3}, {8, 7, 5}},
{{2, 4, 1}, {0, 6, 3}, {8, 7, 5}}, {{2, 4, 1}, {8, 6, 3}, {0, 7, 5}},
{{2, 4, 1}, {8, 6, 3}, {7, 0, 5}}, {{2, 4, 1}, {8, 0, 3}, {7, 6, 5}},
{{2, 4, 1}, {0, 8, 3}, {7, 6, 5}}, {{0, 4, 1}, {2, 8, 3}, {7, 6, 5}},
{{4, 0, 1}, {2, 8, 3}, {7, 6, 5}}, {{4, 1, 0}, {2, 8, 3}, {7, 6, 5}},
{{4, 1, 3}, {2, 8, 0}, {7, 6, 5}}, {{4, 1, 3}, {2, 8, 5}, {7, 6, 0}},
{{4, 1, 3}, {2, 8, 5}, {7, 0, 6}}, {{4, 1, 3}, {2, 0, 5}, {7, 8, 6}},
{{4, 1, 3}, {0, 2, 5}, {7, 8, 6}}, {{0, 1, 3}, {4, 2, 5}, {7, 8, 6}},
{{1, 0, 3}, {4, 2, 5}, {7, 8, 6}}, {{1, 2, 3}, {4, 0, 5}, {7, 8, 6}},
{{1, 2, 3}, {4, 5, 0}, {7, 8, 6}}, {{1, 2, 3}, {4, 5, 6}, {7, 8, 0}}
}} *)
Since we can easily store information on paths from all possible boards to selected final board, we don't need to calculate them each time. We can precalculate all those paths once and than just retrieve them when needed.
With[
{
newPos = $8puzzleNewPos, newPosBounds = $8puzzleNewPosBounds,
n = 9, elements = Range[0, 8], factorial = Factorial@Range[0, 9]
},
solve8puzzleJkuczmPrecalcPathsToC = quote@Compile[{{initial, _Integer, 2}},
Module[{initialRank, leadsTo, next, first, last, lehmerCode, prevPos, dummy},
initialRank = inline[boardToRank][initial, n, factorial];
leadsTo = Table[-1, unquote@Last@factorial];
next = Table[-1, unquote@Last@factorial];
lehmerCode = Table[-1, {n}];
inline[oneElSwapPermutationsBFS[Unevaluated@inline@rankToLehmerCode, Unevaluated@inline@lehmerCodeToSwappedRank, False]][
leadsTo, next, lehmerCode, False, last, initialRank, 0, newPos, newPosBounds, n, factorial
];
leadsTo
],
CompilationTarget -> "C", RuntimeOptions -> "Speed",
RuntimeAttributes -> {Listable}, Parallelization -> True
] // qCompiledPartOptimize // qSubtractOptimize // eval;
solve8puzzleJkuczmPrecalcPathsToLib = solve8puzzleJkuczmPrecalcPathsToC // Last;
solve8puzzleJkuczmPrecalcPathFromC = quote@Compile[
{{initial, _Integer, 2}, {leadsTo, _Integer, 1}},
Module[{initialRank, prev, bag, resultRanks, resultLen, result},
initialRank = inline[boardToRank][initial, n, factorial];
inline[getPermutationsPath[Unevaluated@inline@rankToBoard, False]][leadsTo, initialRank, n, elements, factorial]
],
CompilationTarget -> "C", RuntimeOptions -> "Speed",
RuntimeAttributes -> {Listable}, Parallelization -> True
] // qCompiledPartOptimize // qSubtractOptimize // eval;
solve8puzzleJkuczmPrecalcPathFromLib = solve8puzzleJkuczmPrecalcPathFromC // Last;
]
solve8puzzleJkuczmPrecalc // ClearAll
solve8puzzleJkuczmPrecalc@final_ :=
With[{multiple = Replace[Dimensions@final, {{x___, 3, 3} :> {x} =!= {}, _ :> Return[$Failed, With]}]},
With[
{
multipleQ = If[multiple, True&, {##} =!= {}&],
leadsTo = If[multiple,
solve8puzzleJkuczmPrecalcPathsToC
(* else *),
solve8puzzleJkuczmPrecalcPathsToLib
]@final
},
Check[
If[Replace[Dimensions@#, {{x___, 3, 3} :> multipleQ@x, _ :> Return[$Failed, Check]}],
solve8puzzleJkuczmPrecalcPathFromC
(* else *),
solve8puzzleJkuczmPrecalcPathFromLib
][#, leadsTo],
$Failed
]&
]]
Precalculation takes one tenth of a second.
f = solve8puzzleJkuczmPrecalc@{{1, 2, 3}, {4, 5, 6}, {7, 8, 0}}; // MaxMemoryUsed // RepeatedTiming
(* {0.104, 8711688} *)
Then getting arbitrary path leading to given final board takes time of order $10^{-5}$ second.
f@{{2, 1, 5}, {6, 3, 4}, {8, 0, 7}} // MaxMemoryUsed // RepeatedTiming
(* {0.0000233, 11936} *)
Getting all paths to given final board takes one and a half second.
boards = ArrayReshape[Permutations@Range[0, 8], {9!, 3, 3}];
allPaths = f@boards; // RepeatedTiming
allPaths // ByteCount
(* {1.5, Null} *)
(* 347143432 *)
Let's check that all paths are valid:
AllTrue[Range@Length@boards, validPathQ[boards[[#]], final]@allPaths[[#]] &] // AbsoluteTiming
(* {44.4838, True} *)
and how long they are:
Length /@ allPaths // Counts // KeySort
ListPlot[%, PlotRange -> Full]
(* <|0 -> 181440, 1 -> 1, 2 -> 2, 3 -> 4, 4 -> 8, 5 -> 16, 6 -> 19, 7 -> 37,
8 -> 58, 9 -> 108, 10 -> 142, 11 -> 267, 12 -> 366, 13 -> 693, 14 -> 965,
15 -> 1786, 16 -> 2363, 17 -> 4238, 18 -> 5372, 19 -> 9153, 20 -> 10555,
21 -> 16585, 22 -> 16835, 23 -> 23778, 24 -> 20350, 25 -> 24422, 26 -> 16064,
27 -> 15204, 28 -> 6644, 29 -> 4221, 30 -> 886, 31 -> 287, 32 -> 11|> *)
We can see that from exactly half of boards we can't reach given final board, and that longest found paths walk through 32 boards.
Since all boards with zero in specified position differ only by relabeling of other elements, there are at most 9 distinct "final" boards. Since we can also "rotate" board, I believe, there are only 3 representative boards: with zero in the corner; - with zero on the side, but not in corner; - and with zero in the middle. After precalculating paths for all of them we can get path between arbitrary two boards by simple relabeling of non-zero elements.
Let's compare calculation times for paths starting on consecutive elements on one of 32-board paths.
Needs@"GeneralUtilities`"
With[
{
init = {
{{1, 2, 3}, {4, 5, 0}, {7, 8, 6}},
{{1, 2, 0}, {4, 5, 3}, {7, 8, 6}}, {{1, 0, 2}, {4, 5, 3}, {7, 8, 6}},
{{1, 5, 2}, {4, 0, 3}, {7, 8, 6}}, {{1, 5, 2}, {0, 4, 3}, {7, 8, 6}},
{{0, 5, 2}, {1, 4, 3}, {7, 8, 6}}, {{5, 0, 2}, {1, 4, 3}, {7, 8, 6}},
{{5, 4, 2}, {1, 0, 3}, {7, 8, 6}}, {{5, 4, 2}, {0, 1, 3}, {7, 8, 6}},
{{5, 4, 2}, {7, 1, 3}, {0, 8, 6}}, {{5, 4, 2}, {7, 1, 3}, {8, 0, 6}},
{{5, 4, 2}, {7, 0, 3}, {8, 1, 6}}, {{5, 4, 2}, {7, 3, 0}, {8, 1, 6}},
{{5, 4, 2}, {7, 3, 6}, {8, 1, 0}}, {{5, 4, 2}, {7, 3, 6}, {8, 0, 1}},
{{5, 4, 2}, {7, 0, 6}, {8, 3, 1}}, {{5, 4, 2}, {7, 6, 0}, {8, 3, 1}},
{{5, 4, 0}, {7, 6, 2}, {8, 3, 1}}, {{5, 0, 4}, {7, 6, 2}, {8, 3, 1}},
{{0, 5, 4}, {7, 6, 2}, {8, 3, 1}}, {{7, 5, 4}, {0, 6, 2}, {8, 3, 1}},
{{7, 5, 4}, {6, 0, 2}, {8, 3, 1}}, {{7, 0, 4}, {6, 5, 2}, {8, 3, 1}},
{{0, 7, 4}, {6, 5, 2}, {8, 3, 1}}, {{6, 7, 4}, {0, 5, 2}, {8, 3, 1}},
{{6, 7, 4}, {8, 5, 2}, {0, 3, 1}}, {{6, 7, 4}, {8, 5, 2}, {3, 0, 1}},
{{6, 7, 4}, {8, 0, 2}, {3, 5, 1}}, {{6, 7, 4}, {8, 2, 0}, {3, 5, 1}},
{{6, 7, 0}, {8, 2, 4}, {3, 5, 1}}, {{6, 0, 7}, {8, 2, 4}, {3, 5, 1}}
},
final = {{1, 2, 3}, {4, 5, 6}, {7, 8, 0}}
},
Internal`InheritedBlock[{Benchmark},
SetOptions[Benchmark, TimeConstraint -> 600.];
BenchmarkPlot[
<|
"bullitohappy" -> (solve8puzzleBullitohappy[#, final]&),
"assoc" -> (solve8puzzleJkuczmAssoc[#, final]&),
"compiled" -> (solve8puzzleJkuczmCompiled[#, final]&),
"precalc" -> solve8puzzleJkuczmPrecalc@final
|>,
init[[#]]&,
Range@Length@init
]
]
]
We see that running time of compiled function for short paths is almost constant and, up to 5-element path, higher than top level association based solution. That's because, for short paths, running time is dominated by creation of large array storing permutation ranks. For large paths time plateaus at around $0.1$ second that's the time needed to search through all boards.
For function with precalculated data time is proportional to length of a path, with tiny proportionality constant.
Let's add simple function visualizing our solutions.
animate8puzzleSolution // ClearAll
animate8puzzleSolution[sol : {__?board8PuzzleQ}, img_Image, opts : OptionsPattern@ListAnimate] :=
Module[{size, imgAssoc},
size = Floor[Min@ImageDimensions@img / 3];
imgAssoc = AssociationThread[Flatten@Last@sol -> Flatten@ImagePartition[img, size]];
imgAssoc@0 = Image@SparseArray[{}, {size, size}, 1];
ListAnimate[GraphicsGrid /@ Map[imgAssoc, sol, {3}], opts, AnimationRate -> 1, Deployed -> True]
]
For path from OP we get:
f = solve8puzzleJkuczmPrecalc@{{1, 2, 3}, {4, 5, 6}, {7, 8, 0}};
f@{{2, 1, 5}, {6, 3, 4}, {8, 0, 7}};
animate8puzzleSolution[%, ExampleData@{"TestImage", "Mandrill"}]
Comments
Post a Comment