Stumbled upon the (very) incomplete Games::Tetris and it scratched my itch to learn some more Moose and try out threading in Perl. It was all surprisingly very painless.

With the code below, either set your module path or get it on CPAN (when available) and run

perl -MGames::Tetris::Complete -e "play" [width height]

where optional arguments width and height are the board dimensions in pixels. They default to 12x20.

Here's the code:

• Games::Tetris::Complete:

package Games::Tetris::Complete;
use warnings;
use strict;
use Games::Tetris::Complete::Shape;
use Term::ReadKey;
use Time::HiRes qw(usleep);
use Term::Screen::Uni;
use threads;
use threads::shared;
use Thread::Semaphore;
our ( @ISA, @EXPORT );

BEGIN {
    require Exporter;
    @ISA    = qw(Exporter);
    @EXPORT = qw(play);       # symbols to export on request
}
$| = 1;

our $VERSION = '0.02';

# Globals
my $semaphore           = Thread::Semaphore->new();
my $print_cond : shared = 0;
my $GAME_OVER : shared  = 0;
my %line_points         = (
    1 => 40,
    2 => 100,
    3 => 300,
    4 => 1200
);

sub play {
    my @args = @_ ? @_ : @ARGV ? @ARGV : ();
    @args = ( width => $args[ 0 ], height => $args[ 1 ] )
        if @args == 2 and int $args[ 0 ];
    my $self : shared = shared_clone( __PACKAGE__->new( @args ) );
    $semaphore->down;    # Block console until we get first input
    my $console_thread = threads->create( \&console_thread, $self );
    print "Enter any key to begin...";
    get_input( 0 );
    $self->active_shape( random_shape() );
    $semaphore->up;
    my $player_thread = threads->create( \&player_thread, $self );
    my $game_thread   = threads->create( \&game_thread,   $self );
    $player_thread->detach();
    $game_thread->join();
    # print "Joined game_thread.\n";
    {
        lock( $print_cond );
        $print_cond = -1;
        cond_signal( $print_cond );
    }
    $console_thread->join();
    print "Final Score: " . commify( $self->score ) . "\n";
}

# perlfaq5 (brian d foy)
sub commify {
    local $_ = shift;
    1 while s/^([-+]?\d+)(\d{3})/$1,$2/;
    return $_;
}

#---------------------------------------------------------------------
+---------#
use Moose;

$SIG{ __DIE__ } = sub { confess $_[ 0 ] };

for ( qw/ width height / ) {
    has $_ => (
        is       => 'ro',
        isa      => 'Int',
        required => 1,
        default  => $_ eq 'width' ? 12 : 20
    );
}

has 'score' => (
    traits  => [ 'Number' ],
    is      => 'ro',
    isa     => 'Int',
    default => 0,
    handles => {
        inc_score => 'add',
        dec_score => 'sub',
        set_score => 'set',
    },
);
has 'level' => (
    is      => 'rw',
    isa     => 'Num',
    default => 0,
);

has 'board' => (
    is         => 'ro',
    isa        => 'GameGrid',
    lazy_build => 1,
);

sub BUILD {
    my $self = shift;
    $self->board;    # Create board before sharing
}

has [ qw/ active_shape queued_shape / ] => (
    is  => 'rw',
    isa => 'Games::Tetris::Complete::Shape',
);

