Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

Racing Mice with Language::Logo - MouseRace.pm

by teamster_jr (Curate)
on Mar 06, 2007 at 11:36 UTC ( #603380=CUFP: print w/ replies, xml ) Need Help??

After liverpole released his fantastic module 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.

Eventually I decided to continue my long running obsession with mazes, and do something with that.

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;
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;
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;

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;

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.
$options is formated like this:
{ 'relative' => { 'left' => 165, 'backward' => 182 }, 'absolute' => { 'north' => 165, 'east' => 182 }, 'backtrack' => { '182' => 'east', '165' => 'north' } };
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); }
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.

Hope you enjoy it.

Alex

Comment on Racing Mice with Language::Logo - MouseRace.pm
Select or Download Code
Re: Racing Mice with Language::Logo - MouseRace.pm
by liverpole (Monsignor) on Mar 06, 2007 at 13:15 UTC
    ++teamster_jr,

    It's a really cool idea, and the presentation is impeccable.  A specific example of how nicely written this was -- the idea of having each "mouse" offset its path by a slight amount, so that it doesn't obscure the other mice.

    teamster_jr was kind enough to send me a preview copy of this, which I ran yesterday.  My wife and kids all enjoyed watching it, and my 7-year-old exclaimed with innocent incredulity -- "so the mice actually *solve* the maze?!"  :-)

    I'm also honored that my module would be used for something so impressive.   A terrific job!


    s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/
Re: Racing Mice with Language::Logo - MouseRace.pm
by zentara (Archbishop) on Mar 06, 2007 at 13:52 UTC
    It's fascinating to watch. It reminds me of my Perl programming techniques... try this...try that...repeat until sucess. :-)

    I'm not really a human, but I play one on earth. Cogito ergo sum a bum
Re: Racing Mice with Language::Logo - MouseRace.pm
by w-ber (Hermit) on Mar 06, 2007 at 13:54 UTC

    Just brilliant!

    --
    print "Just Another Perl Adept\n";

Re: Racing Mice with Language::Logo - MouseRace.pm
by wulvrine (Friar) on Mar 06, 2007 at 14:10 UTC
    That is GREAT!! I love it ++!!!
    Heck of a job! I also love the concept of writing your own solve solution.
    Too bad I can only upvote once :(

    s&&VALKYRIE &&& print $_^q|!4 =+;' *|
Re: Racing Mice with Language::Logo - MouseRace.pm
by chanio (Priest) on Mar 08, 2007 at 04:10 UTC
Re: Racing Mice with Language::Logo - MouseRace.pm
by Random_Walk (Parson) on Apr 03, 2007 at 08:46 UTC

    Not sure why but I get an error after the mice have made a few turns. (Running on Windows 2000. The maze draws and the mouse start out OK)

    C:\Documents and Settings\RandomW\workspace\Perl_Playground>perl Race. +pl Optimum: 106 Attempt to free non-existent shared string '_ErrorInfo_', Perl interpr +eter: 0x1e16364 at C:/Perl/site/lib/Tk.pm line 411, <GEN4> line 30. Free to wrong pool 1b63df0 not 58743b0 at C:/Perl/site/lib/Tk.pm line +411, <GEN4> line 30. Free to wrong pool 58743b0 not 1b63df0 at C:/Perl/site/lib/Tk.pm line +411, <GEN0> line 1659. Free to wrong pool 59ba1d0 not 58743b0 at C:/Perl/site/lib/Tk.pm line +411, <GEN1> line 6. Attempt to free non-existent shared string '_ErrorInfo_', Perl interpr +eter: 0x5b7c7ec at C:/Perl/site/lib/Tk.pm line 411, <GEN2> line 6. Free to wrong pool 5b79c38 not 59ba1d0 at C:/Perl/site/lib/Tk.pm line +411, <GEN2> line 6.
    An error box pops up too, the good old 'an instrution at blah blah referenced memory at 0x000000000. the memory could not be written', Click OK to terminate (I have to click this box four times (same addresses each time) beore it clears.

    My Logo looks OK, at least the spiral and random box programs run fine. Any suggestions ?

    Cheers,
    R.

    Pereant, qui ante nos nostra dixerunt!
      I am using Perl with Tk / kill a thread with a signal / thread dies / same dumb error message

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: CUFP [id://603380]
Approved by Corion
Front-paged by McDarren
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others chilling in the Monastery: (2)
As of 2014-09-20 02:10 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    How do you remember the number of days in each month?











    Results (151 votes), past polls