Beefy Boxes and Bandwidth Generously Provided by pair Networks
Do you know where your variables are?
 
PerlMonks  

SameGame

by $code or die (Deacon)
on Sep 14, 2001 at 18:53 UTC ( [id://112437]=sourcecode: print w/replies, xml ) Need Help??
Category: Fun Stuff
Author/Contact Info $code or die Simon Flack
Description: A Perl Tk Game.

Clear the grid with the highest score. You can clear blocks when there are two or more identical blocks next to eachother. The score goes up considerably when you get rid of more than a handful of blocks (you'll see what I mean).

See AGamesZone for the inspiration. (Ok, yes, I ripped it off!)

Code is a little rough in places, but it works.
Tested on:
Perl 5.6.1: ActivePerl 629 on Win2000 and Windows Me,
Perl 5.5: on Debian (potato)		 
######################################################################
+#########
#  SameGame.pl                                                        
+        #
#  -----------                                                        
+        #
#                                                                     
+        #
#  Version:      1.1                                                  
+        #
#                                                                     
+        #
#  Description:                                                       
+        #
#  Clear the grid with the highest score. You can clear blocks when th
+ere     #
#  are two or more identical blocks next to eachother. The more blocks
+ next   #
#  to eachother: the higher the score for clearing them :             
+        #
#      score(n)   =   score(n-1) + score(n-2)                         
+        #
#                                                                     
+        #
#  See http://www.agameszone.com/samegame/samegame.html for the inspir
+ation   #
#  for this, and an online Java version :)                            
+        #
#                                                                     
+        #
#  Simon Flack (perl@simonflack.com)  13/9/2001                       
+        #
######################################################################
+#########

use vars qw($game);


$game = SameGame->new();
#$game->DisplayASCII;    # Displays a text version of the board
$game->play;




package SameGame;

use strict;
use constant ROWS         => 10;
use constant COLUMNS     => 20;
use Tk;
use Tk::Dialog;

sub new
{
    my ($class, %args) = @_;
    $class = ref $class || $class;
    my $self = { score => 0, level => 5};
    $self->{pieces} = pieces();
    bless $self, $class;
    $self->{board} = $self->GenerateBoard(5);
    $self->{value} = generate_scores();
    $self->{display} = SameGame::UI->new($self->{board});
    $self->{currentlyselected} = [];
    return $self;
}

sub restart
{
    my ($game, $level) = @_;
    $level ||= 5;
    $game->{score} = 0;
    $game->{currentlyselected} = [];
    $game->{board} = $game->GenerateBoard($level);
    $game->{display}->refresh_board($game->{board});
    $game->{display}->update_total_score(0);
    $game->{display}->update_click_score(0);
    $game->{display}->update_this_total(0);
}


sub GenerateBoard
{
    my ($self, $level) = @_;
    $self->{level} = $level || 5;
    my @board;
    my ($rows, $cols) = (ROWS, COLUMNS);
    
    for (1 .. $cols) 
    {
        my $row = $_ - 1;
        
        #Each column has $rows rows
        for (1 .. $rows) 
        {
            $board[$row]->[$_ - 1] = $self->_random_piece($level);
        }
    }
    return \@board;
}

sub _random_piece 
{
    my ($self,$level) = @_;
    $level ||=5;
    my @Pieces = @{ $self->{pieces} };
    return $Pieces[rand $level]->{name};
    
}

sub pieces
{
    [
            { name => 'A', color => 'red',},
            { name => 'B', color => 'blue'},
            { name => 'C', color => 'green'},
            { name => 'D', color => 'pink'},
            { name => 'E', color => 'orange'},
            { name => 'F', color => 'yellow'},
            { name => 'G', color => 'purple'},
            { name => 'H', color => 'brown'},
    ]
}


sub generate_scores
{
    my @array = (undef, undef, 2, 4);
    for (1 .. 100)
    {
        push @array, $array[-1] + $array[-2];
    }
    return \@array;
}


sub DisplayASCII
{
    my $self = shift;
    my $board = $self->{board};
    
    for (1 .. ROWS)
    {
        print "  ";
        my $row = $_ - 1;
        for ( 1 .. COLUMNS )
        {
            print $board->[$_ - 1 ]->[$row], "  ";
        }
        print "\n\n";
    }
    
}

sub makeselection
{
    my ($self, $row, $col) = @_;
    #print "R:$row    C:$col  ($self->{board}->[$col-1]->[$row-1]) sel
+ected\n";
    my $piecename = $self->{board}->[$col-1]->[$row-1];
    
    if ($piecename eq " ")
    {
        return unless @{$self->{currentlyselected}};
        $self->{currentlyselected} = [];
        $self->{display}->refresh_board($self->{board});
    }

    # is this piece currently selected?
    # e.g. is it in $self->{currentlyselected}
    # then delete all pieces in $self->{currentlyselected},
    # readjust the board, and add the score
    
    my $piece = "$col,$row";     # e.g. cartesian (x,y)
    if ( grep /^\Q$piece\E$/, @{$self->{currentlyselected}} )
    {
        $self->{score} += $self->{clickscore};
        $self->{clickscore} = 0;
        $self->{display}->update_click_score(0);
        $self->{display}->update_this_total(0);
        $self->{display}->update_total_score($self->{score});
        
        $self->deleteblocks();
        $self->{currentlyselected} = []; 
        $self->deleteblocks(); # temporary bug fix
        $self->{display}->refresh_board($self->{board});

        if ($self->is_game_over) { 
            #print "Game Over";
            $self->{display}->{GameOver}->Show;
        }

        
    } else {
    # if not, then scan the board for adjacent pieces that are the sam
+e
    # and add them to $self->{currentlyselected}
    # then update click score
        $self->{clickscore} = 0;
        $self->updateselection($piecename, $col, $row);
        my $number_of_pieces = @{$self->{currentlyselected}};
        $self->{clickscore} = $self->{value}->[$number_of_pieces] || 0
+;
        $self->{clickscore} *= ($self->{level} - 5) || 1;

        if ($self->{clickscore} == 0) {
            $self->{currentlyselected} = [];
            $self->{display}->refresh_board($self->{board});
            $number_of_pieces = 0;
            return;            
        }
        $self->{display}->refresh_board($self->{board});
        #print "Prospective Score: $self->{clickscore}\n";        
        $self->{display}->update_click_score($self->{clickscore});
        $self->{display}->update_this_total($number_of_pieces);
    }
}


sub updateselection
{
    my ($self, $piecename, $x, $y) = @_;
    $self->{searched} = {};
    @{$self->{currentlyselected}} = 
            $self->recursive_search($self->{board}, $piecename, $x, $y
+, "north");
    $self->{searched} = {};
    push @{$self->{currentlyselected}}, 
            $self->recursive_search($self->{board}, $piecename, $x, $y
+, "west");
    $self->{searched} = {};
    push @{$self->{currentlyselected}}, 
            $self->recursive_search($self->{board}, $piecename, $x, $y
+, "east");
    $self->{searched} = {};
    push @{$self->{currentlyselected}}, 
            $self->recursive_search($self->{board}, $piecename, $x, $y
+, "south");

    
    # strip duplicates
    my %temp_store; @temp_store{@{$self->{currentlyselected}}} = ();
    @{$self->{currentlyselected}} =  keys %temp_store;
}
    
sub recursive_search
{
    my ($self, $board, $search, $x, $y, $direction) = @_;
    return if $self->{searched}->{"$x,$y"};
    my @bag;
    my %dir = (north => "south", east => "west", south => "north", wes
+t => "east");
    
    return unless $board->[$x-1]->[$y-1] eq $search;
    $self->{searched}->{"$x,$y"} = 1;
    push @bag, "$x,$y";

    # make sure we don't double back and go in circles forever
    # the recursion will go back for us
    delete $dir{ $dir{$direction} };

    # make sure we don't fall off the board in our search;
    if ($x == 1         ) { delete $dir{west} }
    if ($x == COLUMNS     ) { delete $dir{east} }
    if ($y == 1         ) { delete $dir{north} }
    if ($y == ROWS         ) { delete $dir{south} }
    
    foreach (keys %dir)
    {
        my ($newx, $newy) = ($x, $y);
        $newy-- if $_ eq "north";
        $newy++ if $_ eq "south";
        $newx++ if $_ eq "east";
        $newx-- if $_ eq "west";
        push @bag, $self->recursive_search($board, $search, $newx, $ne
+wy, $_);
    }
    return @bag;    
}

sub is_game_over
{
    my $self = shift;
    my $board = $self->{board};
    
    for (0 .. COLUMNS - 1)
    {
        my $col = $_;
        COLUMNCHECK:
        for (0 .. ROWS - 2)
        {
            my $row = $_;
            next COLUMNCHECK if $board->[$col]->[$row] eq " ";
            return 0 if $board->[$col]->[$row] eq
                        $board->[$col]->[$row + 1];
        }
    }
    
    for (0 .. ROWS - 1)
    {
        my $row = $_;
        ROWCHECK:
        for (0 .. COLUMNS - 2)
        {
            my $col = $_;
            next ROWCHECK if $board->[$col]->[$row] eq " ";
            return 0 if $board->[$col]->[$row] eq
                        $board->[$col+1]->[$row];
        }
    }
    return 1;
}



sub deleteblocks
{
    my $self = shift;
    
    my @blocks = @{ $self->{currentlyselected} };
    foreach (@blocks)
    {
        my ($x,$y) = split /,/;
        $self->{board}->[$x-1]->[$y-1] = " ";        
    }
    
    # now, shift all the blocks down where there are gaps;
    # one column at a time
    
    for (1 .. COLUMNS)
    {
        my @temp_column = grep /^\S$/, @{$self->{board}->[$_-1]};
        my $empties = (ROWS - scalar @temp_column);

        for (1 .. $empties)
        {
            unshift @temp_column, ' '
        }
        $self->{board}->[$_-1] = \@temp_column;


        if ($empties == ROWS)
        {
            last if $_ == COLUMNS;
            my @replacement = (@{$self->{board}}[$_ .. COLUMNS-1]);
            my @empty; push @empty, ' ' for 1 .. ROWS; push @replaceme
+nt, \@empty;
            @{$self->{board}}[$_-1 .. COLUMNS-1] = @replacement;
        }
        
    }

    #$self->DisplayASCII;
}


sub play
{
    Tk::MainLoop;    
}

sub commify 
{
    # adapted from perlfaq4
    my ($self, $num) = @_;
    1 while $num =~ s/^([-+]?\d+)(\d{3})/$1,$2/;
    return $num;
}

package SameGame::UI;

use vars qw(@ISA);
use constant ROWS         => 10;
use constant COLUMNS     => 20;

@ISA = qw(SameGame);


sub new
{
    my ($class, $board) = @_;
    my $self = {};
    
    $self->{top} = MainWindow->new();
    $self->{top}->title("SameGame");
    $self->{main_frame} = $self->{top}->Frame(-background => 'grey')->
+pack(
        -fill=>'both', 
        -expand=>1,
    );
    bless $self, $class;
    $self->{font} = ($^O =~ /MSWin32/) ? "Helvetica" : "Helvetica";
    $self->{colours} = getcolors();
    $self->init();
    $self->fill_board($board);
    $self->build_board();
    return $self;
}

sub DESTROY
{
    undef $_[0];    
}


sub getcolors
{
    my %colors;
    my $colors = SameGame::pieces;
    foreach (@$colors)
    {
        $colors{$_->{name}} = $_->{color};        
    }
    $colors{"  "} = "grey";
    return \%colors;    
}


sub init {
    my($self, $pieces) = @_;
    my $root = $self->{main_frame};

    $self->{GameOver} = $self->{main_frame}->Dialog(
                    -title => "Game Over!",
                    -text  => "Game Over",
                    -buttons => ["OK"],
                    );


    # widget creation 

    $self->{frameBoard} = $root->Frame (
        -borderwidth => '1',
        -relief => 'groove',
    );
    my($frame_1) = $root->Frame (
    );
    $self->{frameScores} = $root->Frame (
    );
    my($buttonNewGame) = $root->Button (
        -default => 'normal',
        -text => 'New Game',
        -command => sub { $::game->restart },
    );
    my($buttonNewGameHard) = $root->Button (
        -default => 'normal',
        -text => 'HARD level!',
        -background => 'red',
        -command => sub { $::game->restart(8) },
    );
    my($labelThisTotal) = $root->Label (
        -text => 'This Total:',
    );
    $self->{thisTotal} = $root->Label (
        -text => '0',
    );
    my($labelClickScore) = $root->Label (
        -text => 'This Click Score:',
    );
    $self->{clickScore} = $root->Label (
        -text => '0',
    );
    my($labelScoreTotal) = $root->Label (
        -text => 'Score:',
    );
    $self->{totalScore} = $root->Label (
        -text => '0',
    );

    # Geometry management

    $self->{frameBoard}->grid(
        -in => $root,
        -column => '1',
        -row => '1'
    );
    $frame_1->grid(
        -in => $root,
        -column => '1',
        -row => '2'
    );
    $self->{frameScores}->grid(
        -in => $frame_1,
        -column => '3',
        -row => '1'
    );
    $buttonNewGame->grid(
        -in => $frame_1,
        -column => '1',
        -row => '1'
    );
    $buttonNewGameHard->grid(
        -in => $frame_1,
        -column => '2',
        -row => '1'
    );
    $labelThisTotal->grid(
        -in => $self->{frameScores},
        -column => '1',
        -row => '1',
        -sticky => 'e'
    );
    $self->{thisTotal}->grid(
        -in => $self->{frameScores},
        -column => '2',
        -row => '1',
        -sticky => 'w'
    );
    $labelClickScore->grid(
        -in => $self->{frameScores},
        -column => '1',
        -row => '2',
        -sticky => 'e'
    );
    $self->{clickScore}->grid(
        -in => $self->{frameScores},
        -column => '2',
        -row => '2',
        -sticky => 'w'
    );
    $labelScoreTotal->grid(
        -in => $self->{frameScores},
        -column => '4',
        -row => '2',
        -sticky => 'e'
    );
    $self->{totalScore}->grid(
        -in => $self->{frameScores},
        -column => '5',
        -row => '2',
        -sticky => 'w'
    );

    # Resize behavior management

    # container $frame_2 (rows)
    $self->{frameScores}->gridRowconfigure(1, -weight  => 0, -minsize 
+ => 30);
    $self->{frameScores}->gridRowconfigure(2, -weight  => 0, -minsize 
+ => 30);

    # container $frame_2 (columns)
    $self->{frameScores}->gridColumnconfigure(1, -weight => 0, -minsiz
+e => 30);
    $self->{frameScores}->gridColumnconfigure(2, -weight => 0, -minsiz
+e => 155);
    $self->{frameScores}->gridColumnconfigure(3, -weight => 0, -minsiz
+e => 90);
    $self->{frameScores}->gridColumnconfigure(4, -weight => 0, -minsiz
+e => 30);
    $self->{frameScores}->gridColumnconfigure(5, -weight => 0, -minsiz
+e => 121);

    # container $frameBoard (generate)
    for (1 .. ROWS)
    {
        $self->{frameBoard}->gridRowconfigure($_, -weight => 0);
    }
    for (1 .. COLUMNS)
    {
        $self->{frameBoard}->gridColumnconfigure($_, -weight => 0);
    }



    # container $root (rows)
    $root->gridRowconfigure(1, -weight  => 1, -minsize  => 391);
    $root->gridRowconfigure(2, -weight  => 0, -minsize  => 30);

    # container $root (columns)
    $root->gridColumnconfigure(1, -weight => 0, -minsize => 540);

    # container $frame_1 (rows)
    $frame_1->gridRowconfigure(1, -weight  => 0, -minsize  => 30);

    # container $frame_1 (columns)
    $frame_1->gridColumnconfigure(1, -weight => 0, -minsize => 80);
    $frame_1->gridColumnconfigure(2, -weight => 0, -minsize => 80);
    $frame_1->gridColumnconfigure(3, -weight => 0, -minsize => 400);
    
    # additional interface code
    # end additional interface code

}


sub fill_board
{
    my($self, $pieces) = @_;
    my $root = $self->{main_frame};
    $self->{board} = ();
    for (1 .. ROWS)
    {
        my $row = $_;
        for (1 .. COLUMNS)
        {
            my $col = $_;
            $self->{board}[$_-1]->[$row-1] = $root->Button (
                -text => $pieces->[$_ - 1]->[$row-1],
                -background => $self->{colours}->{$pieces->[$_ - 1]->[
+$row -1]},
                -foreground => "black",
                -font => $self->{font} . ',20,bold',
                -command => sub { $::game->makeselection($row, $col) }
+,
            );
        }
    }

}

sub build_board
{
    my($self) = @_;
    my $root = $self->{main_frame};
    for (1 .. ROWS)
    {
        my $row = $_;
        for (1 .. COLUMNS)
        {
            $self->{board}[$_-1]->[$row-1]->grid(
                -in => $self->{frameBoard},
                -column => $_,
                -row => $row,
                -sticky => 'w'
                );
        }
    }

}

sub refresh_board
{
    my($self, $pieces) = @_;
    my $root = $self->{main_frame};
    #$self->{board} = ();
    for (1 .. ROWS)
    {
        my $row = $_;
        
        COLCHECK:
        for (1 .. COLUMNS)
        {
            my $col = $_;
            if ($pieces->[$_ - 1]->[$row-1] eq " ") { 
                $self->{board}[$_-1]->[$row-1]->configure(
                -text =>"O",
                -background => "grey",
                -foreground => "grey",
                -font => $self->{font} . ',20,bold',
                -command => sub { $::game->makeselection($row, $col) }
                );
                
                next COLCHECK;
            }
            

            my $color = $self->{colours}->{$pieces->[$_ - 1]->[$row -1
+]};
            if (grep /^$col,$row$/, @{$::game->{currentlyselected}})
            {
                $color = "white";
            }

            $self->{board}[$_-1]->[$row-1]->configure(
                -text =>$pieces->[$_ - 1]->[$row-1],
                -background => $color,
                -foreground => "black",
                -font => $self->{font} . ',20,bold',
                -command => sub { $::game->makeselection($row, $col) }
                )
        }
    }
    $root->pack;
}

sub update_click_score
{
    my($self, $score) = @_;
    my $root = $self->{main_frame};
    $self->{clickScore}->configure(
        -text => $self->commify($score),
    );
    $root->pack;
}


sub update_total_score
{
    my($self, $score) = @_;
    my $root = $self->{main_frame};
    $self->{totalScore}->configure(
        -text => $self->commify($score),
    );
    $root->pack;
}

sub update_this_total
{
    my($self, $score) = @_;
    my $root = $self->{main_frame};
    $self->{thisTotal}->configure(
        -text => $self->commify($score),
    );
    $root->pack;
}

sub commify 
{
    # adapted from perlfaq4
    my ($self, $num) = @_;
    1 while $num =~ s/^([-+]?\d+)(\d{3})/$1,$2/;
    return $num;
}

######################################################################
+#########
#  Revision History                                                   
+        #
#  -----------                                                        
+        #
#                                                                     
+        #
#  12/9/2001       Beta version - some small bugs                     
+        #
#  13/9/2001       v1.0   Fixed main bugs and added selected block    
+        #
#                         highlighting                                
+        #
#  13/9/2001       v1.1   Added commify() for those really high scores
+!       #
#                         Added a Game Over Check                     
+        #
#                         Fixed board shift bug [ temporary hack :( ] 
+        #
######################################################################
+#########
Replies are listed 'Best First'.
Re: SameGame
by Hero Zzyzzx (Curate) on Sep 15, 2001 at 17:58 UTC

    Very cool! You can now add "tested on Mandrake 8.0, perl 5.6.1" too. I don't know how many total hours I've played SameGnome. Too many.

    I guess I'm going to have to learn how to use Tk. . .

    -Any sufficiently advanced technology is
    indistinguishable from doubletalk.

[reply]
Re: SameGame
by thunders (Priest) on Jan 10, 2002 at 21:15 UTC
    ++
    Great job. It works well on Windows NT sp6 with ActivePerl 629 as well as Cygwin's version of Perl 5.6.1.
[reply]
Re: SameGame
by Dasaan (Beadle) on Dec 18, 2003 at 11:01 UTC
    works on debian unstable too, nice
[reply]
Re: SameGame
by Anonymous Monk on Jan 11, 2002 at 04:36 UTC
    tested successfully on:
    Perl 5.003_03 on HPUX 10.2 running CDE
[reply]

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Node Status?
node history
Node Type: sourcecode [id://112437]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? • Last hour • Other CB clients
Other Users?
Others chilling in the Monastery: (5)
As of 2024-04-19 16:06 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found