around 'active_shape' => sub {
    my ( $orig, $self, $shape ) = @_;
    return $self->$orig() unless $shape;
    lock( $GAME_OVER );

    # Update the board
    my $board      = $self->board;
    my $shape_grid = $shape->grid;
    my $shape_nx   = $shape->nx;
    my $x_offset   = int( $self->width / 2 ) - int( $shape_nx / 2 );
    for my $y ( 0 .. $shape->ny - 1 ) {
        my $shape_row = $shape_grid->[ $y ];

        # Note: can't splice shared arrays
        for ( 0 .. $shape_nx - 1 ) {
            my $shape_char = $shape_row->[ $_ ];
            # Game over if removed chars overlap shape chars
            $GAME_OVER = 1
                if $board->[ $y ][ $x_offset + $_ ] ne ' '
                    and $shape_char ne ' ';
            $board->[ $y ][ $x_offset + $_ ] = $shape_char;
        }
    }
    # Set the shape location
    $shape->ulx( $x_offset );
    $shape->uly( 0 );

    # Enqueue a new shape
    $self->queued_shape( shared_clone( random_shape() ) );

    # Set the shape as the active shape
    $self->$orig( shared_clone( $shape ) );
};

#---------------------------------------------------------------------
+---------#

no Moose;
use Carp;
__PACKAGE__->meta->make_immutable;

sub _build_board {
    my $self = shift;
    my @board =
        map { [ map ' ', 0 .. $self->width - 1 ]; } 0 .. $self->height
+ - 1;
    \@board;
}

sub _game_over {
    lock( $GAME_OVER );
    $GAME_OVER;
}

sub player_thread {
    my $self = shift;
    while ( 1 ) {
        last if _game_over();
        if ( my $action = get_input( 0.5 ) ) {
            $semaphore->down;
            block_to_print() if $action->( $self );
            $semaphore->up;
        }
    }
    # print "Exiting player_thread.\n";
}

sub game_thread {
    my $self               = shift;
    my $sleep_microseconds = 1_000_000;    # 0.2 second(s)
    my $speedup            = 1.1;
    # $self->level( 0.9 );   Testing only
    while ( 1 ) {
        usleep( $sleep_microseconds / ( $speedup * ( int $self->level 
++ 1 ) ) );
        last if _game_over();
        $semaphore->down;
        if ( $self->down( 1 ) ) {
            block_to_print();
        }
        else {
            $self->next_shape;
        }
        $semaphore->up;
    }
    # print "Exiting game_thread.\n";
}

sub next_shape {
    my $self = shift;
    # Clear full lines
    if ( my $cleared = $self->clear_full_lines ) {
        my $level = $self->level;
        $self->inc_score( $line_points{ $cleared } * ( int( $level ) +
+ 1 ) );
        $self->level( $level += 0.1 * $cleared );
    }
    # Start new shape
    $self->active_shape( $self->queued_shape );
    block_to_print();
}

sub block_to_print {
    lock( $print_cond );
    $print_cond++;
    cond_signal( $print_cond );
}

sub clear_full_lines {
    my $self  = shift;
    my $board = $self->board;
    my $width = $self->width;
    my @cleared;
    for ( 0 .. $self->height - 1 ) {
        next if grep $_ eq ' ', @{ $board->[ $_ ] };
        push @cleared, $_;
    }
    return 0 unless @cleared;

    # Animate!
    my $sleep_microseconds = 50_000;
    my $mid                = int( $width / 2 ) + $width % 2 - 1;
    $board->[ $_ ][ $mid ] = ' ' for @cleared;
    unless ( $width % 2 ) {
        $board->[ $_ ][ $mid + 1 ] = ' ' for @cleared;
    }
    block_to_print();
    usleep( $sleep_microseconds );
    for ( my $i = 1; $i < $mid; $i++ ) {
        $board->[ $_ ][ $mid - $i ] = ' ' for @cleared;
        $board->[ $_ ][ $mid + $i ] = ' ' for @cleared;
        block_to_print();
        usleep( $sleep_microseconds );
    }
    if ( @cleared == 4 ) {
        # Hell yea tetris, do some random pattern
        my @chars = ( '+', ' ' );
        for my $i ( 1, 2 ) {
            for my $y ( @cleared ) {
                # if ( $y == $cleared[ 0 ] or $y == $cleared[ 3 ] ) {
                if ( $y + $i % 2 ) {
                    $board->[ $y ][ $_ ] = $_ % 2 ? '+' : ' '
                        for 0 .. $width - 1;
                }
                else {
                    $board->[ $y ][ $_ ] = $_ % 2 ? ' ' : '+'
                        for 0 .. $width - 1;
                }
                block_to_print();
                usleep( $sleep_microseconds );
            }
        }
    }

    # Update The Board
    $self->clear_line( $_ ) for @cleared;

    scalar @cleared;
} ## end sub clear_full_lines

