4
$\begingroup$

I am trying to solve the 8-puzzle using two heuristics, which are: Pieces out of place and Distance Manhattan. After consulting several websites for example see and some books, I'm with some doubts, the most pressing is, in both heuristics should be counted zero? Let's go to the specific case, we start of the next board.

INITIAL BOARD

0 1 3

4 2 5

7 8 6

and we want to get to the final board

1 2 3

4 5 6

7 8 0

If we count the pieces of the initial board, we get that 5 pieces are out of place, it should be noted that we have taken into account the 0. As I mentioned earlier looking for information on the web I found something done in other languages and this is my function that I built

misplaced[board_List]:=Module[{i,j,cuenta},
cuenta = 0;
For[i=1,i<=3,i++,
  For[j=1,j<=3,j++,
    If[board[[i,j]]!= Mod[j+(i-1) 3, 9], cuenta++];
    ];  
   ];
cuenta
] 

Using it

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

I should mention trying to do it without using nested For, but I'm having problems with the results, see what I mean.

misplacedtwo[board_List]:= Table[
                                If[board[[i,j]]!= Mod[j+(i-1) 3, 9], cuenta++]
                                                    ,{i,1,3},{j,1,3}]

Test

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

The same thing happens with the manhattan function, that is to say, I have only managed to do it so that it counts zero but in a procedural way, you see what I mean.

valabs[a_, b_] := If [a > b, a - b, b - a]
manhattan[tablero_List] := Module[{i, j, x, y, cuenta = 0},
  For[i = 1, i <= 3, i++,
   For[j = 1, j <= 3, j++,
     If[tablero[[i, j]] == 0
       ,
       cuenta += 0;
       ,
       x = Quotient[tablero[[i, j]] - 1, 3] + 1;
       y = Mod[tablero[[i, j]] - 1, 3] + 1;
       cuenta = cuenta + valabs[x, i] + valabs[y, j];
       ];
     ];
   ];
  cuenta
  ]

Using it

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

I have not found a better way to build the functions mentioned above, I hope that you can guide me to do them in the MMA style and you can tell me if you should count the zero or not. Thanks for your help that is invaluable.

EDIT

Thanks to the solution that Bill provided, the misplaced function has been transformed to

Total [Abs [Sign [Flatten [b1] - Flatten [b2]]]]

the manhattan function, on the other hand, faces certain conflicts between obtained results. If we calculate the Manhattan distance as BillS points, we get 12, but if we use the manhattan function that I provide,

manhattan[b1]

we get 8, that's when the problem arises since different results are obtained. I did the calculations manually and got 8, I hope someone can clarify that controversy. Maybe there is a way to rewrite the manhattan function without using the For loops to get the same result, in this case 8. Thanks in advance.

$\endgroup$
  • $\begingroup$ Not strictly related to the question: generally speaking, For loops are slow and suboptimal on Mathematica; a preferred alternative is Do: For[i=1,i<=3,i++, For[j=1,j<=3,j++, (* code *)]] could become Do[(* code *), {i, 3}, {j, 3}]. $\endgroup$ – JungHwan Min Jul 6 '18 at 19:14
3
$\begingroup$

Here is a solution for the Manhattan Distance for your specific board format.

md[b_] :=
  With[{p = Tuples[Range@3, 2], o = Flatten @ b},
    Unitize[o].Abs[ p - p[[ Mod[o, 9, 1] ]] ] // Tr
  ]

Test:

