#!/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 POSIX qw{ strftime }; # Time formatting use Term::ReadLine; # Prompt and return user input our $VERSION = '0.000_01'; # A main() function is not usual in Perl scripts. I have installed one # here to make the script into a "modulino." The next line executes # main() if and only if caller() returns false. It will do this if we # were loaded by another Perl script but not otherwise. This was done so # I could test the payout and spin formatting logic. main() unless caller; sub main { print <<'EOD'; ROULETTE Creative Computing Morristown, New Jersey Welcome to the roulette table. EOD if ( get_yes_no( 'Do you want instructions' ) ) { print <<'EOD'; This is the betting layout (*=red) 1* 2 3* 4 5* 6 7* 8 9* 10 11 12* --------------- 13 14* 15 16* 17 18* 19* 20 21* 22 23* 24 --------------- 25* 26 27* 28 29 30* 31 32* 33 34* 35 36* --------------- 00 0 Types of bets: The numbers 1 to 36 signify a straight bet on that number. These pay off 35:1 The 2:1 bets are: 37) 1-12 40) first column 38) 13-24 41) second column 39) 25-36 42) third column The even money bets are: 43) 1-18 46) odd 44) 19-36 47) red 45) even 48) black 49) 0 and 50) 00 pay off 35:1 Note: 0 and 00 do not count under any bets except their own. When I ask for each bet, type the number and the amount, separated by a comma. For example: to bet $500 on black, type 48,500 when I ask for a bet. The minimum bet is $5, the maximum is $500. EOD } my $P = 1000; my $D = 100000.; while ( 1 ) { # Iterate indefinitely my $Y = get_input( 'How many bets? ', sub { m/ \A [0-9]+ \z /smx && $ARG > 0 && $ARG <= 50 }, "Please enter a positive integer no greater than 50\n", ); my @B; my @T; foreach my $C ( 1 .. $Y ) { my ( $X, $Z ) = split qr< , >smx, get_input( "Number $C: ", sub { m/ \A ( [0-9]+ ) , ( [0-9]+ ) \z /smx && $1 > 0 && $1 <= 50 && $2 >= 5 && $2 <= 500 }, "Please enter two comma-separated positive numbers\n", ); if ( $B[$X] ) { say 'You made that bet once already, dum-dum.'; redo; } $B[$X] = $Z; # BASIC does $B[$C] = $Z $T[$C] = $X; } print <<'EOD'; Spinning ... EOD my $S = int rand 38; # Zero-based, versus 1-based in BASIC say format_spin( $S ); say ''; foreach my $C ( 1 .. $Y ) { my $X = $T[$C]; my $payout = payout( $S, $X ) * $B[$X]; $D -= $payout; $P += $payout; if ( $payout > 0 ) { say "You win $payout dollars on bet $C"; } else { $payout = -$payout; say "You lose $payout dollars on bet $C"; } } say "Totals\tMe\tYou"; say "\t$D\t$P"; say ''; last unless get_yes_no( 'Again' ); } say ''; if ( $P > 0 ) { my $B = get_input( 'To whom shall I make out the check? ', ); my $check_number = 1000 + int rand 9000; my $todays_date = strftime( '%B %d, %Y', localtime ); print <<"EOD"; ------------------------------------------------------------ Check number $check_number $todays_date Pay to the order of ------ $B ----- \$$P The Memory Bank of New York The Computer ---------X----- ------------------------------------------------------------------------------- Come back soon! EOD } else { print <<'EOD'; Thanks for your money. I'll use it to buy a solid gold roulette wheel EOD } } { # Define the kind of each possible spin. 0 is '0' or '00', 1 is # black, and 2 is red. We assign the values in a BEGIN block because # execution never actually reaches this point in the script. my @kind; BEGIN { @kind = ( 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 1, 2, 1, 2, 1, 2, 1, 2, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 1, 2, 1, 2, 1, 2, 1, 2, 0, 0 ); } # Convert the spin (0-37) to its name on the wheel. sub format_spin { my ( $number ) = @_; state $format = [ sub { '0' x ( $_[0] - 35 ) }, sub { sprintf '%s Black', $_[0] + 1 }, sub { sprintf '%s Red', $_[0] + 1 }, ]; return $format->[$kind[$number]]( $number ); } # Compute the payout given the spin (0-37) and the bet (1-50). sub payout { my ( $number, $bet ) = @_; # We compute the payout on '0' and '00' directly, since under # our rules they are only eligible for the 35-to-1 bet. $kind[$number] or return $number == $bet - 49 + 36 ? 35 : -1; --$bet; # #bet is 1-based coming in # Dispatch table for computing the payout for spins 0-36. state $payout = [ ( sub { $_[0] == $_[1] ? 35 : -1 } ) x 36, ( sub { int( $_[0] / 12 ) == $_[1] - 36 ? 2 : -1 } ) x 3, ( sub { $_[0] % 3 == $_[1] - 39 ? 2 : -1 } ) x 3, ( sub { int( $_[0] / 18 ) == $_[1] - 42 ? 1 : -1 } ) x 2, ( sub { $_[0] % 2 == 45 - $_[1] ? 1 : -1 } ) x 2, ( sub { $kind[$_[0]] == 48 - $_[1] ? 1 : -1 } ) x 2, ( sub { -1 } ) x 2, # Bet on '0' or '00' loses ]; return $payout->[$bet]->( $number, $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 roulette - Play the game 'Roulette' from Basic Computer Games =head1 SYNOPSIS roulette.pl =head1 DETAILS This Perl script is a port of roulette, which is the 75th entry in Basic Computer Games. The main internal changes are converting the roulette slot numbering to 0-based and replacing most of the payout logic with a dispatch table. These changes were tested for correctness against the original BASIC. =head1 PORTED BY 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 expandtab tabstop=4 textwidth=72 :