sub clear_line {
    my ( $self, $y ) = @_;
    my $board = $self->board;
    my $width = $self->width;
    for my $y ( reverse 0 .. $y - 1 ) {
        $board->[ $y + 1 ][ $_ ] = $board->[ $y ][ $_ ] for 0 .. $widt
+h - 1;
    }
    # Clear first line
    $board->[ 0 ][ $_ ] = ' ' for 0 .. $width - 1;
}

{
    my %input_response = (
        'j' => \&left,
        'k' => \&down,
        'l' => \&right,
        'i' => \&rotate_left,
        'a' => \&left,
        's' => \&down,
        'd' => \&right,
        'w' => \&rotate_left,
        'q' => \&quit,
        ' ' => \&drop,
    );

    sub get_input {
        my $timeout = @_ ? shift : 0;
        ReadMode 'cbreak';
        my $action;
        my $got = ReadKey $timeout;
        # print "Saw key: '$got'\n";
        $action = $input_response{ $got } if defined $got;
        ReadMode 'normal';
        $action;
    }
}

sub drop {
    my $self  = shift;
    my $lines = 0;
    while ( $self->down ) {
        $lines++;
    }
    $self->inc_score( $lines * 2 );
    $self->next_shape;
    $lines;
}

sub rotate_left {
    my $self       = shift;
    my $board      = $self->board;
    my $shape      = $self->active_shape;
    my $shape_grid = $shape->grid;
    my ( $nx,     $ny )    = ( $shape->nx,    $shape->ny );
    my ( $ulx,    $uly )   = ( $shape->ulx,   $shape->uly );
    my ( $height, $width ) = ( $self->height, $self->width );

    # Return if we'd run into a border
    return if $ny > $nx and $ulx == 0 || $ulx + $nx == $width;
    return if $nx > $ny and $uly + $ny == $height;

    # Build new rotated shape
    my @new_grid;
    for my $x ( reverse 0 .. $nx - 1 ) {
        push @new_grid, [ map $shape_grid->[ $_ ][ $x ], 0 .. $ny - 1 
+];
    }
    my $new_shape = Games::Tetris::Complete::Shape->new(
        grid => \@new_grid,
        char => $shape->char,
        ulx  => $ulx - ( $ny - $nx ),
        uly  => $uly + ( $ny - $nx ),
    );

    # Return if new covered points overlap border or another shape
    my @covered     = $shape->covered_points;
    my @covered_new = $new_shape->covered_points;
    return if grep {
        my ( $y, $x ) = @$_;
        $y < 0 || $x < 0 || $y >= $height || $x >= $width
    } @covered_new;
    return if grep {
        my ( $y, $x ) = @$_;
        $board->[ $y ][ $x ] ne ' '
            # Don't count points covered by original shape
            and !grep { $y == $_->[ 0 ] and $x == $_->[ 1 ] } @covered
    } @covered_new;

    # Update board and store
    my $char = $shape->char;
    $board->[ $_->[ 0 ] ][ $_->[ 1 ] ] = ' '   for @covered;
    $board->[ $_->[ 0 ] ][ $_->[ 1 ] ] = $char for @covered_new;

    $shape->grid( shared_clone \@new_grid );
    $shape->ulx( $ulx - ( $ny - $nx ) );
    $shape->uly( $uly + ( $ny - $nx ) );
    $shape->nx( $ny );
    $shape->ny( $nx );

    1;
} ## end sub rotate_left

sub left  { shift->horizontal( 0 ) }
sub right { shift->horizontal( 1 ) }

