puzzle solver, intermediate steps not showing

Questions
, ,
1

Hello, I write to ask for your help to solve the following problem as a board, give the intermediate steps to reach the solution state, which in my case is {{1,2,3}, {4,5,6}, {7,8,0}};
I implemented the following function that gives the possible permutations of a board,

mutacion[tablero_List] := Module[{posc, i, j, permu, tabli},
  posc = Flatten[Position[tablero, 0]];
  i = posc[[1]]; j = posc[[2]]; permu = {};
    Which[
   i == 1 && j == 1,
   tabli = tablero; tabli[[i, j]] = tablero[[i, j + 1]]; 
   tabli[[i, j + 1]] = 0; AppendTo[permu, tabli];(*derecha*)
   
   tabli = tablero; tabli[[i, j]] = tablero[[i + 1, j]]; 
   tabli[[i + 1, j]] = 0; AppendTo[permu, tabli];(*abajo*),
   i == 2 && j == 1,
   tabli = tablero; tabli[[i, j]] = tablero[[i - 1, j]]; 
   tabli[[i - 1, j]] = 0; AppendTo[permu, tabli];(*arriba*)
   
   tabli = tablero; tabli[[i, j]] = tablero[[i, j + 1]]; 
   tabli[[i, j + 1]] = 0; AppendTo[permu, tabli];(*derecha*)
   
   tabli = tablero; tabli[[i, j]] = tablero[[i + 1, j]]; 
   tabli[[i + 1, j]] = 0; AppendTo[permu, tabli];,(*abajo*)
   
   i == 3 && j == 1, tabli = tablero; 
   tabli[[i, j]] = tablero[[i - 1, j]]; tabli[[i - 1, j]] = 0; 
   AppendTo[permu, tabli];(*arriba*)
   tabli = tablero; 
   tabli[[i, j]] = tablero[[i, j + 1]]; tabli[[i, j + 1]] = 0; 
   AppendTo[permu, tabli];(*derecha*),
   i == 1 && j == 2,
   tabli = tablero; tabli[[i, j]] = tablero[[i, j + 1]]; 
   tabli[[i, j + 1]] = 0; AppendTo[permu, tabli];(*derecha*)
   
   tabli = tablero; tabli[[i, j]] = tablero[[i + 1, j]]; 
   tabli[[i + 1, j]] = 0; AppendTo[permu, tabli];(*abajo*)
   
   tabli = tablero; tabli[[i, j]] = tablero[[i, j - 1]]; 
   tabli[[i, j - 1]] = 0; AppendTo[permu, tabli];(*izquierda*),
   i == 2 && j == 2,
   tabli = tablero; tabli[[i, j]] = tablero[[i - 1, j]]; 
   tabli[[i - 1, j]] = 0; AppendTo[permu, tabli];(*arriba*)
   
   tabli = tablero; tabli[[i, j]] = tablero[[i, j + 1]]; 
   tabli[[i, j + 1]] = 0; AppendTo[permu, tabli];(*derecha*)
   
   tabli = tablero; tabli[[i, j]] = tablero[[i + 1, j]]; 
   tabli[[i + 1, j]] = 0; AppendTo[permu, tabli];(*abajo*)
   
   tabli = tablero; tabli[[i, j]] = tablero[[i, j - 1]]; 
   tabli[[i, j - 1]] = 0; AppendTo[permu, tabli];(*izquierda*),
   i == 3 && j == 2,
   tabli = tablero; tabli[[i, j]] = tablero[[i - 1, j]]; 
   tabli[[i - 1, j]] = 0; AppendTo[permu, tabli];(*arriba*)
   
   tabli = tablero; tabli[[i, j]] = tablero[[i, j + 1]]; 
   tabli[[i, j + 1]] = 0; AppendTo[permu, tabli];(*derecha*)
   
   tabli = tablero; tabli[[i, j]] = tablero[[i, j - 1]]; 
   tabli[[i, j - 1]] = 0; AppendTo[permu, tabli];(*izquierda*),
   i == 1 && j == 3,
   tabli = tablero; tabli[[i, j]] = tablero[[i + 1, j]]; 
   tabli[[i + 1, j]] = 0; AppendTo[permu, tabli];(*abajo*)
   
   tabli = tablero; tabli[[i, j]] = tablero[[i, j - 1]]; 
   tabli[[i, j - 1]] = 0; AppendTo[permu, tabli];(*izquierda*),
   i == 2 && j == 3,
   tabli = tablero; tabli[[i, j]] = tablero[[i - 1, j]]; 
   tabli[[i - 1, j]] = 0; AppendTo[permu, tabli];(*arriba*)
   
   tabli = tablero; tabli[[i, j]] = tablero[[i + 1, j]]; 
   tabli[[i + 1, j]] = 0; AppendTo[permu, tabli];(*abajo*)
   
   tabli = tablero; tabli[[i, j]] = tablero[[i, j - 1]]; 
   tabli[[i, j - 1]] = 0; AppendTo[permu, tabli];(*izquierda*),
   i == 3 && j == 3,
   tabli = tablero; tabli[[i, j]] = tablero[[i - 1, j]]; 
   tabli[[i - 1, j]] = 0; AppendTo[permu, tabli];(*arriba*)
   
   tabli = tablero; tabli[[i, j]] = tablero[[i, j - 1]]; 
   tabli[[i, j - 1]] = 0; AppendTo[permu, tabli];(*izquierda*)
   ];
  permu]

