Mouse Heuristic

[pope]

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.

[Masem]

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 - [e-mail] || "You've left the lens cap of your mind on again, Pinky" - The Brain

[pope]

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.

[Corion]

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).

[Chmrr]

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'

[pope]

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.
Enjoy!

#!/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;

[hiroki]

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.

http://www.gamasutra.com/features/19990212/sm_01.htm

hope this helps