sub horizontal {
    my ( $self, $right ) = @_;
    my $shape = $self->active_shape;
    my $board = $self->board;
    my ( $ulx,      $uly )      = ( $shape->ulx, $shape->uly );
    my ( $shape_nx, $shape_ny ) = ( $shape->nx,  $shape->ny );
    my $shape_grid = $shape->grid;

    # Check if right/left column overlaps next column or end of board
    return if !$right && !$ulx or $right && $ulx + $shape_nx == $self-
+>width;
    return
        if grep {
        $shape_grid->[ $_ ][ $right ? ( $shape_nx - 1 ) : 0 ] ne ' '
            and $board->[ $uly + $_ ][
            $right
            ? ( $ulx + $shape_nx )
            : ( $ulx - 1 )
            ] ne ' '
        } 0 .. $shape_ny - 1;

    for my $i ( 0 .. $shape_nx ) {
        if ( $i ) {
            for my $y ( 0 .. $shape_ny - 1 ) {
                my $char = $shape_grid->[ $y ][ $i - 1 ];
                # Update board
                $board->[ $uly + $y ][
                    $right
                    ? ( $ulx + $i )
                    : ( $ulx + $i - 2 )
                    ]
                    = $char
                    # Keep right/left pixels the same when not blank
                    unless $char eq ' '
                        and ( $right && $i == $shape_nx or !$right && 
+$i == 1 );
            }
        }
        else {
            # Blank left/right col
            $board->[ $uly + $_ ][ $right ? $ulx : ( $ulx + $shape_nx 
+- 1 ) ] =
                ' '
                for 0 .. $shape_ny - 1;
        }
    }
    $right ? $shape->inc_ulx : $shape->dec_ulx;

    1;
} ## end sub horizontal

sub down {
    my ( $self, $dont_inc_score ) = @_;
    my $shape = $self->active_shape;
    my $board = $self->board;
    my ( $ulx,      $uly )      = ( $shape->ulx, $shape->uly );
    my ( $shape_nx, $shape_ny ) = ( $shape->nx,  $shape->ny );
    my $shape_grid = $shape->grid;

    # Check if last shape row overlaps beneath current location or end
+ of board
    return if $uly + $shape->ny == $self->height;
    return if grep {
        my ( $y1, $x1 ) = ( $_->[ 0 ] + 1, $_->[ 1 ] );
        !$shape->covers( $y1, $x1 ) and $board->[ $y1 ][ $x1 ] ne ' '
    } $shape->covered_points;

    for my $i ( 0 .. $shape_ny ) {
        if ( $i ) {
            my $shape_row = $shape_grid->[ $i - 1 ];
            for ( 0 .. $shape_nx - 1 ) {
                my $char = $shape_row->[ $_ ];
                # Keep beneath pixels the same when not blank
                my ( $y, $x ) = ( $uly + $i, $ulx + $_ );
                $board->[ $y ][ $x ] = $char
                    unless $board->[ $y ][ $x ] ne ' '
                        and !$shape->covers( $y, $x );
            }
        }
        else {
            # Blank first row
            $board->[ $uly ][ $_ ] = ' ' for $ulx .. $ulx + $shape_nx 
+- 1;
        }
    }
    $shape->inc_uly;
    $self->inc_score( 1 ) unless $dont_inc_score;
    1;
} ## end sub down

sub clear_screen {
    my $console = shift;
    $console->clrscr();
}

