Beefy Boxes and Bandwidth Generously Provided by pair Networks
XP is just a number

Mouse Heuristic

by pope (Friar)
on Jun 12, 2001 at 14:59 UTC ( #87766=perlquestion: print w/replies, xml ) Need Help??

pope has asked for the wisdom of the Perl Monks concerning the following question:

Hi, I've just played with the famous mouse and cheese problem, the Perl Way, of course. The code is shown below.
#!/usr/bin/perl -w use strict; use vars qw($opt_h); use Getopt::Std; getopts('h'); my @dir = ([0,-1],[1,0],[0,1],[-1,0]); my (@map, @mark, @dist); my (%mouse, %cheese); my $poss = 1; # initialize map while(<>) { chomp; push @map, [map { tr/#// } split //]; if (/M/) { $mouse{x} = length($`); $mouse{y} = $. - 1; } if (/C/) { $cheese{x} = length($`); $cheese{y} = $. - 1; } } # init dist foreach my $row (0..$#map) { $dist[$row] = [map {($_ - $cheese{x})**2 + ($row - $cheese{y})**2} + 0..$#{$map[$row]}]; } sub find_cheese { my ($x, $y) = @_; return if not $poss; $mark[$x][$y] = 1; print "X = $x, Y = $y\n"; $poss = 0 if ($x == $cheese{x} && $y == $cheese{y}); for ($opt_h? sort { $dist[$y + $a->[1]][$x + $a->[0]] <=> $dist[$y + $b->[1 +]][$x + $b->[0]] } @dir : @dir) { !$map[$y + $_->[1]][$x + $_->[0]] && !$mark[$x + $_->[0]][$y + $_->[1]] && find_cheese($x + $_->[0], $y + $_->[1]); } } find_cheese(@mouse{'x','y'}); print "Cheese found!!\n" if not $poss;
That needs a map file which represents the maze, and the positions of the mouse and the cheese. A sample map file could be like this:
# # # # # #     # #     #
# #       # ##### # # # #
# #######   #     # # # #
#           ### #   # # #
######### #     # # # # #
#C        # # # # # # #M#
The mouse is represented by M, and the cheese by C.

The script's output is the coordinates of route taken by the mouse. For the sake of convenience, I've also written a script which takes the output and displays a simple text-mode animation, using Term::ANSIScreen:

#!/usr/bin/perl -w use strict; use vars qw($opt_m); use Getopt::Std; use Term::ANSIScreen qw(:cursor :screen :color); $|++, cls; getopts('m:'); die "Please specify map file" unless $opt_m; { local @ARGV = $opt_m; locate; while(<>) { print } } while(<>) { if (/X = (\d+), Y = (\d+)/) { locate($2 + 1, $1 + 1); print colored(".", 'bold yellow'); select(undef, undef, undef, 0.25); } }
The heuristic I use to help the mouse is the distance from the cheese. But as we notice the result, this is not quite satisfactory. Therefore I'm looking for a better heuristic, which can guide the mouse to refuse taking misleading route, and to refuse searching(!) if the cheese is at an unreachable place.

Replies are listed 'Best First'.
Re: Mouse Heuristic
by Masem (Monsignor) on Jun 12, 2001 at 15:17 UTC
    What you need to do if you want to do it this way is to convert the 'maze' into a graph (the comp.sci. version). As to not force minimization of this graph, simply construct it by looking at each open space on the map, and creating graph connections between that space and open spaces, using some id strict like "5,6" to represent the X=5, Y=6 space.

    Then you simply use the shortest graph distance algorithm from the node where the mouse is to where the node where the cheese is. This will not only find you the shortest route (and thus avoid dead-ends), but will also determine if the cheese is unreachable.

    Note however that this sort of 'violates' the spirit of the problem in that you've suddenly given the mouse full understanding of the maze. A somewhat better solution in the sense of keeping the mouse sufficiently clueless is to have it be able to backtrack to the last decision point if it reaches a dead end, and to select a new route from that point. If the mouse reaches it's starting point and has exhausted all paths from it, it should conclude that the cheese is unreachable (but again, this method will search the entire maze, so it will have lots of dead ends).

    Dr. Michael K. Neylon - || "You've left the lens cap of your mind on again, Pinky" - The Brain
      And experts call this "cheating" :-)
      You're right that such strategy violates the problem spirit, and absolutely that's not the solution I'm expecting.

      Had I chosen such strategy, then my good old shortest path finder would solve it nicely.

