#!/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 :
