MouseRace is a module designed to race virtual mice around a maze. It is invoked like this:

Race.pl

#!/usr/bin/perl
# race.pl - example script for MouseRace.pm

use MouseRace;
use strict; use warnings;

my $arena = new MouseRace(
    x          => 15,
    y          => 15,
    no_draw    => 0,
    dump_arena => 0,
    load_arena => 0
);

$arena->add_mouse( colour => "blue" );

# works with incorrect spelling as well :)
$arena->add_mouse( color => "red", solver => 'MouseRace::Random::solve
+' );
$arena->add_mouse( color => "green" );

$arena->run_mousy_run;
[download]

The new method takes the arguments shown:
x,y are the number of boxes in the maze.
no_draw will turn off graphical output.
dump_arena and load_arena can either be 1, or a filename.

Up to 3 mice are added with $arena->add_mouse which takes a colour (or color if you prefer :) ) and an optional "solver" parameter. This is the name of a subroutine which will be used by the mouse to solve the maze, if left out it will default to MouseRace::DFS::solve (this will be discussed later).

finally they need to be set off with the run_mousy_run call.

and here's the modules (please excuse my code - it started as an obfu and i haven't really had time to tidy it up!):

MouseRace.pm

# MouseRace.pm - a mouse racing module.
package MouseRace;
use strict;
use warnings;

use Language::Logo;
use Data::Dumper;