{
    # Output Stuff

    my $console;

    sub console_thread {
        my $self = shift;
        $console = Term::Screen::Uni->new() or die "couldn't make cons
+ole";

        # Intro Screen
        clear_screen( $console );
        $self->print_intro;

        $semaphore->down;
        clear_screen( $console );
        $self->print_board;
        $semaphore->up;
        while ( 1 ) {
            lock( $print_cond );
            cond_wait( $print_cond ) until $print_cond;
            last if $print_cond == -1;
            $print_cond--;
            $console->at( 0, 0 );
            $self->print_board;
        }
        # print "Exiting console_thread.\n";
    }

    my $INSTRUCTIONS = <<EOI;

KEYBOARD CONFIGURATION:

    LEFT    - a / j
    DOWN    - s / k    
    RIGHT   - d / l
    ROTATE  - w / i
    DROP    - space

    QUIT    - q

EOI

    sub print_board {
        my ( $self ) = @_;
        my $board    = $self->board;
        my $level    = $self->level;
        my $width    = $self->width;
        printf "NEXT LEVEL: %2d\n", 10 - $level * 10 % 10;
        print '+' . '-' x $width . "+\n";
        for my $y ( 0 .. $self->height - 1 ) {
            print '|' . join( '', @{ $board->[ $y ] } ) . "|\n";
        }
        print '+' . '-' x $width . "+\n";
        # print $INSTRUCTIONS;
        my $col = $width + 4;
        $console->at( 2, $col );
        printf "Level: %02d", $level;
        $console->at( 4, $col );
        printf "Score: %06d", $self->score;
        $console->at( 8, $col );
        print " Next:";
        my $queued_shape = $self->queued_shape;
        my $grid_next    = $queued_shape->grid;
        my $row          = 7;
        $col = $width + 12;

        if ( $queued_shape->ny <= 2 ) {
            $console->at( $row, $col );
            print ' ' x 4;
            $row++;
        }
        for ( 0 .. 3 ) {
            my $grid_row = $grid_next->[ $_ ] || [];
            $console->at( $row, $col );
            print join '',
                map defined $grid_row->[ $_ ] ? $grid_row->[ $_ ] : ' 
+',
                0 .. 3;
            $row++;
        }
        $console->at( $self->height + 4, 0 );
    } ## end sub print_board

    sub print_intro {
        my $self = shift;
        my $msg  = 'TETRIS';
        my ( $width, $height ) = ( $self->width, $self->height );
        print '+' . '-' x $width . "+\n";
        for my $y ( 0 .. $height - 1 ) {
            if ( $y == int( $height / 2 ) ) {
                my $l1 = ( $width - length $msg ) / 2;
                print '|'
                    . ' ' x $l1
                    . $msg
                    . ' ' x ( $width - $l1 - length( $msg ) + $width %
+ 2 )
                    . "|\n";
            }
            else {
                print "|" . ' ' x $width . "|\n";
            }
        }
        print '+' . '-' x $width . "+\n";
        print $INSTRUCTIONS;
    }
}

sub quit {
    lock( $GAME_OVER );
    $GAME_OVER = 1;
    return;
}

{
    my @shapes = (
        [ ' +', '++', '+ ' ],
        [ '+ ', '++', ' +' ],
        [ '++', '++' ],
        [ '+' x 4 ],
        [ ' + ', '+++' ],
        [ '++', '+ ', '+ ' ],
        [ '++', ' +', ' +' ],
    );
    # @shapes = ( [ '+' x 4 ] );    This is cheating

    sub random_shape {
        Games::Tetris::Complete::Shape->new(
            grid => $shapes[ int rand @shapes ] );
    }
}

1;
[download]

• Games::Tetris::Complete::Shape

package Games::Tetris::Complete::Shape;
use strict;
use warnings;
use Data::Dumper;
use Moose;
use Moose::Util::TypeConstraints;

our $VERSION = '0.02';

# Upper left corner of grid
for ( qw( ulx uly ) ) {
    has $_ => (
        is      => 'rw',
        isa     => 'Int',
        default => sub { -1 },
        traits  => [ 'Counter' ],
        handles => {
            "inc_$_" => 'inc',
            "dec_$_" => 'dec',
        },
    );
}

subtype 'Char' => as 'Str' => where { $_ ne ' ' && length $_ == 1 } =>
    message { "Not a string of length 1 ($_)" };