Re: Mouse Heuristic
by Corion (Pope) on Jun 12, 2001 at 15:26 UTC

    If your maze is a maze without islands (that is, walls which are not connected to any wall surrounding the maze) and each corridor is at most one cell wide, there is a really nice way to reduce the maze to the path to the cheese, if such a path exists :

    • Look at the maze as an array of cells.
    • Every cell that is not a wall is considered alive.
    • Every cell that is a wall is considered dead.
    • A cell that has three dead neighbours dies as well.
    • A cell that has none,one or two dead neighbours lives.
    • Stop when in one turn no cell died.

    When this algorithm stops, you end up either with the path from the mouse to the cheese, or with an enclosed mouse (or cheese).

Re: Mouse Heuristic
by Chmrr (Vicar) on Jun 12, 2001 at 19:16 UTC

    The easiest way to do this is to use a reverse flood fill algorithm. Essentially, fill in the cheese square with distance 0. Fill in all adjecent squares with 1, ignoring squares that are already filled. Repeat with the squares you just filled in, and so on. Here's some code:

    my @dist; &flood($cheese{x},$cheese{y},0); die "No route to cheese!" unless defined $dist[$mouse{x}][$mouse{y}]; sub flood { my ($x,$y,$dist) = @_; return if defined $dist[$x][$y] and $dist[$x][$y] < $dist; $dist[$x][$y] = $dist++; flood($x-1,$y,$dist) unless $map[$x-1][$y]; flood($x+1,$y,$dist) unless $map[$x+1][$y]; flood($x,$y-1,$dist) unless $map[$x][$y-1]; flood($x,$y+1,$dist) unless $map[$x][$y+1]; }

    perl -e 'print "I love $^X$\"$]!$/"#$&V"+@( NO CARRIER'

      Perfect, Chmrr! Eventually my mouse has learnt Something from you! :-)
      Took your snippet and modified it slightly to work with my code, now we have a smart mouse.

      Two options are now made available:
      -d for heuristic by distance, and -s for heuristic by smell, i.e. the reverse flood fill algorithm.

      #!/usr/bin/perl -w use strict; use vars qw($opt_d $opt_s); use Getopt::Std; getopts('ds'); my @dir = ([0,-1],[1,0],[0,1],[-1,0]); my (@map, @mark, @dist); my (%mouse, %cheese); my $poss = 1; # initialize map while(<>) { chomp; push @map, [map { tr/#// } split //]; if (/M/) { $mouse{x} = length($`); $mouse{y} = $. - 1; } if (/C/) { $cheese{x} = length($`); $cheese{y} = $. - 1; } } # init smell or distances if ($opt_s) { flood($cheese{y}, $cheese{x}, 0); die "No route to cheese!" unless defined $dist[$mouse{y}][$mouse{x +}]; } else { foreach my $row (0..$#map) { $dist[$row] = [map {($_ - $cheese{x})**2 + ($row - $cheese{y}) +**2} 0..$#{$map[$row]}]; } } sub flood { my ($y, $x, $dist) = @_; return if defined $dist[$y][$x] and $dist[$y][$x] < $dist; $dist[$y][$x] = $dist++; for (@dir) { flood($y + $_->[1], $x + $_->[0], $dist) unless $map[$y + $_-> +[1]][$x + $_->[0]]; } } sub find_cheese { my ($x, $y) = @_; return if not $poss; $mark[$x][$y] = 1; print "X = $x, Y = $y\n"; $poss = 0 if ($x == $cheese{x} && $y == $cheese{y}); for (!$opt_d && !$opt_s ? @dir : sort { $dist[$y + $a->[1]][$x + $a->[0]] <=> $dist[$y + $b->[1 +]][$x + $b->[0]] } ($opt_s ? grep /./, map { defined $dist[$y + $_->[1]] && defined $dist[$y + $_->[1]][$x ++ $_->[0]] ? $_ : '' } @dir : @dir)) { !$map[$y + $_->[1]][$x + $_->[0]] && !$mark[$x + $_->[0]][$y + $_->[1]] && find_cheese($x + $_->[0], $y + $_->[1]); } } find_cheese(@mouse{'x','y'}); print "Cheese found!!\n" if not $poss;
Re: Mouse Heuristic
by hiroki (Novice) on Jun 13, 2001 at 01:38 UTC

    a while ago, i tried tackling this problem as well. it was fun. i did a bit of research on the subject and found this article to be very helpful. it also links to a program that demonstrates the different path algorithms.

    hope this helps

Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: perlquestion [id://87766]
Approved by root
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others chilling in the Monastery: (3)
As of 2020-01-19 01:37 GMT
Find Nodes?
    Voting Booth?