mirror of
https://github.com/coding-horror/basic-computer-games.git
synced 2025-12-25 20:34:32 -08:00
09b0e972cd
The directory includes a Perl script to test the port (roulette-test.t) and a Perl script to generate the test based on output from the BASIC implementation (make-roulette-test.pl).
264 lines
6.5 KiB
Perl
Executable File
264 lines
6.5 KiB
Perl
Executable File
#!/usr/bin/env perl
|
|
|
|
use 5.014; # For s///r
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use File::Temp;
|
|
use Getopt::Long 2.33 qw{ :config auto_version };
|
|
use IPC::Cmd qw{ can_run }; # Core as of Perl 5.9.5.
|
|
use Pod::Usage;
|
|
|
|
our $VERSION = '0.000_01';
|
|
|
|
my %opt = (
|
|
program => find_basic(),
|
|
output => make_default_output(),
|
|
);
|
|
|
|
GetOptions( \%opt,
|
|
qw{ output=s program=s },
|
|
help => sub { pod2usage( { -verbose => 2 } ) },
|
|
) or pod2usage( { -verbose => 0 } );
|
|
|
|
die "No default BASIC found; you must specify --program\n"
|
|
unless defined $opt{program};
|
|
|
|
my $game_dir = ( File::Spec->splitdir( $0 ) )[0];
|
|
my $basic_file = File::Spec->catfile( $game_dir, 'roulette.bas' );
|
|
open my $basic_handle, '<', $basic_file
|
|
or die "Unable to open $basic_file: $!\n";
|
|
|
|
my $munged = File::Temp->new();
|
|
|
|
print { $munged } <<'EOD';
|
|
1000 Y=50
|
|
1010 DIM B(100),C(100),T(100)
|
|
1090 FOR S=1 TO 38
|
|
1095 PRINT "SPIN ";S
|
|
1100 FOR C=1 TO Y
|
|
1110 B(C)=1
|
|
1120 T(C)=C
|
|
1130 NEXT C
|
|
EOD
|
|
|
|
transcribe( $basic_file, $basic_handle, $munged, 1860, 2810 );
|
|
transcribe( $basic_file, $basic_handle, $munged, 2950 );
|
|
|
|
say { $munged } '4000 NEXT S';
|
|
|
|
$munged->flush();
|
|
|
|
if ( $opt{output} ne '-' ) {
|
|
my $dir = ( File::Spec->splitpath( $0 ) )[1];
|
|
my $fn = File::Spec->rel2abs( $opt{output}, $dir );
|
|
$fn = File::Spec->abs2rel( $fn );
|
|
open my $fh, '>', $fn
|
|
or die "Unable to open $fn: $!\n";
|
|
warn "Writing $fn\n";
|
|
select $fh;
|
|
}
|
|
|
|
print <<'EOD';
|
|
package main;
|
|
|
|
use 5.010;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use File::Spec;
|
|
use Test::More 0.88; # Because of done_testing();
|
|
|
|
EOD
|
|
|
|
print <<"EOD";
|
|
# NOTE: This file is generated by $0.
|
|
# Any edits made to it will be lost the next time it is regenerated.
|
|
# Caveat coder.
|
|
|
|
EOD
|
|
|
|
print <<'EOD';
|
|
my $dir = ( File::Spec->splitpath( $0 ) )[1];
|
|
my $script = File::Spec->catfile( $dir, 'roulette.pl' );
|
|
{
|
|
# Modern Perls do not have . in @INC, but we need it there to load a
|
|
# relative path.
|
|
local @INC = ( File::Spec->curdir(), @INC );
|
|
require $script; # Load game as module
|
|
}
|
|
|
|
EOD
|
|
|
|
my $spin;
|
|
my $name;
|
|
foreach ( `$opt{program} @{[ $munged->filename() ]}` ) {
|
|
s/\N{U+1D}/ /smxg; # Artifact of the BASIC I'm using.
|
|
s/ \s+ \z //smx;
|
|
s/ \A \s+ //smx;
|
|
if ( $_ eq '' ) {
|
|
# Ignore empty lines.
|
|
} elsif ( m/ \A SPIN \s* ( [0-9]+ ) /smx ) {
|
|
$spin = $1 - 1; # BASIC is 1-based, but Perl is 0-based
|
|
} elsif ( m/ \A YOU \s+ WIN \s* ( [0-9]+ ) \s*
|
|
DOLLARS \s+ ON \s+ BET \s* ( [0-9]+ ) /smx ) {
|
|
say "is payout( $spin, $2 ), $1, 'Spin $spin ($name), bet $2 pays $1';";
|
|
} elsif ( m/ \A YOU \s+ LOSE \s* ( [0-9]+ ) \s*
|
|
DOLLARS \s+ ON \s+ BET \s* ( [0-9]+ ) /smx ) {
|
|
say "is payout( $spin, $2 ), -$1, 'Spin $spin ($name), bet $2 pays -$1';";
|
|
} elsif ( m/ \A \s* ( [0-9]+ ) (?: \s* ( [[:alpha:]]+ ) )? \z /smx ) {
|
|
$name = $2 ? sprintf( '%d %s', $1, ucfirst lc $2 ) : $1;
|
|
say "is format_spin( $spin ), '$name', 'Spin $spin is $name';";
|
|
} else {
|
|
die "Unexpected input $_";
|
|
}
|
|
}
|
|
|
|
print <<'EOD';
|
|
|
|
done_testing;
|
|
|
|
1;
|
|
|
|
# ex: set textwidth=72 :
|
|
EOD
|
|
|
|
sub find_basic {
|
|
# yabasic seems not to work
|
|
foreach my $prog ( qw{ basic cbmbasic } ) {
|
|
return $prog if can_run( $prog )
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
sub make_default_output {
|
|
( my $rslt = $0 ) =~ s/ [.] pl \z /.t/smx;
|
|
$rslt =~ s/ .* \b make- //smx;
|
|
return $rslt;
|
|
}
|
|
|
|
sub transcribe {
|
|
my ( $in_file, $in_handle, $out_handle, $first_line, $last_line ) = @_;
|
|
$last_line //= $first_line;
|
|
|
|
while ( <$in_handle> ) {
|
|
m/ \A \s* ( [0-9]+ )+ \s /smx
|
|
or next;
|
|
$1 < $first_line
|
|
and next;
|
|
say { $out_handle } sprintf '%04d REM BEGIN VERBATIM FROM %s',
|
|
$first_line - 10, $in_file;
|
|
print { $out_handle } $_;
|
|
last;
|
|
}
|
|
while ( <$in_handle> ) {
|
|
m/ \A \s* ( [0-9]+ )+ \s /smx
|
|
and $1 > $last_line
|
|
and last;
|
|
print { $out_handle } $_;
|
|
}
|
|
say { $out_handle } sprintf '%04d REM END VERBATIM FROM %s',
|
|
$last_line + 10, $in_file;
|
|
|
|
return;
|
|
}
|
|
|
|
__END__
|
|
|
|
=head1 TITLE
|
|
|
|
make-roulette-test.pl - Generate the tests for 75_Roulette/perl/roulette.pl
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
perl 75_Roulette/perl/make-roulette-test.pl
|
|
perl 75_Roulette/perl/make-roulette-test.pl --program mybasic
|
|
perl 75_Roulette/perl/make-roulette-test.pl --help
|
|
perl 75_Roulette/perl/make-roulette-test.pl --version
|
|
|
|
=head1 OPTIONS
|
|
|
|
<<< replace boiler plate >>>
|
|
|
|
=head2 --help
|
|
|
|
This option displays the documentation for this script. The script then
|
|
exits.
|
|
|
|
=head2 --output
|
|
|
|
--output fubar.t
|
|
|
|
This option specifies the output file. This needs to be in the same
|
|
directory as F<roulette.pl>, and defaults to that directory. A single
|
|
dash (C<'-'>) is special-cased to send the output to standard out.
|
|
|
|
The default is C<--output=test-roulette.t>.
|
|
|
|
=head2 --program
|
|
|
|
--program my_basic
|
|
|
|
This option specifies the name of your BASIC interpreter. This must be
|
|
the name of an executable file in your PATH (aliases do not work).
|
|
|
|
The default is the first-found in the list C<qw{ basic cbmbasic }>.
|
|
|
|
=head2 --version
|
|
|
|
This option displays the version of this script. The script then exits.
|
|
|
|
=head1 DETAILS
|
|
|
|
This Perl script generates F<roulette-test.t>, which tests
|
|
F<roulette.pl>. The latter is expected to be written as a modulino.
|
|
|
|
This script assumes that:
|
|
|
|
=over
|
|
|
|
=item * it is in the same directory as F<roulette.pl>;
|
|
|
|
=item * F<roulette.bas> is in the first-level subdirectory under the current directory;
|
|
|
|
=back
|
|
|
|
The generated test assumes that it is in the same directory as
|
|
F<roulette.pl>.
|
|
|
|
This script works by abstracting the internals of F<roulette.bas> and
|
|
wrapping them in a loop that generates all possible spins, and places
|
|
all possible bets on each spin. The generated BASIC is written to a
|
|
temporary file, and executed by a BASIC interpreter. The output is
|
|
parsed and used to generate the output.
|
|
|
|
Obviously there is some ad-hocery going on, and this script has only
|
|
been tested under C<cbmbasic>, which was what I had on hand.
|
|
|
|
B<Caveat:> the abstraction process is driven by BASIC line numbers. Any
|
|
change of these puts the ad-hocery at risk.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Thomas R. Wyant, III F<wyant at cpan dot org>
|
|
|
|
=head1 COPYRIGHT AND LICENSE
|
|
|
|
Copyright (C) 2022 by Thomas R. Wyant, III
|
|
|
|
This program is free software; you can redistribute it and/or modify it
|
|
under the same terms as Perl 5.10.0. For more details, see the Artistic
|
|
License 1.0 at
|
|
L<https://www.perlfoundation.org/artistic-license-10.html>, and/or the
|
|
Gnu GPL at L<http://www.gnu.org/licenses/old-licenses/gpl-1.0.txt>.
|
|
|
|
This program is distributed in the hope that it will be useful, but
|
|
without any warranty; without even the implied warranty of
|
|
merchantability or fitness for a particular purpose.
|
|
|
|
=cut
|
|
|
|
# ex: set textwidth=72 :
|