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