# puzzle solver, intermediate steps not showing

Posted 10 years ago
13781 Views
|
7 Replies
|
1 Total Likes
|
 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 ideapuzzle[{{1, 3, 5}, {7, 0, 2}, {8, 4, 6}}]MatrixForm /@ %
7 Replies
Sort By:
Posted 10 years ago
 @Luis It certainly is possible to solve using Mathematica. Though you have to come up with a good algorithm in order to solve it.
Posted 10 years ago
 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 HuismanMight I suggest someone check my project more in detail, and this case is that  can not do in mathematica?
Posted 10 years ago
 By the way there is a great slide-puzzle at the Wolfram Demonstration project with free code:  Picture Puzzle
Posted 10 years ago
 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 belowbut what I need are all the intermediate steps that functions to find the solution,something like the followingI 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}}
Posted 10 years ago
 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 looploopNow 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.
Posted 10 years ago
 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.
Posted 10 years ago
 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.