mirror of
https://github.com/coding-horror/basic-computer-games.git
synced 2025-12-12 15:50:20 -08:00
Port 88_Slots to Perl.
I have made a change in the payout table versus the BASIC, since I presume the failure to pay a double on LEMON CHERRY LEMON is a bug. See the documentation in the module for why.
This commit is contained in:
Tom Wyant
238
80_Slots/perl/slots.pl
Executable file
238
80_Slots/perl/slots.pl
Executable file
@@ -0,0 +1,238 @@
|
||||
#!/usr/bin/env perl
|
||||
|
||||
use 5.010; # To get 'state' and 'say'
|
||||
|
||||
use strict; # Require explicit declaration of variables
|
||||
use warnings; # Enable optional compiler warnings
|
||||
|
||||
use English; # Use more friendly names for Perl's magic variables
|
||||
use List::Util qw{ shuffle }; # Shuffle an array.
|
||||
use Scalar::Util qw{ looks_like_number };
|
||||
use Term::ReadLine; # Prompt and return user input
|
||||
|
||||
our $VERSION = '0.000_01';
|
||||
|
||||
print <<'EOD';
|
||||
SLOTS
|
||||
Creative Computing Morristown, New Jersey
|
||||
|
||||
|
||||
|
||||
You are in the H&M casino, in front of one of our
|
||||
one-arm bandits. Bet from $1 to $100.
|
||||
To pull the arm, punch the return key after making your bet.
|
||||
EOD
|
||||
|
||||
my $winnings = 0; # Winnings
|
||||
|
||||
while ( 1 ) { # Iterate indefinitely
|
||||
|
||||
say '';
|
||||
|
||||
my $bet = get_input( 'Your bet? ',
|
||||
sub { m/ \A [0-9]+ \z /smx },
|
||||
'Please enter a whole number between 0 and 100',
|
||||
);
|
||||
if ( $bet > 100 ) {
|
||||
say 'The house limit is $100';
|
||||
next;
|
||||
}
|
||||
if ( $bet < 1 ) {
|
||||
say 'The minimum bet is $1';
|
||||
next;
|
||||
}
|
||||
|
||||
say "\a" x 10;
|
||||
my $reel_x = int( 6 * rand() );
|
||||
my $reel_y = int( 6 * rand() );
|
||||
my $reel_z = int( 6 * rand() );
|
||||
foreach my $column ( $reel_x, $reel_y, $reel_z ) {
|
||||
state $symbol = [ qw{ Bar Bell Orange Lemon Plum Cherry } ];
|
||||
print $symbol->[$column], "\a" x 5, ' ';
|
||||
}
|
||||
|
||||
use constant YOU_WON => 'You won!';
|
||||
use constant YOU_LOST => 'You lost.';
|
||||
|
||||
say '';
|
||||
if ( $reel_x == $reel_y ) {
|
||||
if ( $reel_y == $reel_z ) {
|
||||
if ( $reel_z ) {
|
||||
say '** TOP DOLLAR **';
|
||||
$winnings += 11 * $bet;
|
||||
} else {
|
||||
say '*** JACKPOT ***';
|
||||
$winnings += 101 * $bet;
|
||||
}
|
||||
say YOU_WON;
|
||||
} elsif ( $reel_y ) {
|
||||
$winnings += double( $bet );
|
||||
} else {
|
||||
$winnings += double_bar( $bet );
|
||||
}
|
||||
} elsif ( $reel_x == $reel_z ) {
|
||||
if ( $reel_z ) {
|
||||
$winnings += double( $bet );
|
||||
# NOTE that the below code is what is actually implemented
|
||||
# in the basic, but it is implemented strangely enough (a
|
||||
# GOTO a line that contains a test that, if I understand the
|
||||
# control flow, must fail) that I wonder if it is an error.
|
||||
# I know nothing about slot machines, but research suggests
|
||||
# the payoff table is fairly arbitrary. The code above makes
|
||||
# code above makes the game orthogonal.
|
||||
# $winnings += you_lost( $bet );
|
||||
} else {
|
||||
$winnings += double_bar( $bet );
|
||||
}
|
||||
} elsif ( $reel_y == $reel_z ) {
|
||||
if ( $reel_z ) {
|
||||
$winnings += double( $bet );
|
||||
} else {
|
||||
$winnings += double_bar( $bet );
|
||||
}
|
||||
} else {
|
||||
$winnings += you_lost( $bet );
|
||||
}
|
||||
|
||||
say 'Your standings are $', $winnings;
|
||||
|
||||
last unless get_yes_no( 'Again' );
|
||||
|
||||
}
|
||||
|
||||
if ( $winnings < 0 ) {
|
||||
say 'Pay up! Please leave your money on the terminal.';
|
||||
} elsif ( $winnings > 0 ) {
|
||||
say 'Collect your winnings from the H&M cashier.';
|
||||
} else {
|
||||
say 'Hey, you broke even.';
|
||||
}
|
||||
|
||||
sub double {
|
||||
my ( $bet ) = @_;
|
||||
say 'DOUBLE!';
|
||||
say YOU_WON;
|
||||
return 3 * $bet;
|
||||
}
|
||||
|
||||
sub double_bar {
|
||||
my ( $bet ) = @_;
|
||||
say '* DOUBLE BAR *';
|
||||
say YOU_WON;
|
||||
return 6 * $bet;
|
||||
}
|
||||
|
||||
sub you_lost {
|
||||
my ( $bet ) = @_;
|
||||
say YOU_LOST;
|
||||
return -$bet;
|
||||
}
|
||||
|
||||
# Get input from the user. The arguments are:
|
||||
# * The prompt
|
||||
# * A reference to validation code. This code receives the response in
|
||||
# $ARG and returns true for a valid response.
|
||||
# * A warning to print if the response is not valid. This must end in a
|
||||
# return.
|
||||
# The first valid response is returned. An end-of-file terminates the
|
||||
# script.
|
||||
sub get_input {
|
||||
my ( $prompt, $validate, $warning ) = @ARG;
|
||||
|
||||
# If no validator is passed, default to one that always returns
|
||||
# true.
|
||||
$validate ||= sub { 1 };
|
||||
|
||||
# Create the readline object. The 'state' causes the variable to be
|
||||
# initialized only once, no matter how many times this subroutine is
|
||||
# called. The do { ... } is a compound statement used because we
|
||||
# need to tweak the created object before we store it.
|
||||
state $term = do {
|
||||
my $obj = Term::ReadLine->new( 'reverse' );
|
||||
$obj->ornaments( 0 );
|
||||
$obj;
|
||||
};
|
||||
|
||||
while ( 1 ) { # Iterate indefinitely
|
||||
|
||||
# Read the input into the topic variable, localized to prevent
|
||||
# Spooky Action at a Distance. We exit on undef, which signals
|
||||
# end-of-file.
|
||||
exit unless defined( local $ARG = $term->readline( $prompt ) );
|
||||
|
||||
# Return the input if it is valid.
|
||||
return $ARG if $validate->();
|
||||
|
||||
# Issue the warning, and go around the merry-go-round again.
|
||||
warn $warning;
|
||||
}
|
||||
}
|
||||
|
||||
# Get a yes-or-no answer. The argument is the prompt, which will have
|
||||
# '? [y/n]: ' appended. The donkey work is done by get_input(), which is
|
||||
# requested to validate the response as beginning with 'y' or 'n',
|
||||
# case-insensitive. The return is a true value for 'y' and a false value
|
||||
# for 'n'.
|
||||
sub get_yes_no {
|
||||
my ( $prompt ) = @ARG;
|
||||
state $map_answer = {
|
||||
n => 0,
|
||||
y => 1,
|
||||
};
|
||||
my $resp = lc get_input(
|
||||
"$prompt? [y/n]: ",
|
||||
sub { m/ \A [yn] /smxi },
|
||||
"Please respond 'y' or 'n'\n",
|
||||
);
|
||||
return $map_answer->{ substr $resp, 0, 1 };
|
||||
}
|
||||
|
||||
__END__
|
||||
|
||||
=head1 TITLE
|
||||
|
||||
slots - Play the game 'Slots' from Basic Computer Games
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
slots.pl
|
||||
|
||||
=head1 DETAILS
|
||||
|
||||
This Perl script is a port of C<slots>, which is the 80th entry in Basic
|
||||
Computer Games.
|
||||
|
||||
I know nothing about slot machines, and my research into them says to me
|
||||
that the payout tables can be fairly arbitrary. But I have taken the
|
||||
liberty of deeming the BASIC program's refusal to pay on LEMON CHERRY
|
||||
LEMON a bug, and made that case a double.
|
||||
|
||||
My justification for this is that at the point where the BASIC has
|
||||
detected the double in the first and third reels it has already detected
|
||||
that there is no double in the first and second reels. After the check
|
||||
for a bar (and therefore a double bar) fails it goes back and checks for
|
||||
a double on the second and third reels. But we know this check will
|
||||
fail, since the check for a double on the first and second reels failed.
|
||||
So if a loss was intended at this point, why not just call it a loss?
|
||||
|
||||
=head1 PORTED BY
|
||||
|
||||
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 expandtab tabstop=4 textwidth=72 :
|
||||
Reference in New Issue
Block a user