######################################################################
+#########
#  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 :( ] 
+        #
######################################################################
+#########
[download]