88 lines
2.4 KiB
Perl
88 lines
2.4 KiB
Perl
#!/usr/bin/perl
|
|
|
|
use strict; # https://rosettacode.org/wiki/2048
|
|
use warnings;
|
|
use Tk;
|
|
|
|
my $N = shift // 4;
|
|
$N < 2 and $N = 2;
|
|
my @squares = 1 .. $N*$N;
|
|
my %n2ch = (' ' => ' ');
|
|
@n2ch{ map 2**$_, 1..26} = 'a'..'z';
|
|
my %ch2n = reverse %n2ch;
|
|
my $winner = '';
|
|
my @arow = 0 .. $N - 1;
|
|
my @acol = map $_ * $N, @arow;
|
|
|
|
my $mw = MainWindow->new;
|
|
$mw->geometry( '+300+0' );
|
|
$mw->title( 2048 );
|
|
$mw->focus;
|
|
$mw->bind('<KeyPress-Left>' => sub { arrow($N, @arow) } );
|
|
$mw->bind('<KeyPress-Right>' => sub { arrow($N, reverse @arow) } );
|
|
$mw->bind('<KeyPress-Up>' => sub { arrow(1, @acol) } );
|
|
$mw->bind('<KeyPress-Down>' => sub { arrow(1, reverse @acol) } );
|
|
my $grid = $mw->Frame()->pack;
|
|
for my $i ( 0 .. $#squares )
|
|
{
|
|
$grid->Label(-textvariable => \$squares[$i],
|
|
-width => 5, -height => 2, -font => 'courierbold 30',
|
|
-relief => 'ridge', -borderwidth => 5,
|
|
)->grid(-row => int $i / $N, -column => $i % $N );
|
|
}
|
|
my $buttons = $mw->Frame()->pack(-fill => 'x', -expand => 1);
|
|
$buttons->Button(-text => 'Exit', -command => sub {$mw->destroy},
|
|
-font => 'courierbold 14',
|
|
)->pack(-side => 'right');
|
|
$buttons->Button(-text => 'New Game', -command => \&newgame,
|
|
-font => 'courierbold 14',
|
|
)->pack(-side => 'left');
|
|
$buttons->Label(-textvariable => \$winner,
|
|
-font => 'courierbold 18', -fg => 'red2',
|
|
)->pack;
|
|
|
|
newgame();
|
|
MainLoop;
|
|
-M $0 < 0 and exec $0;
|
|
|
|
sub losecheck
|
|
{
|
|
local $_ = join '', @n2ch{ @squares };
|
|
/ / || ($_ ^ substr $_, $N) =~ tr/\0// and return;
|
|
/(.)\1/ and return for /.{$N}/g;
|
|
$winner = 'You Lost';
|
|
}
|
|
|
|
sub arrow
|
|
{
|
|
$winner and return; # you won, no more play
|
|
my ($inc, @ix) = @_;
|
|
my $oldboard = "@squares";
|
|
for ( 1 .. $N )
|
|
{
|
|
local $_ = join '', @n2ch{ @squares[@ix] }; # extract 4 squares
|
|
tr/ //d; # force left
|
|
s/(\w)\1/ chr 1 + ord $1 /ge; # group by twos
|
|
@squares[@ix] = @ch2n{ split //, $_ . ' ' x $N }; # replace
|
|
$_ += $inc for @ix; # next row or col
|
|
}
|
|
$oldboard eq "@squares" and return;
|
|
add2();
|
|
losecheck();
|
|
grep $_ eq 2048, @squares and $winner = 'WINNER !!';
|
|
}
|
|
|
|
sub add2
|
|
{
|
|
my @blanks = grep $squares[$_] eq ' ', 0 .. $#squares;
|
|
@blanks and $squares[ $blanks[rand @blanks] ] =
|
|
$_[0] // (rand() < 0.1 ? 4 : 2);
|
|
}
|
|
|
|
sub newgame
|
|
{
|
|
$_ = ' ' for @squares;
|
|
add2(2) for 1, 2;
|
|
$winner = '';
|
|
}
|