#!/usr/local/bin/perl -w
use strict;
use Tk;
use Tk::DialogBox;
use Data::Dumper;
my $DEBUG = 0;
# How many rows and calls on the grid
my $MAX_COLS = 9;
my $MAX_ROWS = 9;
# Each tile has a ball inside it. The bounding box of the ball
# is drawn with margin $BALL_MARGIN taken from each bounding
# side, i.e. the ball diameter is:
# ($TILE_WIDTH - 2*$BALL_MARGIN)
#
my $TILE_WIDTH = 30;
my $BALL_MARGIN = 3;
my $MAX_TILE = $MAX_COLS * $MAX_ROWS - 1;
# The states of the game
my $IDLE = 0; # idle state - waiting for a mouse clicks
my $SELECTED = 1; # a ball is selected
my $BUSY = 2; # no events are accepted when busy
my $GAME_OVER = 4; # when a game ends
# all colors
my @colors = ('blue', 'red', 'green', 'lightblue', 'yellow', 'purple',
+ 'brown');
# the colors of "preview" balls, and their canvas ids
my @preview_colors;
my @preview_ids;
# neighbors: there are 8 neighbors for each tile (the ones on the
# edges have less). Checking sequences is enough for only 4 of the nei
+ghbors.
# Example: all sequences detectable by going left can also be detected
+ by
# going right (from another ball)
#
# \ | /
# - -
# / | \
#
my @neighbors = ('to_bottom', 'to_right', 'to_bottomright', 'to_bottom
+left');
# state variable
my $state = $IDLE;
my $cur_selected = undef;
my $score = 0;
# highscores: array of {'name', 'score'}
my @highscores;
my $HIGHS_LISTED = 10;
my $highscores_filename = "perlines_highscores";
my $w_top;
my $w_canv;
my $w_menu;
my $w_upframe;
my $w_preview;
my $w_score;
# This matrix represents the "playing field". Wherever a ball is,
# its color and canvas id are stored. Empty tiles are undef
#
my @matrix;
# this is infinite for all purposes of the game
my $INF = 1000000;
# Create the game screen
#
sub create_screen
{
# Menu stuff
#
$w_menu = $w_top->Frame(-relief => 'raised', -borderwidth => '1')-
+>pack(side => 'top', -fill => 'x');
my $w_filemenu = $w_menu->Menubutton(text => 'File',
borderwidth => 2);
$w_filemenu->pack(-side => 'left', padx => 2);
my $w_new_game = $w_filemenu->command( -label => 'New game',
accelerator => 'F4',
underline => 0,
command => \&new_game);
my $w_highscore = $w_filemenu->command( -label => 'Show high sc
+ores',
accelerator => 'F5',
underline => 0,
command => \&view_highscor
+e);
$w_filemenu->separator();
my $w_exit_game = $w_filemenu->command( -label => 'Exit',
accelerator => 'Ctrl-x',
underline => 0,
command => \&exit_program)
+;
my $w_aboutmenu = $w_menu->Button( text => 'About',
command => \&show_about,
borderwidth => 0);
$w_aboutmenu->pack(-side => 'right', padx => 0);
$w_top->configure(-menu => $w_menu);
# The game grid
#
$w_canv = $w_top->Canvas('-width' => $MAX_COLS * $TILE_WIDTH,
'-height' => $MAX_ROWS * $TILE_WIDTH,
'-border' => 1,
'-relief' => 'ridge');
$w_canv->pack(-side => 'bottom');
# Upper frame stuff: contains preview and score
#
$w_upframe = $w_top->Frame(-relief => 'sunken', -borderwidth => 1)
+;
$w_upframe->pack(-side => 'top', -fill => 'x', -expand => 'x');
my $w_l1 = $w_upframe->Label(-text => 'Preview ')->pack(-side =>
+ 'left');
$w_preview = $w_upframe->Canvas('-width' => 60,
'-height' => 20,
'-border' => 1,
'-relief' => 'ridge');
$w_preview->pack(-side => 'left');
$w_score = $w_upframe->Label(-textvariable => \$score, -width => 6
+)->pack(-side => 'right');
my $w_l2 = $w_upframe->Label(-text => 'Score ')->pack(-side => 'r
+ight');
}
sub new_game
{
$w_canv->destroy;
$w_menu->destroy;
$w_upframe->destroy;
save_highscores_file();
game_init();
}
sub exit_program
{
save_highscores_file();
exit(0);
}
sub show_about
{
my $w_dialog = $w_top->DialogBox( -title => "About Perlines"
+,
-buttons => ["OK"] );
my $about_text = <<END_TEXT;
Perlines is my free clone of the popular
Lines game, written in Perl/Tk.
This program is open source, licensed
with the GPL.
The rules are very simple. Move the balls to form
sequences (rows, columns or diagonals) of at least
5 balls of the same color. For a sequence of 5,
you get 10 points. Each additional ball scores 2
points more than the previous. So, each of balls
1-5 give you 2 points, the 6th gives 4 points,
the 7th gives 6 points, etc.
Enjoy !
Eli Bendersky
END_TEXT
$w_dialog->add("Label", text => $about_text)->pack();
$w_dialog->Show();
}
sub draw_grid
{
# draw horizontal lines
foreach my $i (1 .. $MAX_ROWS)
{
$w_canv->create('line',
0,
$i * $TILE_WIDTH,
$MAX_COLS * $TILE_WIDTH,
$i * $TILE_WIDTH,
'-fill' => 'white');
}
# draw vertical lines
foreach my $i (1 .. $MAX_COLS)
{
$w_canv->create('line',
$i * $TILE_WIDTH,
0,
$i * $TILE_WIDTH,
$MAX_ROWS * $TILE_WIDTH,
'-fill' => 'white');
}
}
sub index2rowcol
{
my $index = $_[0];
return [int($index / $MAX_COLS), $index % $MAX_COLS];
}
sub rowcol2index
{
my ($row, $col) = @_;
return $row * $MAX_COLS + $col;
}
sub get_id
{
my $index = $_[0];
die if !defined($matrix[$index]);
my $ref = $matrix[$index];
return $ref->{'id'};
}
sub mouse_click
{
# we don't need the object ref that's implicitly passed as the fir
+st arg,
my ($x, $y) = @_[1..2];
my $col = int($x / $TILE_WIDTH);
my $row = int($y / $TILE_WIDTH);
return if ($col >= $MAX_COLS or $row >= $MAX_ROWS);
my $index = rowcol2index($row, $col);
print "State: $state, Click in: x,y=($x,$y), that's index $index\
+n" if $DEBUG;
if ($state == $IDLE)
{
if (defined($matrix[$index]))
{
select_ball($index);
}
}
elsif ($state == $SELECTED)
{
# If other ball is selected, change selection to
# this ball
if (defined($matrix[$index]))
{
unselect_ball($cur_selected);
select_ball($index);
}
# If no ball is selected, move this ball to the specified
# destination
else
{
my $move_succ = move_ball($cur_selected, $index);
return unless $move_succ;
tk_sleep($w_top, 150);
my $removed = check_row();
if (!$removed)
{
tk_sleep($w_top, 150);
generate_random_balls();
check_row();
}
game_over() if @{get_empty_tiles()} == 0;
}
}
}
sub game_over
{
$state = $GAME_OVER;
# good enough to get into highscores ?
if ($score > $highscores[-1]->{'score'})
{
my $w_name_dialog = $w_top->DialogBox( -title => "You got i
+nto the high scores !",
-buttons => ["OK"]);
$w_name_dialog->add("Label", -text => "Please, enter your name
+: ")->pack();
my $entry = $w_name_dialog->add("Entry", -width => 35)->pack()
+;
$entry->focus;
$w_name_dialog->Show;
my $name = $entry->get;
$highscores[-1] = {'name' => $name, 'score' => $score};
my @tmp_highscores = @highscores;
@highscores = sort {$b->{'score'} <=> $a->{'score'}} @tmp_high
+scores;
view_highscore();
save_highscores_file();
}
else
{
my $w_dialog = $w_top->DialogBox(-title => "Game over", -butto
+ns => ["OK"]);
$w_dialog->add("Label", -text => "Good luck next time :-)")->p
+ack();
$w_dialog->Show;
}
}
# remove sequences of 5 balls and more in a row
sub check_row
{
my @bag;
# for all balls
foreach my $index (@{get_all_balls()})
{
foreach my $neighbor (@neighbors)
{
my $this = $index;
my $color = $matrix[$this]->{'color'};
my @seq;
push(@seq, $this);
# we only need to detect a sequence of length 5, as longer
# sequences will be implicitly detected (a longer sequence
# is simply 2 separated sequences of 5)
foreach my $i (1..4)
{
my $next = eval("$neighbor($this)");
last if !defined($next) or !defined($matrix[$next]);
last if $matrix[$next]->{'color'} ne $color;
# we're here ? the sequence lives on !
push(@seq, $next);
$this = $next;
}
if ($#seq == 4)
{
$, = ",";
push(@bag, @seq);
}
}
}
if (@bag)
{
my %seen = ();
my @uniq_bag = grep {!$seen{$_}++} @bag;
my $ball_count = 0;
foreach (@uniq_bag)
{
++$ball_count;
kill_ball($_, 1);
if ($ball_count <= 5)
{
$score = $score + 2;
}
else
{
$score = $score + 2 + ($ball_count - 5) * 2;
}
}
return 1;
}
}
sub to_bottom
{
my $index = $_[0];
return (($index + $MAX_COLS) > $MAX_TILE)
? undef : $index + $MAX_COLS;
}
sub to_up
{
my $index = $_[0];
return (($index - $MAX_COLS) < 0)
? undef : $index - $MAX_COLS;
}
sub to_right
{
my $index = $_[0];
return ($index % $MAX_COLS == $MAX_COLS - 1)
? undef : $index + 1;
}
sub to_left
{
my $index = $_[0];
return ($index % $MAX_COLS == 0)
? undef : $index - 1;
}
sub to_bottomright
{
my $index = $_[0];
return ($index % $MAX_COLS == $MAX_COLS - 1) || (($index + $MAX_CO
+LS + 1) > $MAX_TILE)
? undef : $index + $MAX_COLS + 1;
}
sub to_bottomleft
{
my $index = $_[0];
return ($index % $MAX_COLS == 0) || (($index + $MAX_COLS - 1) > $M
+AX_TILE)
? undef : $index + $MAX_COLS - 1;
}
# return an array of indices of the tiles that are empty (no balls)
sub get_empty_tiles
{
my @arr;
for (my $i = 0; $i <= $#matrix; ++$i)
{
push @arr, $i unless defined($matrix[$i]);
}
return \@arr;
}
#return an array of indices of all balls
sub get_all_balls
{
my @arr;
for (my $i = 0; $i <= $#matrix; ++$i)
{
push @arr, $i if defined($matrix[$i]);
}
return \@arr;
}
sub generate_preview_colors
{
foreach my $i (0..2)
{
my $color = $colors[rand @colors];
$preview_colors[$i] = $color;
}
# delete old preview balls
foreach (@preview_ids)
{
$w_preview->delete($_);
}
foreach my $i (0..2)
{
my $color = $preview_colors[$i];
my $id = $w_preview->create('oval',
$i * 20 + 5,
5,
($i + 1) * 20 - 1,
19,
'fill' => $color);
}
}
sub generate_random_balls
{
# 3 random balls
foreach my $i (0..2)
{
my @empty_tiles = @{get_empty_tiles()};
if (@empty_tiles == 0)
{
last;
}
my $index = $empty_tiles[rand @empty_tiles];
create_ball($index, $preview_colors[$i]);
}
generate_preview_colors();
}
sub move_ball
{
$state = $BUSY;
my ($source, $dest) = @_;
my $tmp = find_path($source, $dest);
my @path;
# is it possible to move this ball to that destination ?
if (defined($tmp))
{
@path = @{$tmp};
my $color = $matrix[$source]->{'color'};
my $now = $source;
foreach my $next (@path)
{
tk_sleep($w_top, 30);
kill_ball($now, 0);
create_ball($next, $color);
$now = $next;
}
$state = $IDLE;
return 1;
}
else
{
$state = $SELECTED;
return 0;
}
}
# To find the optimal path (if exists) for a ball to move from a sourc
+e
# to destination, the Dijkstra single-source shortest path algorithm
# is utilized. The implementation is based on "Introduction to algorit
+hms"
# by Cormen et al, so some of the definitions are taken from there.
#
# A graph is assembled from the empty tiles
# and the source tile.
#
# The graph is represented as follows:
#
# A vertex is represented by a number - its index into the
# vertices array. The array is always of length $MAX_TILE+1,
# with some indices undefined (the tiles are full).
#
# The array cells are references to hashes, that contain
# the following fields:
# 'd' - shortest path estimate to the vertex
# 'pred' - predecessor in the path
# 'adj' - (ref to) an array of all adjacent tiles (their indices)
#
# The source tile is the first element of the array of vertices
#
# Performance: Building a graph each time is not too bad, it's linear
+in the
# amount of empty tiles. The "linked list" graph representation
# is efficient because there can be a maximum of 4 edges from
# each vertex
#
sub build_graph
{
# $indices[0] is the source vertex
my @indices = @_;
my @graph;
$graph[$MAX_TILE] = undef; # pre-set size
# adjacent tiles to some tile
my @adj_arr = ('to_right', 'to_left', 'to_up', 'to_bottom');
foreach my $index (@indices)
{
my %entry;
# The init-single-source procedure
#
$entry{'d'} = $INF;
$entry{'pred'} = undef;
my @adj;
# Detect all legal edges from this tile
foreach my $to_dir (@adj_arr)
{
my $next = eval("$to_dir($index)");
# an edge is legal, if the adjacent tile exists and is emp
+ty
push(@adj, $next) if (defined($next) and !defined($matrix[
+$next]));
}
$entry{'adj'} = \@adj;
$graph[$index] = \%entry;
}
# init source path estimation
$graph[$indices[0]]->{'d'} = 0;
return \@graph;
}
# The "Dijkstra" procedure - finds the shortest paths
# to all destinations from a given source.
# Gets a graph, modifies 'd' and 'pred' to make a shortest
# path and returns a graph
#
# init-single-source should have been done before (in build_graph)
#
# In the algorithm:
#
# S - a set of vertices for which the final path was decided
# Q - a priority queue, sorted by 'd', of all vertices in the
# graph that are not yet in S
#
sub dijkstra
{
my @graph = @{$_[0]};
# init S
my @S = ();
# init Q
my @Q;
foreach my $i (0..$MAX_TILE)
{
push(@Q, $i) if defined($graph[$i]);
}
# the fun is here
#
while (@Q)
{
# keep Q in priority queue order
my @Q_tmp = @Q;
@Q = sort {$graph[$a]->{'d'} <=> $graph[$b]->{'d'}} @Q_tmp;
# extract-min from Q
my $u = shift @Q;
# add $u to @S set
push(@S, $u);
# for each vertex adjacent to $u, relax all edges leaving
# it
# relax - improve (if possible) the shortest path estimate
# to v by going through u
#
# note: all weights are 1 in our graph
#
foreach my $v (@{$graph[$u]->{'adj'}})
{
if ($graph[$v]->{'d'} > $graph[$u]->{'d'} + 1)
{
$graph[$v]->{'d'} = $graph[$u]->{'d'} + 1;
$graph[$v]->{'pred'} = $u;
}
}
}
return \@graph;
}
sub find_path
{
my ($source, $dest) = @_;
# build a graph
my $graph_ref = build_graph($source, @{get_empty_tiles()});
# get a graph with shortest past coded in 'pred' of vertices
my @final_graph = @{dijkstra($graph_ref)};
# path found ?
if (defined($final_graph[$dest]->{'pred'}))
{
# compute a reversed path, by going backwards from $dest,
# through all 'pred's until $source is reached
#
my @rev_path;
my $iter = $dest;
while ($iter != $source)
{
push(@rev_path, $iter);
$iter = $final_graph[$iter]->{'pred'};
}
return [reverse @rev_path];
}
else
{
return undef;
}
}
sub kill_ball
{
# $trace tells whether to leave a white trail prior
# to dying. it is useful when a sequence is removed,
# but not used when a ball is moved
#
my ($index, $trace) = @_;
my ($row, $col) = @{index2rowcol($index)}[0..1];
my $id = get_id($index);
if ($trace == 1)
{
$w_canv->itemconfigure($id, 'outline' => 'white', 'fill' => 'w
+hite');
tk_sleep($w_top, 40);
}
$w_canv->delete($id); $matrix[$index] = undef;
}
sub select_ball
{
my ($index) = $_[0];
my $id = get_id($index);
$w_canv->itemconfigure($id, 'outline' => 'white', 'width' => 2);
$cur_selected = $index;
$state = $SELECTED;
}
sub unselect_ball
{
my ($index) = $_[0];
my $id = get_id($index);
$w_canv->itemconfigure($id, 'outline' => 'black', 'width' => 1);
$cur_selected = undef;
$state = $IDLE;
}
sub create_ball
{
my ($index, $color) = @_;
my ($row, $col) = @{index2rowcol($index)}[0..1];
die if defined($matrix[$index]);
my $id = $w_canv->create('oval',
$col * $TILE_WIDTH + $BALL_MARGIN,
$row * $TILE_WIDTH + $BALL_MARGIN,
($col + 1) * $TILE_WIDTH - $BALL_MARGIN,
($row + 1) * $TILE_WIDTH - $BALL_MARGIN,
'fill' => $color);
$matrix[$index] = {'id' => $id, 'color' => $color};
}
# imitate a tk 'sleep' (non-blocking)
sub tk_sleep
{
my ($top, $ms) = @_;
my $delay_dummy = 0;
$top->after($ms, sub{$delay_dummy++});
$top->waitVariable(\$delay_dummy)
unless $delay_dummy;
}
sub game_init
{
srand();
$score = 0;
$state = $IDLE;
@highscores = ();
foreach my $i (0..$MAX_TILE)
{
$matrix[$i] = undef;
}
create_screen();
read_highscores_file();
draw_grid();
generate_preview_colors();
$w_canv->Tk::bind("<Button-1>" => [\&mouse_click, Ev('x'), Ev('y')
+]);
$w_top->Tk::bind("<F4>" => \&new_game);
$w_top->Tk::bind("<F5>" => \&view_highscore);
$w_top->Tk::bind("<Control-x>" => \&exit_program);
generate_random_balls() foreach (1..2);
}
sub view_highscore
{
my $w_dialog = $w_top->DialogBox( -title => "High scores",
-buttons => ["OK", "Clear"]);
my $w_scores_frame = $w_dialog->add("Frame", -borderwidth => 1,
-relief => 'sunken')->pack(-si
+de => 'top', -fill => 'x');
for (my $i = 1; $i <= $HIGHS_LISTED; ++$i)
{
my $name = "";
my $score = 0;
if (defined($highscores[$i-1]))
{
$name = $highscores[$i-1]->{'name'};
$score = $highscores[$i-1]->{'score'};
}
my $w_line_frame = $w_scores_frame->Frame(-borderwidth => 1)->
+pack(-side => 'top', -fill => 'x');
my $line = sprintf("%-2d.", $i);
$w_line_frame->Label(-text => $line, -width => 3)->pack(-side
+=> 'left');
$line = sprintf("%-50s", $name);
$w_line_frame->Label(-text => $line, -width => 30, -anchor =>
+'w')->pack(-side => 'left');
$line = sprintf("%6d", $score);
$w_line_frame->Label(-text => $line, -width => 6, -anchor => '
+e')->pack(-side => 'right');
}
my $button = $w_dialog->Show();
if ($button eq "OK")
{
return;
}
elsif ($button eq "Clear")
{
@highscores = ();
}
}
# The highscores file format is as follows:
#
# All lines are read (only the best will be displayed). On each
# line, the last space separated token is the score,
# the rest is the name.
#
# No error checking is performed - no one should
# play around with this highscores file
#
sub read_highscores_file
{
if (open(FH, $highscores_filename))
{
while (my $line = <FH>)
{
chomp($line);
my @tokens = split(/ /, $line);
# grab the score from last tokens
my $score = $tokens[-1];
# all tokens except the last make the name
pop @tokens;
my $name = join(" ", @tokens);
push(@highscores, {'name' => $name, 'score' => $score});
}
}
while ($#highscores < $HIGHS_LISTED - 1)
{
push(@highscores, {'name' => "n/a", 'score' => 0});
}
my @tmp_highscores = @highscores;
@highscores = sort {$b->{'score'} <=> $a->{'score'}} @tmp_highscor
+es;
}
sub save_highscores_file
{
open(FH, ">$highscores_filename") or warn "could not write high sc
+ores: $!\n";
foreach (@highscores)
{
my $name = $_->{'name'};
my $score = $_->{'score'};
print FH "$name $score\n";
}
}
sub main
{
$w_top = MainWindow->new(-title => 'Perlines');
$w_top->resizable(0, 0);
game_init();
MainLoop();
return 0;
}
# Run
exit(main(@ARGV));
In reply to Perlines
by spurperl
Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
Read Where should I post X? if you're not absolutely sure you're posting in the right place.
Please read these before you post! —
Posts may use any of the Perl Monks Approved HTML tags:
- a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
| |
For: |
|
Use: |
| & | | & |
| < | | < |
| > | | > |
| [ | | [ |
| ] | | ] |
Link using PerlMonks shortcuts! What shortcuts can I use for linking?
See Writeup Formatting Tips and other pages linked from there for more info.