[SPOILER] Tetris - ascii

Had a lot of fun with this one, my 5 year old enjoyed it.
 
This is my first experience writing a dispatcher... where a key ( keyboard
input becomes key in hash ) is used to call a function.
 
There were a few issues that I never did resolve, advice is welcome:
- how to get input in a platform independent way ( don't see a way, mine
runs in windows with Term::ReadKey )
- how to draw the output ( learning curve to climb in Tk, tutorial
suggestions? )
- how to get the timer independent of the keyboard input
 
this guy does not give points for adjacent blocks.
 
instructions.
- start, then resize output window to have one screen's worth.
 
 
>>> start of code >>>
 
# tetris_tgc.pl
#

use strict;
use warnings;
 
use Term::ReadKey;
 
my $field_rows = 20;
my $field_cols = 10;
 
my $appear_x = $field_cols / 2;
my $appear_y = 1;
 
my $tick_time = 1;
 
my @field;
my $blank = ' ';
my $boundary = '.';
 
my $key_left    = 'z';
my $key_right   = 'x';
my $key_up      = 'i';
my $key_down    = '/';
my $key_rotate  = ',';
my $key_unrotate= 's';
my $key_quit    = 'q';
my $key_place   = 'p';
my $key_drop    = ' ';
 
my $row = $boundary x ($field_cols + 2);
push( @field, $row );
 
for( 1..$field_rows )
{
    $row = $boundary . $blank x $field_cols . $boundary;
    push( @field, $row );
}
 
$row = $boundary x ($field_cols + 2);
push( @field, $row );
 
my @composite = @field;
 
my @shapes = (
    get_square(),
    get_s(),
    get_z(),
    get_l(),
    get_r(),
    get_t(),
    get_long()    );
 
my $current_piece = 0;
my $current_piece_ref = $shapes[ $current_piece ];
my $current_piece_rotation = 0;
 
# my @user_actions = qw ( j j j p i i i p k k k p q );
 
#########################################
 
ReadMode('cbreak');
 
my %dispatch;
 
teach_commands( \%dispatch );
 
my %points_to_add = ( 0, 0,  1, 10,  2, 30,  3, 90,  4, 400 );
my $score;
 
my $pos_x = $appear_x;
my $pos_y = $appear_y;
 
$tick_time = 1;
 
while( 1 )
{
    my $rows_removed = remove_full_rows();
    $score += $points_to_add{ $rows_removed };
 
    my $piece_ref = prepare_piece( 0 );
    @field = @composite;
    apply_shape( $piece_ref, \@field, $pos_x, $pos_y );
    show_field( \@field );
    show_instructions();
 
    while( 1 )
    {
        my $keyboard_input = ReadKey( $tick_time );
#        my $keyboard_input = shift( @user_actions );
 
        print "tick";
 
        $keyboard_input = $key_down unless $keyboard_input;
 
        if( exists( $dispatch{ $keyboard_input } ) )
        {
#            print "yes defined\n";
            my $sub_ref = $dispatch{$keyboard_input};
 
            store_state();
 
            my $action_result = &$sub_ref();
 
            $piece_ref = prepare_piece( 0 );
            if( position_problem( $piece_ref, \@composite, $pos_x, $pos_y )
)
            {
                restore_state();
                exit( 0 ) if( at_top() and $keyboard_input eq $key_down );
                if( 'down' eq $action_result )
                {
                    $piece_ref = prepare_piece( 0 );
                    apply_shape( $piece_ref, \@composite, $pos_x, $pos_y );
                    $pos_x = $appear_x;
                    $pos_y = $appear_y;
                    $current_piece++;
                    $current_piece = 0 unless( exists( $shapes[
$current_piece ] ) );
                    $current_piece_ref = $shapes[ $current_piece ];
                    $current_piece_rotation = 0;
                }
            }
 
            last;
        }
        else
        {
#            print "not defined\n";
            print "x";
        }
    }
}
 
exit( 0 );
 
####################################################
 
sub apply_shape
{
    my $shape_ref  = shift;
    my $field_ref  = shift;
    my $position_x = shift;
    my $position_y = shift;
 
    my $row = 0;
    for my $piece_line ( @$shape_ref )
    {
        my $len = length( $piece_line );
        for my $col ( 0..$len-1 )
        {
            next if( substr( $piece_line, $col, 1 ) eq $blank );
 
            substr( $$field_ref[ $position_y + $row ], 
                    $col + $position_x, 1 ) = 
                substr( $piece_line, $col, 1 );
        }
        $row++;
    }
}
 
