#!/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));