#! /usr/bin/perl -ws

use strict;
use Tk;
use vars qw/$d/;

my $DEBUG = $d or 0;

# Really, these shouldn't be global variables.
my( $top, $playfield, $msg_window );
my( $trackbase, $pip, $pathchoice );

# Main
{
    my $trackname = 'Monaco';
    my @path = ( 2 );      # Series of spaces;

    # Setup
    my $board = &initialize_track( $trackname );
    my $players = [ ];     # Note that initialization is dependend on
               # the Tk board already being initialized.
    # A lot of the TK calls are dependent on the size of the track.
    # If possible offload as much of this as possible to the initalize_track
    # routine, and we may need some sort of screen swapping dealie as well.
    $top = MainWindow->new();
    $top->title( $trackname );
    $playfield = $top->Canvas( -width  => $board->{views}[0][0],
           -height => $board->{views}[0][1],
           );
    $trackbase = $playfield->Photo( -file => "$trackname/$trackname.gif",
          );
    $pip = $playfield->Photo( -file => "Primitives/Piece1.gif",
             );
    $playfield->createImage( 0, 0, -anchor => 'nw', -image => $trackbase,
           );
    $playfield->pack();
    # Ideally, what I'd like to have is a highlighting of an area as the use
    # moves over it.  That means, unfortunately, revamping the data
    # structures to define the areas of spaces, rather than just their
    # centres.  Still, it would be nice.
    $playfield->Tk::bind( "<Button-1>", [ \&movement, Ev('x'), Ev('y'), $board, $players ], );
    # Realistically, a "simple" move, consists of determining length (by
    # rolling a die), choosing a valid path, allowing for backing up or
    # clearing, then effecting the path, taking into account number of stops
    # if going through a curve.  Where the hell am I going to do all this?
    $msg_window = $top->Label( -background => "black",
                -foreground => "white",
                -justify => "left",
                );
    my $done = $top->Button( -text    => 'Dismiss',
              -command => \&done,
              );
    $done->pack( -side => "right" );
    my $reset = $top->Button( -text => 'Reset',
               -command => [ \&reset, $board, $players, ],
               );
    $reset->pack( -side => 'right' );
    $msg_window->pack( -side => "left", -fill => "x", -expand => 1, );

    $players->[1] = undef; # Need to have existing entry for reset to work
    &reset( $board, $players );

    MainLoop();
}

sub done
{
    exit;
}

sub movement( $$$$$ )
{
    my( undef, $x, $y, $board, $players ) = @_;
    print STDERR "$x, $y:\n" if $DEBUG;

    my @coords = @{$board->{views}};   # Pass by value.
    my @space = @{$board->{spaces}};
    # Find closest point
    my $leastdist = undef;
    my $closest = undef;
    foreach my $spindex ( 1..$#coords ) {
   my $dist = abs( $x - $coords[$spindex][0] )
       + abs ( $y - $coords[$spindex][1] );
   if( ! defined( $leastdist ) || $dist < $leastdist ) {
       $leastdist = $dist;
       $closest = $spindex;
   }
#  last if $leastdist < 5;
    }

    # For now, there's only one player:

    # Is this a valid move?
    my @options = @{$space[$players->[1]{space}]};
    my( $newspace, $newdirection, $valid );
    $valid = '';
    print STDERR "\tPath choices: ", join( ", ", @options ), "\n" if $DEBUG;
    while( @options ) {
   $newspace = shift( @options );
   $newdirection = shift( @options );
   next unless( $newspace == $closest );
   $valid = 1;
   last;
    }
    unless( $valid ) {
   &status_msg( "Invalid move from " . $players->[1]{space} . " to $closest." );
   return 0;
    }
    # Check for lane changes.  If we're in a new segment, then we can reset
    # the lane change counter.
    if( $newdirection ) {
   if( $players->[1]{direction} && ( $newdirection != $players->[1]{direction} )) {
       &status_msg( "Invalid lane change." );
       return 0;
   }
   $players->[1]{direction} = $newdirection;
    }
    # Right now, the easiest way (for me) to see if we can reset the lane
    # change counter is to see if we're in a corner or not.
    foreach my $corner ( @{$board->{corners}} ) {
   next unless defined $corner;
   if( $closest > $corner->[0] && $closest < $corner->[1] ) {
       $players->[1]{direction} = 0;
       last;
   }
    }

    # Erase last square:
    ( $x, $y ) = ( $coords[$players->[1]{space}][0],
         $coords[$players->[1]{space}][1] );
    $trackbase->copy( $players->[1]{asphalt}, -to => ( $x - 8, $y - 8,
                      $x + 7, $y + 7 ))
   if $players->[1]{drawn};
    # Draw new point
    ( $x, $y ) = ( $coords[$closest][0], $coords[$closest][1] );
    print STDERR "\t$closest ($x, $y)\n" if $DEBUG;
    $players->[1]{asphalt}->copy( $trackbase, -from => ( $x - 8, $y - 8,
                        $x + 7, $y + 7 ));
    $trackbase->copy( $pip, -to => ($x - 8, $y - 8, $x + 7, $y + 7) );
    $players->[1]{space} = $closest;
    $players->[1]{drawn} = 1;
    &status_msg( "Moved to space $closest" );

    return 1;
}

