#! /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( $$$ ) { }