# is there a problem for
# the shape fit in the field
# at the location given?
#
sub position_problem
{
    my $shape_ref  = shift;
    my $field_ref  = shift;
    my $position_x = shift;
    my $position_y = shift;
 
    my $row = 0;
    for my $piece_line ( @$shape_ref )
    {
        my $len = length( $piece_line );
        for my $col ( 0..$len-1 )
        {
            next if( substr( $piece_line, $col, 1 ) eq $blank );
 
            my $field_positin = 
                substr( $$field_ref[ $position_y + $row ], 
                    $col + $position_x, 1 );
 
            if( $field_positin ne $blank )
            {
                print "# there is a problem\n";
                return 1;
            }
        }
        $row++;
    }
    return 0;
}
 
sub show_field
{
    my $field = shift;
 
    for( @$field )
    {
        print "   $_\n";
    }
    print "\n\n";
}
 

sub show_instructions
{
    print "score: $score\n";
    print "to move the block:\n";
    print "left    $key_left    \n";
    print "right   $key_right   \n";
    print "up      $key_up      \n";
    print "down    $key_down    \n";
    print "rotate  $key_rotate  \n";
    print "unrot   $key_unrotate\n";
    print "place   $key_place   \n";
    print "drop    <space>      \n";
    print "quit    $key_quit    \n";
}
 
# connect something to do
# with user input.
#
sub teach_commands
{
    my $dispatch_ref = shift;
 
    $$dispatch_ref{ $key_left } = 
        sub
        {
            print "move left\n";
            $pos_x--;
        };
 
    $$dispatch_ref{ $key_right } = 
        sub
        {
            print "move right\n";
            $pos_x++;
        };
    $$dispatch_ref{ $key_up } = 
        sub
        {
            print "move up\n";
            $pos_y--;
        };
    $$dispatch_ref{ $key_down } = 
        sub
        {
            print "move down\n";
            $pos_y++;
            return "down";
        };
    $$dispatch_ref{ $key_rotate } = 
        sub
        {
            @field = @composite;
            my $piece_ref = prepare_piece( 1 );
            apply_shape( $piece_ref, \@field, $pos_x, $pos_y );
            show_field( \@field );
            show_instructions();
        };
    $$dispatch_ref{ $key_unrotate } = 
        sub
        {
            @field = @composite;
            my $piece_ref = prepare_piece( -1 );
            apply_shape( $piece_ref, \@field, $pos_x, $pos_y );
            show_field( \@field );
            show_instructions();
        };
    $$dispatch_ref{ $key_quit } = 
        sub
        {
            print "quit program\n";
            exit( 0 );
        };
    $$dispatch_ref{ $key_place } =
        sub
        {
            my $piece_ref = prepare_piece( 0 );
            apply_shape( $piece_ref, \@composite, $pos_x, $pos_y );
            $pos_x = $appear_x;
            $pos_y = $appear_y;
        };
    $$dispatch_ref{ $key_drop } = 
        sub
        {
            my $piece_ref = prepare_piece( 0 );
            while( 1 )
            {
                $pos_y++;
                if( position_problem( $piece_ref, \@composite, $pos_x,
$pos_y ) )
                {
                    $pos_y--;
                    last;
                }
            }
        };
}
 
# when something goes wrong
# restore when it was good.
 
my $store_x;
my $store_y;
my $store_piece_rotation;
 
sub store_state
{
    $store_x = $pos_x;
    $store_y = $pos_y;
 
    $store_piece_rotation = $current_piece_rotation;
}
 
sub restore_state
{
    $pos_x = $store_x;
    $pos_y = $store_y;
 
    $current_piece_rotation = $store_piece_rotation;
 
    my $piece_ref = prepare_piece( 0 );
    @field = @composite;
    apply_shape( $piece_ref, \@field, $pos_x, $pos_y );
}
 
# get some help to know if the game is over.
sub at_top
{
    print "at top: pos_y = $pos_y, appear_y = $appear_y\n";
    return 1 if( $pos_y <= $appear_y );
}
 
sub get_z
{
    my @z0 = (
        '    ',
        'XX  ',
        ' XX '
        );
 
    my @z1 = (
        '  X ',
        ' XX ',
        ' X  '
        );
 
    my @z = 
    (
        \@z0,
        \@z1
    );
 
    replace_symbols( \@z, $blank, '%' );
    return \@z;
}
 
sub get_s
{
    my @s0 = (
        '    ',
        ' XX ',
        'XX  '
        );
 
    my @s1 = (
        ' X  ',
        ' XX ',
        '  X '
        );
 
    my @s = 
    (
        \@s0,
        \@s1
    );
 
    replace_symbols( \@s, $blank, '@' );
    return \@s;
}
 
