in reply to Puzzle solver (rush hour)

Here's a program that finds a shortest solution. To make things simpler, I only consider moves that slide a piece 1 unit (so sliding a piece two units to the right counts as 2 moves). To consider multi-unit slides as a single move, just change how $moves is created in the setup phase.
#!/usr/bin/perl use 5.010; use strict; use warnings; my %C; # Cache of seen positions. my @Q; # Queue of position to work on. my $start = [[[3, 1], [3, 2]], [[3, 4], [4, 4], [5, 4]], [[2, 5], [3, 5]], [[4, 5], [5, 5], [6, 5]], [[1, 3], [1, 4], [1, 5]], [[4, 6], [5, 6]]]; $start = [[[3, 1], [3, 2]], # A [[1, 1], [1, 2], [1, 3]], # B [[1, 5], [1, 6]], # C [[2, 3], [3, 3]], # D [[2, 4], [2, 5]], # E [[2, 6], [3, 6]], # F [[4, 6], [5, 6], [6, 6]], # G [[4, 1], [5, 1]], # H [[6, 1], [6, 2], [6, 3]], # I [[5, 2], [5, 3]], # J [[5, 4], [6, 4]], # K [[4, 5], [5, 5]], # L [[4, 3], [4, 4]], # M ] if 1; my $moves; foreach my $piece (@$start) { if ($$piece[0][0] == $$piece[1][0]) { push @$moves, [[0, 1], [0, -1]] } else { push @$moves, [[1, 0], [-1, 0]] } } # # Uses the fact board size < 10. # sub flatten ($) {join "", map {map {@$_} @$_} @{$_[0]}} # # Return 1 if a position is valid. No pieces outside the board, # no overlapping pieces. Only key piece allowed in exit. # sub valid ($) { my %seen; my $pos = shift; foreach my $piece (@$pos) { foreach my $part (@$piece) { my ($x, $y) = @$part; return 0 if $x < 1 || $y < 1 || $x > 6; return 0 if $y > 6 && $x != 3; # Exit. return 0 if $seen{$x, $y}++; } } return 1; } # # Return 1 if the position is solved. # sub solved ($) {${$_[0]}[0][1][1] == 7} # # Return a copy of the position # sub copy ($) {[map {[map {[@$_]} @$_]} @{$_[0]}]} sub move ($$$) { my ($pos, $piece, $move) = @_; my $copy = copy $pos; foreach my $cell (@{$$copy[$piece]}) { $$cell[$_] += $$move[$_] for 0, 1; } $copy; } sub move2text ($) { my $move = shift; if ($$move[0] == 0 && $$move[1] == 1) {return "right"} if ($$move[0] == 0 && $$move[1] == -1) {return "left"} if ($$move[0] == 1 && $$move[1] == 0) {return "down"} if ($$move[0] == -1 && $$move[1] == 0) {return "up"} die; } sub print_solution { my $s = length scalar @_; for (my $i = 0; $i < @_; $i++) { my ($piece, $direction) = @{$_[$i]}; printf "%${s}d. %s -> %s\n", $i + 1, chr(ord('A') + $piece), $ +direction; } say "Total number of examined positions: ", scalar keys %C; } die "Not a valid starting position" unless valid $start; $C{flatten $start}++; push @Q, [$start]; while (@Q) { my ($P, @moves) = @{shift @Q}; # # Calculate all moves. Filter out those that are invalid. # foreach my $piece (0 .. $#{$moves}) { foreach my $m (0, 1) { my $move = $$moves[$piece][$m]; my $P_prime = move $P, $piece, $move; next unless valid $P_prime; # Not a valid move. next if $C{flatten $P_prime}++; # Seen position. if (solved $P_prime) { print_solution @moves, [$piece, move2text $move]; exit 0; } push @Q, [$P_prime, @moves, [$piece, move2text $move]]; } } } say "No solution"; exit 1; __END__ 1. C -> left 2. F -> up 3. G -> up 4. L -> up 5. M -> left 6. K -> up 7. I -> right 8. H -> down 9. I -> right 10. I -> right 11. K -> up 12. J -> right 13. J -> right 14. M -> left 15. D -> down 16. D -> down 17. A -> right 18. D -> down 19. M -> right 20. H -> up 21. H -> up 22. H -> up 23. M -> left 24. D -> up 25. I -> left 26. G -> down 27. F -> down 28. C -> right 29. B -> right 30. H -> up 31. A -> left 32. D -> up 33. J -> left 34. J -> left 35. J -> left 36. D -> down 37. A -> right 38. H -> down 39. B -> left 40. C -> left 41. F -> up 42. K -> down 43. A -> right 44. L -> down 45. A -> right 46. A -> right 47. A -> right Total number of examined positions: 5031
I don't have a board handy, so I haven't actually checked whether the solution is valid.

