###############################################################################
#  SameGame.pl                                                                #
#  -----------                                                                #
#                                                                             #
#  Version:      1.1                                                          #
#                                                                             #
#  Description:                                                               #
#  Clear the grid with the highest score. You can clear blocks when there     #
#  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 inspiration   #
#  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]) selected\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 same
	# 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", west => "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, $newy, $_);
	}
	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 @replacement, \@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, -minsize => 30);
	$self->{frameScores}->gridColumnconfigure(2, -weight => 0, -minsize => 155);
	$self->{frameScores}->gridColumnconfigure(3, -weight => 0, -minsize => 90);
	$self->{frameScores}->gridColumnconfigure(4, -weight => 0, -minsize => 30);
	$self->{frameScores}->gridColumnconfigure(5, -weight => 0, -minsize => 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 :( ]         #
###############################################################################