sub get_square
{
    my @square0 = (
        '    ',
        ' XX ',
        ' XX '
        );
 
    my @square = 
    (
        \@square0
    );
 
    replace_symbols( \@square, $blank, '#' );
    return \@square;
}
 
sub get_long
{
    my @long0 = (
        '  X ',
        '  X ',
        '  X ',
        '  X '
        );
 
    my @long1 = (
        '    ',
        '    ',
        'XXXX'
        );
 
    my @long = 
    (
        \@long0,
        \@long1
    );
    replace_symbols( \@long, $blank, '+' );
    return \@long;
}
 
sub get_l
{
    my @l0 = (  ' X  ',
                ' X  ',
                ' XX '  );
    my @l1 = (  '    ',
                '  X ',
                'XXX ' );
    my @l2 = (  '    ',
                ' XX ',
                '  X ',
                '  X ' );
    my @l3 = (  '    ',
                ' XXX',
                ' X  ' );
    my @l =  (  \@l0,
                \@l1,
                \@l2,
                \@l3  );
    replace_symbols( \@l, $blank, '*' );
    return \@l;
}
 
sub get_r
{
    my @r0 = (   ' XX ',
                 ' X  ',
                 ' X  '  );
    my @r1 = (   '    ',
                 'X   ',
                 'XXX ' );
    my @r2 = (   '    ',
                 '  X ',
                 '  X ',
                 ' XX ' );
    my @r3 = (   '    ',
                 ' XXX',
                 '   X' );
 
    my @r =  (  \@r0,
                \@r1,
                \@r2,
                \@r3  );
    replace_symbols( \@r, $blank, '&' );
    return \@r;
}
 
sub get_t
{
    my @t0 = (   ' X ',
                 ' XX',
                 ' X '  );
 
    my @t1 = (   ' X ',
                 'XXX' );
 
    my @t2 = (   ' X ',
                 'XX ',
                 ' X ' );
    my @t3 = (   '   ',
                 'XXX',
                 ' X ' );
 
    my @t =  (  \@t0,
                \@t1,
                \@t2,
                \@t3  );
    replace_symbols( \@t, $blank, '$' );
    return \@t;
}
 
sub remove_full_rows
{
    my @keepers;
    my $changed = 0;
 
    for( @composite )
    {
        if( /^[$boundary]+$/ or /[$blank]/ )
        {
            # normal row, do not remove.
 
            push( @keepers, $_ );
        }
        else
        {
            # no blanks, remove it.
 
            # modify current field for display of rows to remove.
            $_ = $boundary . "*" x $field_cols . $boundary;
 
            $row = $boundary . $blank x $field_cols . $boundary;
            my $border = shift( @keepers );
            unshift( @keepers, $row );
            unshift( @keepers, $border );
            $changed++;
#            print "***** changed ****";
        }
    }
 
    if( $changed )
    {
        show_field( \@composite );
        show_instructions();
        sleep( 1 );
 
        @composite = @keepers;
    }
 
    return $changed;
}
 
# X   shape symbol
# < > space symbol
sub replace_symbols
{
    my $shape_rotations = shift;
    my $blank_symbol = shift;
    my $shape_symbol = shift;
 
    for my $rotation ( @$shape_rotations )
    {
        for( @$rotation )
        {
            s/ /$blank_symbol/g;
            s/X/$shape_symbol/g;
        }
    }
}
 
sub prepare_piece
{
    my $rotate_delta = shift;
    $rotate_delta = 0 unless $rotate_delta;
 
    if( $rotate_delta )
    {
        $current_piece_rotation += $rotate_delta;
 
        if( $rotate_delta < 0 and $current_piece_rotation < 0 )
        {
            $current_piece_rotation = $#$current_piece_ref;
        }
        elsif( $current_piece_rotation > $#$current_piece_ref )
        {
            $current_piece_rotation = 0;
        }
    }
 
    return $$current_piece_ref[ $current_piece_rotation ];
}

 

 



-------------------------------------------------------------------------------
This message and any included attachments are from Siemens Medical Solutions 
USA, Inc. and are intended only for the addressee(s).  
The information contained herein may include trade secrets or privileged or 
otherwise confidential information.  Unauthorized review, forwarding, printing, 
copying, distributing, or using such information is strictly prohibited and may 
be unlawful.  If you received this message in error, or have reason to believe 
you are not authorized to receive it, please promptly delete this message and 
notify the sender by e-mail with a copy to Central.SecurityOffice-/v/[email protected] 

Thank you