subtype 'Blank' => as 'Str' => where { $_ eq ' ' } =>
    message { "Not a blank char ($_)" };
subtype 'GameGrid' => as 'ArrayRef[ArrayRef[Char|Blank]]' =>
    message { "bad grid: " . Dumper( $_ ) };
coerce 'GameGrid' => from 'ArrayRef[Str]' => via { [ map [ split // ],
+ @$_ ] };

has 'char' => (
    is         => 'ro',
    isa        => 'Char',
    lazy_build => 1,
);

sub _build_char {
    my $self = shift;
    my $grid = $self->grid;
    my %chars;
    for my $y ( 0 .. $self->ny - 1 ) {
        $chars{ $_ }++
            for grep $_ ne ' ', map $grid->[ $y ][ $_ ], 0 .. $self->n
+x - 1;
    }
    my @c = keys %chars;
    confess "No non-blank chars in grid!" unless @c;
    confess "More than one char in grid (" . join( ',', @c ) . ")"
        if @c > 1;
    $c[ 0 ];
}

has [ qw( nx ny ) ] => (
    is         => 'rw',
    isa        => 'Int',
    lazy_build => 1,
);
has 'grid' => (
    is       => 'rw',
    isa      => 'GameGrid',
    required => 1,
    coerce   => 1,
);

#---------------------------------------------------------------------
+---------#

no Moose;
use Carp;

sub _build_nx {
    my $self = shift;
    scalar @{ $self->grid->[ 0 ] };
}

sub _build_ny {
    my $self = shift;
    scalar @{ $self->grid };
}

# Test if given board point is covered by this shape
sub covers {
    my ( $self, $y, $x ) = @_;

    # Check if the grid covers the point (undef)
    my ( $ulx, $uly ) = ( $self->ulx, $self->uly );
    return if $ulx > $x || $uly > $y;
    my ( $grid_x, $grid_y ) = ( $x - $ulx, $y - $uly );
    return if $grid_x >= $self->nx || $grid_y >= $self->ny;

    # Check if the value at the given point is a Blank (0) or Char (1)
    my $char = $self->grid->[ $grid_y ][ $grid_x ];
    confess "No char at ($grid_x,$grid_y)!" unless $char;
    match_on_type $char => (
        Blank => sub { 0 },
        Char  => sub { 1 },
        => sub { confess "the fuck is this: '$char'" }
    );
}

sub covered_points {
    my $self = shift;
    my ( $ulx, $uly ) = ( $self->ulx, $self->uly );
    my $grid = $self->grid;
    my @points;
    for my $yi ( 0 .. $self->ny - 1 ) {
        for my $xi ( 0 .. $self->nx - 1 ) {
            # match_on_type $grid->[ $yi ][ $xi ] => (
            # Char => sub { push @points, [ $uly + $yi, $ulx + $xi ] }
+,
            # Blank => sub { }
            # );
            # print "($yi,$xi) ";
            # print "char: '", $grid->[ $yi ][ $xi ], "'\n";
            if ( $grid->[ $yi ][ $xi ] ne ' ' ) {
                push @points, [ $uly + $yi, $ulx + $xi ];
            }
        }
    }
    @points;
}

1;
[download]

(caveats) Testing is, er, manual only. I've only done Win32. Speed is slightly more difficult than the classic version because I'm impatient.

---

---

Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!

Titles consisting of a single word are discouraged, and in most cases are disallowed outright.

Read Where should I post X? if you're not absolutely sure you're posting in the right place.

Please read these before you post! —

• How do I compose an effective node title?
• How do I post a question effectively?
• Markup in the Monastery

Posts may use any of the Perl Monks Approved HTML tags:

a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr

You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)

	For:		Use:
	&		&
	<		&lt;
	>		&gt;
	[		&#91;
	]		&#93;

Link using PerlMonks shortcuts! What shortcuts can I use for linking?

See Writeup Formatting Tips and other pages linked from there for more info.