CUFP
teamster_jr
After [liverpole] released his fantastic module [id://597268|Language::Logo] I immediately started thinking about what to do with it. Like many people I have fond memories of Logo as it was part of my first exposure to programming.<p>
Eventually I decided to continue my [id://252833|long] [id://301203|running] [id://542489|obsession] with mazes, and do something with that.<p>
<readmore>
MouseRace is a module designed to race virtual mice around a maze. It is invoked like this:
<h3>Race.pl</h3>
<code>
#!/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;
</code>
The new method takes the arguments shown:<br>
x,y are the number of boxes in the maze.<br>
no_draw will turn off graphical output.<br>
dump_arena and load_arena can either be 1, or a filename.<p>
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).
<p>
finally they need to be set off with the run_mousy_run call.<p><p>
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!):
<h3>MouseRace.pm</h3>
<code>
# 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) reached\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} } = $_ + $position;
# set up relative directions;
my $diff = abs( $mouse->{heading} - $direction->{heading} );
$diff =
!$diff ? "forward"
: $diff == 180 ? "backward"
: $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 20");
}
}
elsif ( $options->{relative}->{$next} ) {
my $dir_hash =
$self->{directions}
->{ $options->{relative}->{$next} - $mouse->{position} };
$mouse->{heading} = $dir_hash->{heading};
$mouse->{position} +=
$self->{directions}->{ $dir_hash->{name} }->{next};
if ( $mouse->{logo} ) {
$mouse->{logo}->cmd("sh $mouse->{heading};fd 20");
}
}
else {
print "ILLEGAL MOVE: $next; bad mouse ($mouse->{colour} 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;
</code>
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}).<br>
<h3>MouseRace/DFS.pm</h3>
<code>
# MouseRace/DFS.pm - the default mouse solver routine - using depth first 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;
</code>
<h3>MouseRace/Random.pm</h3>
<code>
# 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;
</code>
<h2>Writing your own solve() routines</h2>
I've supplied a random mouse, and a depth first search mouse. Here's how to write your own solver.<p>
Mice start in the top left (box 1) and are aiming for the bottom right (box <code>$self->{x} * ( $self->{y} + 1 ) ) - 1</code>).<br>
once they reach the end box the referee tells you they've either won or finished and in how many moves.<p>
Each turn the referee calls the solve routine with the following parameters:<br>
<code>
# $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 moves.
</code>
$options is formated like this:
<code>
{
'relative' => {
'left' => 165,
'backward' => 182
},
'absolute' => {
'north' => 165,
'east' => 182
},
'backtrack' => {
'182' => 'east',
'165' => 'north'
}
};
</code>
relative contains, unsurprisingly relative directions your mouse can go: left,right,forward,backward.<br>
absolute contains absolute directions: north,south,east and west (north is up).<br>
each of these hash keys will return the box you will end up in if you take that direction.<p>
there is also a backtrack key which contains a reverse mapping of available boxes to direction - this is useful for dfs backtracking.<br>
all you have to do is return one of the directions, either relative or absolute, and your mouse will trundle round the maze.<p>
A few ideas i had for different routines were:
<ul>
<li>pairs of mice that talk to each other - you can write a file with the information that they know (MARCO! POLO!).
<li>a tuneable mouse - change the random seed and rerun with the same maze till you find an optimum solution.
<li>"keep a wall on your right hand side" - guaranteed to solve the maze, slowly :)
</ul>
That's pretty much it.<p>
<h3>Still todo</h3>
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.<br>I'll try and get them working and update:<br>
<ul>
<li>accept a pure coderef as the solve param for the mice<br>
<li><strike>return mouse object.</strike><Br>the add_mouse now returns the $mouse object
<li>machine readable returns from run_mousy_run
<li><strike>return the minimum moves required to solve the maze.</strike><br>now done in update.
<li>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.
<li>probably loads of other things!
</ul>
the above would mean that you could do something like this:
<code>
while($mouse_code_not_optimised){
$arena->add_mouse(solve=>$code_ref);
$arena->run_mousy_run;
optimise_code($code_ref);
}
</code>
er, or something!
<p>
<small>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.</small><p>
</readmore>
Hope you enjoy it.<p>
Alex