5
$\begingroup$

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

$\endgroup$
3
$\begingroup$

Code from OP

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.


Association based queue

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}}
   }} *)

Compilation

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}}
   }} *)

Precalculation

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|> *)

path lengths plot

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.


Benchmarks

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
    ]
  ]
]

benchmarks

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.


Visualization

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"}]

Mandrill board

$\endgroup$
  • $\begingroup$ Thank you for sharing your knowledge is enriching for many. It is true when you say that my code is very slow, for that reason I asked for help in this community and your response is phenomenal, something I did not imagine. Maybe it seems weird but I also thought to use Associations but I was just thinking how to use them, I think I would not have used them in a better way than you did, in addition very good explanation and better yet the way to avoid the use of the ApendTo command . I should mention that the Lehmer code references and the enumeration of the permutations are very $\endgroup$ – bullitohappy Sep 25 '18 at 3:24
  • $\begingroup$ important for this 8-puzzle game, I will read them with more care to understand the code that you shared, your compilation solution and the precalculation solution are amazing but not very common, I congratulate you on the way to create and implement them, you should publish them in a blog that you have, I assure you that it is one of the things that many of us find very interesting. Again, thank you very much for your time and effort to help me in this project, which without your help would be floating on the web without direction. I will continue to review your code to learn more programming $\endgroup$ – bullitohappy Sep 25 '18 at 3:28

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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