In the following function, I set to do in the event that the first permutation is given board state solution

puzzle[tablero_List] := 
 Module[{per, k, exp = {}, fin, n, inter, prb, t, sig},
  If[tablero == {{1, 2, 3}, {4, 5, 6}, {7, 8, 0}},
   MatrixForm[tablero],
   per = mutacion[tablero];
   If[MemberQ[per, {{1, 2, 3}, {4, 5, 6}, {7, 8, 0}}, Infinity],
    PrependTo[per, tablero];
    per
    ,
    fin = mutacion[tablero];
    exp = Flatten[AppendTo[exp, fin], 1];
    For[k = 1, k <= Length@fin, k++,
     sig = mutacion [fin[[k]]];
     For[t = 1, t <= Length@sig, t++,
      If[FreeQ[exp, sig[[t]], Infinity],
       AppendTo[exp, sig[[t]]];
       exp
       ]
      ]
     ]
    ]
   ]
  ]

When you run it, do not get all the steps, this is where my problem arises,
I hope someone has some idea

puzzle[{{1, 3, 5}, {7, 0, 2}, {8, 4, 6}}]

MatrixForm /@ %
2

Hola Luis!

Your code is quite complicated to understand, could you tell us what kind of output you are expecting? Are you trying to find all the possible arrangements of 9 digits in a 3x3 matrix? Or is this like a slide-puzzle? What are you trying to find? We need some more background information.

3

Hola Luis!

I looked at your mutacion function and I now understand what it does, but the way you do it is complicated and long code. Here is a simplified version that does the same:

mutacion2[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}]
]

I will look at the other part of the code some later time.

4

Sander Huisman, first of all, thanks for the help, indeed it is the slide- puzzle,the function that you implemented surprised me with my puzzle function only get some intermediate steps slide-puzzle, as I show below

Pantallazo.png
Pantallazo.png1160×128 10.4 KB

but what I need are all the intermediate steps that functions to find the solution,something like the following
Pantallazo-1.png
I hope you continue to help me, because this is of great interest to me, my goal state is {{1,2,3}, {4,5,6}, {7,8,0}}, as shown in the last panel, why stop there, but I have not managed to that. in thissample, the start state is {{4,1,5},{7,0,2},{8,3,6}}

5

Dear Luis,

I’m not sure if you can evaluate this iteratively, because it can be very memory intensive:
If you start with some configuration a. You wil get 4 (or 3 or 2) new possible states, after that those also have 4 (or 3 or 2) possible states again, so you have 16, after that 64 after that 256. et cetera.. It will grow really fast. My idea would be to do it as follows:

start with a buffer of states and their origin:

buffer = {{{{1,2,3}, {4,5,6}, {7,8,0}},"start"}}

copy the buffer to second buffer.
Now iteratively (until we have the solution) we do:
For each item in the second buffer we calculate the new states and their origin (the previous state) and add them to the second buffer.
delete all the states from the second buffer that are already present in the primary buffer.
copy these states from the second buffer to the primary buffer.
check if the primary buffer has the end state somewhere in it: escape the loop
loop

Now from the final solution you have to track back to the start.

This is a little bit more difficult than your original code, but I think you have to do it in such kind of way, if you want to use this approach. Implementing requires some tricks of course. Maybe I will try later, can’t promise anything though.

6

By the way there is a great slide-puzzle at the Wolfram Demonstration project with free code: Picture Puzzle

7

Hi Vitaly, thanks for sharing the link of the puzzle, after seeing the program I realized that the author, makes random movements and so leaves the board, but does not have a button for the ppuzzle be resolved automatically.

Because what I need is to show the intermediate steps to get to the board based solution {{4,1,5}, 7,0,2}, {8,3,6}} or any other, as I discuss in Sander Huisman

Might I suggest someone check my project more in detail, and this case is that can not do in mathematica?

8

@Luis It certainly is possible to solve using Mathematica. Though you have to come up with a good algorithm in order to solve it.