all = Partition[#, 3] & /@ Permutations[0~Range~8];
r1 = manhattan /@ all; // AbsoluteTiming
r2 = md /@ all; // AbsoluteTiming
r1 === r2
{29.1845, Null}

{4.49513, Null}

True

Full Pre-calculation

In the code above I pre-calculated positions but not actual distances. Completing the idea by calculating a full table of distance pairs (d) makes the code an order of magnitude faster.

Module[{p, d},
  p = Tuples[Range@3, 2];
  d = Total[Abs[p\[Transpose] - # & /@ p]\[Transpose]];
  d[[9]] *= 0;
  d = RotateRight[d];

  md2 = Tr @ d[[ Flatten@# + 1 ]] &;
]

r3 = md2 /@ all; // AbsoluteTiming
r2 === r3
{0.471898, Null}

True

Count of misplaced tiles

A count of misplaced tiles, including the requirement to handle the zero, was requested.

A derivative of my md2 code, using a simple binary matrix in place of the distance table:

Module[{m},
  m = PadLeft[1 - IdentityMatrix[{8, 9}], {9, 9}];
  misp1 = Tr @ m[[ Flatten@# + 1 ]] &;
];

Test:

{{1, 6, 7}, {5, 2, 0}, {8, 4, 3}} // misp1

With your code as a function misp0:

r4 = misp0 /@ all; // AbsoluteTiming
r5 = misp1 /@ all; // AbsoluteTiming
r4 === r5
{40.0715, Null}

{0.471331, Null}

True

However after some consideration here is a different method unrelated to the first, with superior performance.

With[{t = -Range[9]},
  misp2 = Tr @ Unitize[Flatten[#] + t] - 1 &;
]

r6 = misp2 /@ all; // AbsoluteTiming

r4 === r6
{0.358665, Null}

True
$\endgroup$
  • $\begingroup$ Seeing your definition of md, I was perplexed, since that definition is very short besides that it is very fast, which indicates that it is well done, I will mention that it can be used with the type of matrices that I occupy, thank you for reminding me that I am still an apprentice in MMA because I would not have done it in that professional way as you did $\endgroup$ – bullitohappy Jul 8 '18 at 0:00
  • $\begingroup$ @bullitohappy Please see the update I just made. :-) $\endgroup$ – Mr.Wizard Jul 9 '18 at 1:52
  • $\begingroup$ ♦ In truth this is wonderful, the update you shared works excellent, thanks for the effort you have shown in this question I did, every time I am convinced that I must learn more about MMA, with the help of people like all of you who have proposed solutions to me fun to learn, thanks. Finally, giving a review of the website that I shared, it is pointed out that in the misplaced pieces function, zero should not be counted, so based on the suggestions that all have made, I did the following, I hope it is understandable what is pretend to achieve $\endgroup$ – bullitohappy Jul 9 '18 at 6:21
  • $\begingroup$ stf = {{1, 2, 3}, {4, 5, 6}, {7, 8, 0}} (goal state) b = {{1, 3, 5}, {7, 0, 2}, {8, 4, 6}}; (my board) fuera = Position[b, #, Infinity] & /@ Range[1, 8]; bcol = Position[stf, #, Infinity] & /@ Range[1, 8]; Count[bcol - fuera, {{x_, y_}} /; x != 0 [Or] y != 0] (Total of misplaced pieces) I do not know if you have another way of knowing how many pieces are out of place? $\endgroup$ – bullitohappy Jul 9 '18 at 6:23
  • $\begingroup$ @bullitohappy Please see my updates. $\endgroup$ – Mr.Wizard Jul 9 '18 at 17:37
3
$\begingroup$

Another way to count corresponding inequalities without needing to use For

perms = Partition[#, 3] & /@ Permutations[0~Range~8]; 
misplaced[board_List] := Count[
  Inner[Equal, Flatten[board], {1,2,3,4,5,6,7,8,0}, List],
  False];
misplaced /@ perms; // AbsoluteTiming

(* {2.83767, Null} *)

Another way to compute manhattan distance without For or If

manhattan[b_] := (
  bf = Flatten[b /. 0 -> 9] - 1; (* change representation *)
  Total[Map[
    Abs[Mod[bf[[# + 1]], 3] - Mod[#, 3]] + (* horizontal distance *)
    Abs[Quotient[bf[[# + 1]], 3] - Quotient[#, 3]] &, (* vertical distance *)
    {0, 1, 2, 3, 4, 5, 6, 7, 8}]]);
manhattan[{{8, 1, 3}, {4, 0, 2}, {7, 6, 5}}]

(* 12 *)

all = Partition[#, 3] & /@ Permutations[0~Range~8];
manhattan /@ all; // AbsoluteTiming

(* {31.5521, Null} *)

There must be even shorter ways of doing this.

$\endgroup$
  • $\begingroup$ An excellent option to avoid the use of For, thank you very much for your help, I do not know if you have any alternative for the manhattan function? $\endgroup$ – bullitohappy Jul 6 '18 at 22:43
  • $\begingroup$ @bullitohappy Please check my version of manhattan and see if it appears correct $\endgroup$ – Bill Jul 7 '18 at 4:18
  • $\begingroup$ "There must be even shorter ways of doing this." -- yes, see my answer for one of them. I use Tuples to essentially pre-calculate the distances. $\endgroup$ – Mr.Wizard Jul 7 '18 at 4:23
2
$\begingroup$

Two variations on hamming4:

hamming5 = Total[Unitize[Subtract[Flatten @ #, {1, 2, 3, 4, 5, 6, 7, 8, 0}]]] &;
hamming6 = Function[x, Total[Flatten @ Unitize[Subtract[x, 
  {{1, 2, 3}, {4, 5, 6}, {7, 8, 0}}]]], Listable];

r4 = hamming4 /@ perms; // AbsoluteTiming // First

0.165436

r5 = hamming5 /@ perms; // AbsoluteTiming // First

0.132352

r6 = hamming6 /@ perms; // AbsoluteTiming // First

0.102274

Equal[r4, r5, r6]

True

$\endgroup$
  • $\begingroup$ Very interesting then I will change the misplaced function, please see the edited version of this question, your help is very important $\endgroup$ – bullitohappy Jul 6 '18 at 23:40
2
$\begingroup$

One way to do your "misplaced" function is to use the Hamming Distance between the two boards. This essentially counts the number of places in which the two boards (called b1 and b2) differ.

b1 = {{0, 1, 3}, {4, 2, 5}, {7, 8, 6}};
b2 = {{1, 2, 3}, {4, 5, 6}, {7, 8, 0}};
HammingDistance[Flatten[b1], Flatten[b2]]
5

If you are after speed, I would try:

Total[Abs[Sign[Flatten[b1] - Flatten[b2]]]]
5

You appear to be using "Manhatten function" in a different sense than Mathematica's definition. Going to the web site you refer to, you can build a function to do this by changing the data structure a little. Instead of a matrix representation, (which is easy to view) translate it to a set of rules for the position of each element in the array. Let's define the initial and final states via the rules:

final = {1 -> {1, 1}, 2 -> {1, 2}, 3 -> {1, 3}, 4 -> {2, 1}, 
   5 -> {2, 2}, 6 -> {2, 3}, 7 -> {3, 1}, 8 -> {3, 2}, 0 -> {3, 3}};
initial = {8 -> {1, 1}, 1 -> {1, 2}, 3 -> {1, 3}, 4 -> {2, 1}, 
   0 -> {2, 2}, 2 -> {2, 3}, 7 -> {3, 1}, 6 -> {3, 2}, 5 -> {3, 3}};

si = Sort[initial]; sf = Sort[final];

Total[Abs[Flatten[si[[2 ;;, 2]] - sf[[2 ;;, 2]]]]]

The next line sorts them into order (so that 1 lines up with 1, 2 lines up with two, etc. The final line calculates the total distance between the two arrays. In this case, the answer is 10, in agreement with the example on the web site you linked to.

If you really want the input to be the matrix-form, you can convert this to the rule-form. For example,

mat = {{8, 1, 3}, {4, 0, 2}, {7, 6, 5}};
rules = ArrayRules[mat]
initial = Thread[rules[[All, 2]] -> rules[[All, 1]]]

gives the initial state as a set of rules.

$\endgroup$
  • $\begingroup$ please see the edited version of this question $\endgroup$ – bullitohappy Jul 6 '18 at 23:30
  • $\begingroup$ Excellent that you have taken your time to build the manhattan function based on the website that I shared, something I did not intend to do, plus you have designed it to work with the matrix format that I use, thanks for doing all this, I do not have more words to thank you $\endgroup$ – bullitohappy Jul 7 '18 at 23:48
1
$\begingroup$

The nested loop structure should be fine, though @bills's Abs solution should be fast. Comparing speeds: (last case inspired by @bills)

perms = Partition[#, 3] & /@ Permutations[0~Range~8];

hamming1 = Block[{cnt = 0},
    Do[If[#[[i, j]] != Mod[j + 3 (i - 1), 9], cnt++], {i, 3}, {j, 3}];
    cnt
  ] &;

hamming2 = HammingDistance[Flatten@#, {1, 2, 3, 4, 5, 6, 7, 8, 0}] &;

hamming3 = Count[
    MapThread[Equal, {#, {{1, 2, 3}, {4, 5, 6}, {7, 8, 0}}}, 2],
    False,
    {2}
  ] &;

hamming4 = Total[Abs[Sign[Flatten@# - {1, 2, 3, 4, 5, 6, 7, 8, 0}]]] &;

hamming1 /@ perms; // AbsoluteTiming
hamming2 /@ perms; // AbsoluteTiming
hamming3 /@ perms; // AbsoluteTiming
hamming4 /@ perms; // AbsoluteTiming

{0.302045, Null}

{0.85081, Null}

{2.41068, Null}

{0.13908, Null}

$\endgroup$
  • $\begingroup$ Thanks to your comment it has been clear to me that Bill's proposal should be used, this is a good start, thank you $\endgroup$ – bullitohappy Jul 6 '18 at 22:45

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.