Replies are listed 'Best First'.
Re^2: Puzzle solver (rush hour)
by GrandFather (Saint) on Sep 01, 2010 at 02:45 UTC

    But you have Perl handy so you could:

    use strict; use warnings; my @puzzle = ( [3, 1, 2], [1, 1, 3], [1, 5, 2], [2, 3, -2], [2, 4, 2], [2, 6, - +2], [4, 6, -3], [4, 1, 2], [6, 1, 3], [5, 2, 2], [5, 4, -2], [4, 5, - +2], [4, 3, 2], ); while (<DATA>) { next if !/(\d+)\.\ (\w) -> (\w+)/; my ($step, $block, $move) = ($1, $2, $3); my $blockIndex = ord($block) - ord('A'); print "Before step $step $block $move:\n"; dumpPuzzle(@puzzle); my $piece = $puzzle[$blockIndex]; if ($move eq 'up') { --$piece->[0]; } elsif ($move eq 'down') { ++$piece->[0]; } elsif ($move eq 'left') { --$piece->[1]; } else { ++$piece->[1]; } } print "Final state:\n"; dumpPuzzle(@puzzle); sub dumpPuzzle { my (@puzzle) = @_; my @rows = map {'.' x 6} 1 .. 6; for my $pieceIdx (0 .. $#puzzle) { my ($y, $x, $len) = @{$puzzle[$pieceIdx]}; if ($len < 0) { $len = -$len; substr $rows[$_ - 1], $x - 1, 1, chr($pieceIdx + ord('A')) for $y .. $y + $len - 1; } else { substr $rows[$y - 1], $x - 1, $len, chr($pieceIdx + ord('A')) x $len; } } print join "\n", @rows, ''; } __END__ 1. C -> left 2. F -> up 3. G -> up 4. L -> up 5. M -> left 6. K -> up 7. I -> right 8. H -> down 9. I -> right 10. I -> right 11. K -> up 12. J -> right 13. J -> right 14. M -> left 15. D -> down 16. D -> down 17. A -> right 18. D -> down 19. M -> right 20. H -> up 21. H -> up 22. H -> up 23. M -> left 24. D -> up 25. I -> left 26. G -> down 27. F -> down 28. C -> right 29. B -> right 30. H -> up 31. A -> left 32. D -> up 33. J -> left 34. J -> left 35. J -> left 36. D -> down 37. A -> right 38. H -> down 39. B -> left 40. C -> left 41. F -> up 42. K -> down 43. A -> right 44. L -> down 45. A -> right 46. A -> right 47. A -> right

    Prints (in part):

    Before step 1 C left: BBB.CC ..DEEF AAD..F HHMMLG .JJKLG IIIK.G Before step 2 F up: BBBCC. ..DEEF AAD..F HHMMLG .JJKLG IIIK.G Before step 3 G up: BBBCCF ..DEEF AAD... HHMMLG .JJKLG IIIK.G . . . Before step 47 A right: BBBCCF HH.EEF ....AA MMDKLG JJDKLG ..IIIG Final state: BBBCCF HH.EEF .....AA MMDKLG JJDKLG ..IIIG

    Note that I've changed the puzzle coding to use a top left corner and size/orientation array for each piece and the board size is hard wired at 8.

    True laziness is hard work