#!/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, 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. =head2 --version This option displays the version of this script. The script then exits. =head1 DETAILS This Perl script generates F, which tests F. The latter is expected to be written as a modulino. This script assumes that: =over =item * it is in the same directory as F; =item * F is in the first-level subdirectory under the current directory; =back The generated test assumes that it is in the same directory as F. This script works by abstracting the internals of F 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, which was what I had on hand. B 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 =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, and/or the Gnu GPL at L. 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 :