Now bloated to a grand 428 lines, it also comes with 4 food types (stationary, random jitter, random wander, and wander+evade), and 6 levels (though only 4 have different walls). Please feel free to make up new levels and send them in, currently i can't manage to get to level 6 and live more than a few seconds, I keep chasing the bastards right into walls.
Also added some iffy features and fixed the speed issue hopefully. The iffy feature is letting each level start you at a specific spot, this can be quite disconerting the first 20 times it happens. Ideas, improvments, levels, and requests to stop posting these new versions all welcome! ;)
#!/usr/bin/perl
use strict;
use Tk;
use Data::Dumper;
use Time::HiRes qw ( time);
my $mw = MainWindow->new(-title=>"Super Nibbles!");
my ($score, $start, $speed, $last_time, $dead);
$dead = 1;
my $menu_bar = $mw ->Canvas()->pack(-side => 'top', -fill => '
+both');
my $score_board = $menu_bar->Label() ->pack(-side=>'right');
$menu_bar->Button(-text => 'Start', -command => sub {restart()} )->pac
+k(-side=>'left');
my $board = $mw->Canvas(-width => 600, -height => 400)->pack();
my $status = $mw->Label(-text=> "Click 'Start' To Being" )->pack(-side
+=>'bottom');
$mw->bind("<Left>" , sub { set_direction(0) });
$mw->bind("<Up>" , sub { set_direction(1) });
$mw->bind("<Right>", sub { set_direction(2) });
$mw->bind("<Down>" , sub { set_direction(3) });
# enable mouse control.
my ($skip, $pressed, $last_x,$last_y) = 0;
$mw->bind("<ButtonPress-1>", sub { $pressed = 1; });
$mw->bind("<ButtonRelease-1>", sub { $pressed = 0; });
$mw->bind("<Motion>" ,[sub {
my ($e,$x,$y) = (@_);
return unless $skip++ > 10;
if ( $pressed && abs($last_x - $x) > abs($la
+st_y - $y)) {
set_direction( $last_x > $x ? 0 : 2)
} elsif ($pressed) {
set_direction( $last_y > $y ? 1 : 3);
}
($last_x, $last_y, $skip) = ($x,$y, 0);
}, Ev('x'), Ev('y')]);
my $timer = Tk::After->new($mw,100,'repeat',
sub {
my $time = time();
next unless $time - $last_time > $speed;
$last_time = $time;
move() unless $dead;
});
$board->createGrid(0,0,10,10 );
my $moves = [ [-1, 0], [ 0,-1],[ 1, 0], [ 0, 1] ];
my $food = [ ];
my ($l,$r,$t,$b) = (0,59,0,39);
my $blocks;
my $snake;
my $level;
my $cur_level;
my $foods = {
'grass' => { food => 1, color => 'green', },
'jitter bug' => {
food => 4, color => 'orange',
on_move => sub {
my $block = shift;
return unless rand > .1;
my $move = $moves->[int rand 4];
my $new_pos = [ $block->[0] + $move->[0],
+ $block->[1] + $move->[1] ];
if ( ! collide(@$new_pos) ) {
$block->[0] = $new_pos->[0];
$block->[1] = $new_pos->[1];
}
},
},
'wander' => {
food => 5, color => 'blue',
on_move => sub {
my $block = shift;
my $dir = $block->[3] || rand int 4;
$dir += rand(int(2)) -1 if rand > .2;
$dir = direction_norm($dir);
move_unless_collide($block,$dir);
$block->[3] = $dir;
},
},
'evade' => {
food => 6, color => 'red',
on_move => sub {
my ($block, $snake) = @_;
my $dir = $block->[3] || rand int 4;
my $head = $snake->{blocks}->[0];
my @choices;
if (distance(@$head, @$block) < 7 and ran
+d > .3) {
push @choices, ($head->[0] > $block->[0
+]) ? 0 : 2;
push @choices, ($head->[1] > $block->[1
+]) ? 1 : 3;
$dir = pick(@choices);
} else {
$dir += rand(int(2)) - 1;
}
move_unless_collide($block,$dir);
$block->[3] = $dir;
},
},
};
my $levels = {
1 => {
name => "Grassy Knoll",
layout => [],
food => ['grass'], food_count => 3,
speed => .2,
victory => sub { return 1 if $score > 5 },
},
2 => {
name => "Mice will play while the cats away!",
layout => [],
start_at => [30,20],
food => [('grass') x 3, 'jitter bug' ], food_cou
+nt => 5,
speed => .175,
victory => sub { $score > 20 },
},
3 => {
name => "Jittery little buggers!",
start_at => [30,2],
layout => [ line( 0, $t+$b/2, $l+$r/2 - 5, $t+$b/2
+),
line( $l+$r/2 + 5, $t+$b/2, $r, $t+$b/
+2) ], # horz line (middle gap)
food => ['jitter bug' ], food_count => 2,
speed => .15,
victory => sub { $score > 30 },
},
4 => {
name => "Watch out for the walls (they have ears
+)!",
start_at => [30,2],
layout => [ line( $l+$r/2 - 10, $t+$b/2, $l+$r/2 +
+ 10, $t+$b/2) ],
food => [ 'grass', 'jitter bug','wander' ], food
+_count => 3,
speed => .16,
victory => sub { $score > 40 },
},
5 => {
name => "Care to Wander away?",
start_at => [30,20],
layout => [ line($l,$t, $l + 10, $t + 10) , line($
+r - 10 , $t + 10, $r, $t),
line($l,$b, $l + 10 ,$b - 10) , line($
+r - 10 , $b - 10, $r, $b) ], # corners
food => ['jitter bug','wander' ], food_count =>
+5,
speed => .14,
victory => sub { $score > 50 },
},
6 => {
name => "Run for it!",
layout => [ line($l,$t, $l + 10, $t + 10) , line($
+r - 10 , $t + 10, $r, $t),
line($l,$b, $l + 10 ,$b - 10) , line($
+r - 10 , $b - 10, $r, $b) ], # corners
food => ['evade'], food_count => 5,
speed => .10,
victory => sub { $score > 62 },
},
};
show_blocks();
MainLoop;
sub restart {
load_level(1);
$snake = {
direction => (int rand 4),
blocks => [[30,20]],
food => 2,
};
status("Ready!");
$score = 0;
$speed = $cur_level->{speed} || .5;
Tk::After->new($mw,1000,'once', sub {
status("Set");
show_snake();
});
Tk::After->new($mw,2000,'once', sub {
status("Go gobble up food!!!");
$dead = 0;
$start = time;
});
}
sub load_level {
$level = shift;
next unless exists $levels->{$level};
$cur_level = $levels->{$level};
$mw->configure(title => "Super Nibbles - Level $level - " . $cur_l
+evel->{name});
$board->delete('food');
if ($cur_level->{start_at}) {
$board->delete('snake');
$snake->{direction} = (int rand 4);
$snake->{food} = scalar @{$snake->{blocks}};
$snake->{blocks} = [$cur_level->{start_at}];
show_snake();
}
$blocks = $cur_level->{layout};
show_blocks();
$food = [];
place_food() for (1.. ($cur_level->{food_count} || 5));
show_food();
}
sub set_direction {
my $dir = shift;
my $cur = $snake->{direction};
# speed up in same direction
move() && return if ($dir == $cur);
# don't allow to reverse direction into self and die
my $cur_move = $moves->[$cur];
my $new_move = $moves->[$dir];
unless ( ($cur_move->[0] + $new_move->[0]) == 0
and ($cur_move->[1] + $new_move->[1]) == 0)
{
$snake->{new_direction} = $dir;
}
}
# colission detection
sub in_bounds {my ($x,$y) = @_; ($x>=0 and $x<=59 and $y>=0 and $y<=39
+); }
sub hit_food {
my ($x,$y, $dont_consume) = @_;
for my $block (@$food) {
if ($x == $block->[0] and $y == $block->[1]) {
my $hits = $foods->{$block->[2]}->{food};
unless ($dont_consume) {
$block = undef; #hit it, remove it.
$food = [ grep { defined $_ } @$food ];
}
return $hits;
}
}
return 0;
}
sub hit_snake {
my ($x,$y) = @_;
for my $block (@{$snake->{blocks}}) {
if ($x == $block->[0] and $y == $block->[1]) {
return 1;
}
}
return 0;
}
sub hit_block {
my ($x,$y) = @_;
for my $block (@$blocks) {
if ($x == $block->[0] and $y == $block->[1]) {
return 1;
}
}
return 0;
}
# check for all collisions
sub collide { !in_bounds(@_) or
hit_snake(@_) or
hit_food (@_, 1) or
hit_block(@_)
}
# place food randomly
sub place_food {
my $x = undef;
my $y;
while ( !defined $x or
collide($x,$y)
)
{
$x = int(rand 60);
$y = int(rand 40);
}
push @$food, [$x,$y, pick( @{$cur_level->{food}} )];
}
# message update commands
sub status { $status->configure(-text => shift); }
sub update_score_board {
$score_board->configure(-text => "Score: $score Time: " . (time - $s
+tart));
}
sub direction_norm {
my $dir = shift;
$dir = 0 if $dir > 3;
$dir = 3 if $dir < 0;
return $dir;
}
sub move_unless_collide {
my ($block, $dir) = @_;
my $move = $moves->[$dir];
my $new_pos = [ $block->[0] + $move->[0], $block->[1] + $move->[1]
+ ];
if ( ! collide(@$new_pos) ) {
$block->[0] = $new_pos->[0];
$block->[1] = $new_pos->[1];
return 1;
}
return 0;
}
sub move {
return if $dead;
if (exists $snake->{new_direction}) {
$snake->{direction} = $snake->{new_direction};
delete $snake->{new_direction};
}
for my $block (@$food) {
my $food_obj = $foods->{$block->[2]};
$food_obj->{on_move}->($block, $snake) if defined $food_obj->{
+on_move};
}
show_food();
my ($xc,$yc) = @{$moves->[ $snake->{direction} ] };
my $last_pos = $snake->{blocks}->[0];
my $new_pos = [$last_pos->[0] + $xc, $last_pos->[1] + $yc];
if (in_bounds( @$new_pos ) && !hit_snake(@$new_pos) && !hit_block(
+@$new_pos) ) {
unshift @{$snake->{blocks}}, $new_pos;
my $hits = hit_food(@$new_pos);
if ($hits) {
place_food();
show_food();
$snake->{food} += $hits;
$score += $hits;
}
if ($snake->{food} > 0) {
$snake->{food}--;
} else {
pop @{$snake->{blocks}};
}
show_snake();
} else {
status("Ouch! You died");
$dead = 1;
}
if ( $cur_level->{victory}->() ) {
load_level(++$level);
}
update_score_board();
}
# display functions. draw the playing field
sub show_snake {
$board->delete('snake');
my $inc = 3 / (@{ $snake->{blocks} || [] } || 1);
my $size = 5;
for my $block (@{$snake->{blocks}}) {
$size -= $inc;
circle($board, $block->[0], $block->[1], $size, 'red', 'snake
+', 'circle');
}
}
sub show_food {
$board->delete('food');
for my $block ( @$food ) {
block($board, $block->[0], $block->[1], $foods->{$block->[2]}-
+>{color}, 'food');
}
}
sub show_blocks {
$board->delete('block');
for my $block ( @$blocks ) {
block($board, $block->[0], $block->[1], 'black', 'block');
}
}
#Tk display functions (normalized to our play grid)
sub circle {
my ($canvas,$x,$y,$size, $color, $tag) = @_;
$color ||= 'red';
$size ||= 0;
$x = ($x * 10) + 5;
$y = ($y * 10) + 5;
$canvas->createOval($x-$size,$y-$size,$x+$size, $y+$size , -fill=>
+ $color, -tags => [$tag]);
}
sub block {
my ($canvas,$x,$y,$color, $tag) = @_;
$color ||= 'red';
$canvas->createRectangle($x*10,$y*10,($x+1) * 10, ($y + 1) *10, -f
+ill=> $color, -tags => [$tag]);
}
## Util Functions
sub round { int( $_[0] + ( $_[0] < 0 ? -.5 : .5 ) ); }
sub distance {
my ($x1,$y1, $x2,$y2) = @_;
sqrt( ($x1 - $x2)**2 + ($y1 - $y2)**2 );
}
sub pick { @_[rand @_] };
sub line {
my ($x1,$y1,$x2,$y2) = @_;
my $x_diff = $x2 - $x1;
my $y_diff = $y2 - $y1;
my @out;
if (abs($x_diff) >= abs($y_diff)) {
my $y_step = $y_diff / $x_diff;
my $y = $y1;
for my $x ( $x1 .. $x2) {
push @out, [$x, round($y)];
$y += $y_step;
}
} else {
my $x_step = $x_diff / $y_diff;
my $x = $x1;
for my $y ( $y1 .. $y2) {
push @out, [round($x), $y];
$x += $x_step;
}
}
return @out;
}
___________
Eric Hodges
$_='y==QAe=e?y==QG@>@?iy==QVq?f?=a@iG?=QQ=Q?9';
s/(.)/ord($1)-50/eigs;tr/6123457/- \/|\\\_\n/;print;
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.