# Opens up data files and gets info about track
sub initialize_track( $ )
{
    my( $trackname ) = $_[0];
    my $board = { 'views' => [],
             'spaces' => [],
        'corners' => [],
             };   # Board object.

    open( TRACKDATA, "<$trackname/$trackname.txt" ) || die "Unable to open track.";
    my $section = '';
    my $eof = '';
    # Skip down to next section:
    while( ! $section && ! $eof ) {
   $_ = &next_valid_line( *TRACKDATA ) || ( $eof = 1 );
   if( /^SECTION=(\w+)$/ ) {
       $section = $1;
   }
    }

    die "Unable to find any board information." unless $section;
    while( $section ) {
   if( lc $section eq 'boards' ) {
       $section = &get_board_info( *TRACKDATA, $board );
   } elsif( lc $section eq 'spaces' ) {
       $section = &get_space_info( *TRACKDATA, $board );
   } elsif( lc $section eq 'segments' ) {
       $section = &get_segment_info( *TRACKDATA, $board );
   } else {
       die "Unknown section: $section";
   }
    }
    close( TRACKDATA );
    return $board;
}

sub get_board_info( $$ )
{
    my( $input, $board ) = @_;
    my $next_section = '';

    # Read board information:
    $_ = &next_valid_line( $input ) || die "Unable to read board views.";
    $board->{views}[0] = [ split "\t" ];

    while( <$input> ) {
   # Skip blank or comment lines
   next if /^\s*(?:\#.*)?$/;
   chop;
   # Are we done?
   if( /^SECTION=(\w+)$/ ) {
       $next_section = $1;
       last;
   }
   my( $space, @coords ) = split "\t";
   $board->{views}[$space] = [ @coords ];
    }
    return $next_section;
}

sub get_space_info( $$ )
{
    my( $input, $board ) = @_;
    my $next_section = '';

    while( <$input> ) {
   # Skip blank or comment lines
   next if /^\s*(?:\#.*)?$/;
   chop;
   # Are we done?
   if( /^SECTION=(\w+)$/ ) {
       $next_section = $1;
       last;
   }
   my( $space, @pathways ) = split "\t";
   $board->{spaces}[$space] = [ @pathways ];
    }
    return $next_section;
}

sub get_segment_info( $$ )
{
    my( $input, $board ) = @_;
    my $next_section = '';

    while( <$input> ) {
   # Skip blank or comment lines
   next if /^\s*(?:\#.*)?$/;
   chop;
   # Are we done?
   if( /^SECTION=(\w+)$/ ) {
       $next_section = $1;
       last;
   }
   my( $segment, @curve ) = split "\t";
   $board->{corners}[$segment] = [ @curve ];
    }
    return $next_section;
}

# Takes a string and displays it to the user.
sub status_msg( $ )
{
    $msg_window->configure( -text => $_[0] );
    return 1;
}

# Initializes players
sub reset( $$ )
{
    my( $board, $players ) = @_;
    my( $x, $y );
    my @coords = @{$board->{views}};

    # Setup players:

    # Erase existing player pieces if any:
    for my $piece ( 1 .. $#{$players} ) {
   if( $players->[$piece]{space} ) {
       # Erase the current piece from the board
       ( $x, $y ) = ( $coords[$players->[$piece]{space}][0],
            $coords[$players->[$piece]{space}][1] );
       $trackbase->copy( $players->[$piece]{asphalt},
               -to => ( $x - 8, $y - 8, $x + 7, $y + 7 ));
   }
   $players->[$piece] = { asphalt => $playfield->Photo( -height => 16,
                          -width => 16 ),
                space => 1,
                direction => 0,
                drawn => 0,
                lap => 0,
                petrol => 4,
                tires => 6,
                brakes => 4,
                engine => 3,
                chassis => 3,
         };
   # Draw the new piece
   ( $x, $y ) = ( $coords[$players->[$piece]{space}][0],
             $coords[$players->[$piece]{space}][1] );
   $players->[$piece]{asphalt}->copy( $trackbase,
                  -from => ( $x - 8, $y - 8,
                        $x + 7, $y + 7 ));
   $trackbase->copy( $pip, -to => ($x - 8, $y - 8, $x + 7, $y + 7) );
   $players->[$piece]{drawn} = 1;
    }
    return $players;
}

# Takes a stream pointer, and gets the next non-blank, non-comment line
sub next_valid_line( $ )
{
    my $stream = $_[0];
    my $input = '';
    my $valid = '';
    while( ! $valid ) {
      $input = <$stream>;
   next if $input =~ /^\s*(?:\#.*)?$/;
   chop $input;
   $valid = 1;
    }
    return $valid unless $valid;
    return $input;
}

# Given a map, a start and end point, finds the shortest route.
sub shortest_path( $$$ )
{
}