sub new {
    my %args = ( x => 15, y => 15 );

    my ($class) = shift @_;
    (%args) = ( %args, @_ );

    my $self = bless \%args, $class;
    my $backup_file=$self->{load_arena}=~/\D/?$self->{load_arena}:"ref
+.backup";

    if ( $self->{load_arena} && -e $backup_file) {
        $self = do $backup_file;
         print "arena loaded\n";
    }
    else {
        $self->{num_x}  = $self->{x} + 1;
        $self->{width}  = 20 * $self->{num_x};
        $self->{height} = 20 + 20 * $self->{y};

        $self->{referee} = { maze => delete $self->{maze} };

        $self->make_maze;
    }

    if ( $self->{dump_arena} &&! $self->{load_arena}) {
    my $backup_file=$self->{dump_arena}=~/\D/?$self->{dump_arena}:"ref
+.backup";
        delete $self->{dump_arena};
        open( FH, ">$backup_file" );
        print FH Data::Dumper->Dump( [$self] );
        close FH;
        die 'arena backed up' . $/;
    }


    print "Optimum: " . $self->{referee}->{optimum} . $/ x 2;

    @{ $self->{mouse_positions} } = ( 20, 16, 24 );

    $self->{directions} = {
        1               => { name => "east",  heading => "90" },
        -1              => { name => "west",  heading => "270" },
        $self->{num_x}  => { name => "south", heading => "180" },
        -$self->{num_x} => { name => "north", heading => "0" },
    };

    for ( keys %{ $self->{directions} } ) {
        $self->{directions}->{ $self->{directions}->{$_}->{name} } =
          { heading => $self->{directions}->{$_}->{heading}, next => $
+_ };
    }

    $self->draw_maze unless $self->{no_draw};

    return $self;

}
sub make_maze {
    my $self = shift;
    my $ref  = $self->{referee};

    @{ $ref->{maze} } =
      ( ( 31, (15) x $self->{x} ) x $self->{y}, (31) x $self->{num_x} 
+);

    $ref->{position} = 0;

    while ( !$ref->{finish} ) {

        $ref->{maze}[ $ref->{position} ] |= 16;
        @{ $ref->{choices} } =
          grep /.$/ & !( $ref->{maze}[ $ref->{position} + $` ] & 16 ),
+ -18, 11,
          $self->{num_x} . 4, -$self->{num_x} . 2;

        if ( scalar @{ $ref->{choices} } ) {

            $ref->{choices}[ rand @{ $ref->{choices} } ] =~ /.$/;

            push @{ $ref->{visited} }, $ref->{position};

            $ref->{maze}[ $ref->{position} ] &= ~( 8 / $& );
            $ref->{position} += $`;
            $ref->{maze}[ $ref->{position} ] &= 15 - $&;

            if ( $ref->{position} ==
                ( ( $self->{x} * ( $self->{y} + 1 ) ) - 1 ) )
            {
                $ref->{optimum}=(scalar( @{ $ref->{visited} } ) -1 )

            }



            if ( ++$ref->{total_visited} == ( $self->{x} * $self->{y} 
+) ) {
                map { $_ &= 15 } @{ $ref->{maze} };
                $ref->{maze}[0] = 31;
                $ref->{position} = $ref->{finish} = 1;
            }

        }
        else {
            $ref->{position} = pop @{ $ref->{visited} };
        }
    }

}

sub draw_maze {
    my $self = shift;

    $self->{referee}->{logo} = new Logo(
        update => 1,
        width  => $self->{width},
        height => $self->{height}
    );

    $self->{referee}->{logo}->cmd(
        "ht;xy 10 10;pd"
          . (
            (
                    ";rt 90;fd "
                  . ( $self->{x} * 20 )
                  . ";rt 90;fd "
                  . $self->{y} * 20
            ) x 2
          )
          . ";bk 20;rt 90;"
    );
    $self->{referee}->{logo}->cmd(
        $_ % $self->{num_x}
        ? ( $self->{referee}->{maze}[$_] & 2 ? "pd" : "pu" )
          . ";fd 20;lt 90;"
          . ( $self->{referee}->{maze}[$_] & 8 ? "pd" : "pu" )
          . ";fd 20;bk 20;rt 90;"
        : "pu;bk " . ( $self->{x} * 20 ) . ";rt 90; fd 20;lt 90;"
    ) for 1 .. ( $self->{num_x} * $self->{y} ) - 1;

}

sub add_mouse {
    my %args = ( solver => 'MouseRace::DFS::solve', data => {} );
    my $self = shift @_;
    (%args) = ( %args, @_ );
    my $mouse = \%args;
    $mouse->{colour} ||= $mouse->{color};

    if ( $#{ $self->{mice} } >= 2 ) {
        print "EMOUSE : $mouse->{colour} dropped - mice limit (3) reac
+hed\n";
    }
    else {
        my $solver_package = $mouse->{solver};
        if ( $solver_package =~ s#\:\:[^:]+$## ) {
            eval("require $solver_package") || die $@
              if $mouse->{solver} =~ /::/;
        }
        else {
            $mouse->{solver} = "main::$mouse->{solver}";
        }

        $mouse->{logo} = new Logo(
            update => 50,
            width  => $self->{width},
            height => $self->{height}
        ) unless $self->{no_draw};

        # place mouse
        my $mp = shift @{ $self->{mouse_positions} };
        $mouse->{logo}
          ->command( "color " . $mouse->{colour} . ";xy $mp $mp;rt 90;
+ps 2;pd" )
          if $mouse->{logo};

        $mouse->{position} = 1;
        $mouse->{heading}  = 90;

        push @{ $self->{mice} }, $mouse;
        return $mouse;
    }
}
sub run_mousy_run {
    my $self = shift;
    my $ref  = $self->{referee};
    $self->{finished} = 0;
    while ( $self->{finished} < scalar( @{ $self->{mice} } ) ) {
        $self->{counter}++;
        for my $mouse ( @{ $self->{mice} } ) {
            next if $mouse->{finished};
            my $position = $mouse->{position};

            my $options;
            for (
                my @a =
                grep /.$/ & !( $ref->{maze}[ $position + $` ] & ( $& +
+ 16 ) ),
                -18, 11, $self->{num_x} . 4, -$self->{num_x} . 2
              )
            {
                chop;

                my $direction = $self->{directions}->{$_};
                $options->{absolute}->{ $direction->{name} } = $_ + $p
+osition;

                # set up relative directions;

                my $diff = abs( $mouse->{heading} - $direction->{headi
+ng} );
                $diff =
                    !$diff                                    ? "forwa
+rd"
                  : $diff == 180                              ? "backw
+ard"
                  : $mouse->{heading} > $direction->{heading} ? "left"
                  :                                             "right
+";
                $options->{relative}->{$diff} = ( $_ + $position ) || 
+1;
                $options->{backtrack}->{ $_ + $position } = $direction
+->{name};
            }

            my $next;
            eval(   '$next='
                  . $mouse->{solver}
                  . '($mouse->{data},$position,$options)' )
              || print $@
              unless $mouse->{finished};
            if ($next) {

                if ( $options->{absolute}->{$next} ) {

                    #print "ab: $next $mouse->{position}\n";
                    $mouse->{heading} = $self->{directions}->{$next}->
+{heading};
                    $mouse->{position} += $self->{directions}->{$next}
+->{next};
                    if ( $mouse->{logo} ) {
                        $mouse->{logo}->cmd("sh $mouse->{heading};fd 2
+0");
                    }
                }
                elsif ( $options->{relative}->{$next} ) {

                    my $dir_hash =
                      $self->{directions}
                      ->{ $options->{relative}->{$next} - $mouse->{pos
+ition} };
                    $mouse->{heading} = $dir_hash->{heading};
                    $mouse->{position} +=
                      $self->{directions}->{ $dir_hash->{name} }->{nex
+t};
                    if ( $mouse->{logo} ) {
                        $mouse->{logo}->cmd("sh $mouse->{heading};fd 2
+0");
                    }

                }
                else {
                    print "ILLEGAL MOVE: $next; bad mouse ($mouse->{co
+lour} at box $mouse->{position})\n";
                }
                if ( $mouse->{position} ==
                    ( $self->{x} * ( $self->{y} + 1 ) ) - 1 )
                {
                    print "$mouse->{colour} "
                      . ( !$self->{finished}++ ? "wins" : "finishes" )
                      . " in $self->{counter} moves\n";
                    $mouse->{finished}++;

                    #$mouse->{logo}->disconnect;

                }

            }
        }
        my $z;
        select $z, $z, $z, 0.1 unless $self->{no_draw};
    }

    $self->{referee}->{logo}->disconnect("finished") unless $self->{no
+_draw};
}

1;
[download]

And the solving packages (you don't need these in a seperate package - it will check whether the subroutine is in a package, and include the package if necessary or call main::$mouse->{solver}).

MouseRace/DFS.pm

# MouseRace/DFS.pm - the default mouse solver routine - using depth fi
+rst search
package MouseRace::DFS;

sub solve {
    my ( $self, $current, $choices ) = @_;
    $self->{visited}->{$current} = 1;

    my @options =
      grep { !$self->{visited}->{ $choices->{absolute}->{$_} } }
      keys %{ $choices->{absolute} };
    if (@options) {
        push @{ $self->{path} }, $current;
        $choice = $options[ rand @options ];
    }
    else {
        my $back = pop @{ $self->{path} };
        $choice = $choices->{backtrack}->{$back};
    }
    return $choice;
}

1;
[download]

MouseRace/Random.pm

# MouseRace/Random.pm - a random mouse solver
package MouseRace::Random;

sub solve {
    my ( $self, $current, $choices ) = @_;
    @choices = grep { !/backward/ } keys %{ $choices->{relative} };
    return $choices[ rand @choices ] || "backward";
}

1;
[download]

Writing your own solve() routines

I've supplied a random mouse, and a depth first search mouse. Here's how to write your own solver.

Mice start in the top left (box 1) and are aiming for the bottom right (box $self->{x} * ( $self->{y} + 1 ) ) - 1).
once they reach the end box the referee tells you they've either won or finished and in how many moves.

Each turn the referee calls the solve routine with the following parameters:

# $data -> a data hash for use as a persistent scratch pad
# $current -> your current position (box #)
# $options -> these is a data structure containing your available move
+s.
[download]

$options is formated like this:

{
          'relative' => {
                          'left' => 165,
                          'backward' => 182
                        },
          'absolute' => {
                          'north' => 165,
                          'east' => 182
                        },
          'backtrack' => {
                           '182' => 'east',
                           '165' => 'north'
                         }
        };
[download]

relative contains, unsurprisingly relative directions your mouse can go: left,right,forward,backward.
absolute contains absolute directions: north,south,east and west (north is up).
each of these hash keys will return the box you will end up in if you take that direction.

there is also a backtrack key which contains a reverse mapping of available boxes to direction - this is useful for dfs backtracking.
all you have to do is return one of the directions, either relative or absolute, and your mouse will trundle round the maze.

A few ideas i had for different routines were:

• pairs of mice that talk to each other - you can write a file with the information that they know (MARCO! POLO!).
• a tuneable mouse - change the random seed and rerun with the same maze till you find an optimum solution.
• "keep a wall on your right hand side" - guaranteed to solve the maze, slowly :)

That's pretty much it.

Still todo

Since posting this a few things occured to me that would be helpful. Most of them are so you could use this as a training framework for genetic algorithms.
I'll try and get them working and update:

• accept a pure coderef as the solve param for the mice
  
• return mouse object.
  the add_mouse now returns the $mouse object
• machine readable returns from run_mousy_run
• return the minimum moves required to solve the maze.
  now done in update.
• pass in size of maze possibly - at the moment the mouse has no idea of where it's aiming for, perhaps give this as an option.
• probably loads of other things!

the above would mean that you could do something like this:

while($mouse_code_not_optimised){
$arena->add_mouse(solve=>$code_ref);
$arena->run_mousy_run;
optimise_code($code_ref);
}
[download]

er, or something!

Incidentally one of the good things about writing this, was i found a bug in my generic maze solving code that meant that it didn't work in 5.8.8 - i think the precendence was changed, so $a&=~8/$j is now not the same as $a&=~(8/$j), which is what i meant, so i fixed all my maze code scattered around.