diff --git a/90_Tower/perl/tower.pl b/90_Tower/perl/tower.pl new file mode 100755 index 00000000..f9258eea --- /dev/null +++ b/90_Tower/perl/tower.pl @@ -0,0 +1,381 @@ +#!/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 Term::ReadLine; # Prompt and return user input + +our $VERSION = '0.000_01'; + +# Manifest constant representing the maximum number of disks. We can +# change this within limits. It needs to be at least 3 or the +# explanatory text will contain negative numbers. There is no known +# upper limit, though if it is more than 10 the output lines can be more +# than 80 columns, and if it is more than 49 the disk numbers will be +# more than two digits, which will cause output lines not to align +# properly. +use constant MAX_DISKS => 7; + +print <<'EOD'; + TOWERS + Creative Computing Morristown, New Jersey + + +EOD + +while ( 1 ) { # Iterate until something makes us stop. + + print <<'EOD'; +Towers of Hanoi Puzzle. + +You must transfer the disks from the left to the right +Tower, one at a time, never putting a larger disk on a +smaller disk. + +EOD + + # Get the desired number of disks to work with. + my $size = get_input( + + # Manifest constants do not interpolate into strings. This can + # be worked around using the @{[ ... ]} construction, which + # interpolates any expression. + "How many disks do you want to move (@{[ MAX_DISKS ]} is max)? ", + + sub { + + # Accept any response which is an integer greater than zero + # and less than or equal to the maximum number of disks. + # NOTE that 'and' performs the same operation as &&, but + # binds much more loosely. + return m/ \A [0-9]+ \z /smx && + $ARG > 0 && + $ARG <= MAX_DISKS; + }, + + 3, + "Sorry, but I can't do that job for you.\n", # Warning + <<'EOD', +All right, wise guy, if you can't play the game right, I'll +just take my puzzle and go home. So long. +EOD + ); + + # Expressions can be interpolated using @{[ ... ]} + print <<"EOD"; +In this program, we shall refer to disks by numerical code. +3 will represent the smallest disk, 5 the next size, +7 the next, and so on, up to @{[ MAX_DISKS * 2 + 1 ]}. If you do the puzzle with +2 disks, their code names would be @{[ MAX_DISKS * 2 - 1 ]} and @{[ MAX_DISKS * 2 + 1 ]}. With 3 disks +the code names would be @{[ MAX_DISKS * 2 - 3 ]}, @{[ MAX_DISKS * 2 - 1 ]} and @{[ MAX_DISKS * 2 + 1 ]}, etc. The needles +are numbered from left to right, 1 to 3. We will +start with the disks on needle 1, and attempt to move them +to needle 3. + + +Good luck! + +EOD + + # Compute the legal disk numbers for this puzzle. The expression + # reads right to left thus: + # * The .. operator generates the integers between and including + # its end points, that is, from MAX_DISKS + 1 - $size to + # MAX_DISKS, inclusive. + # * map { .. } calls the block once for each of its arguments. + # The value of the argument appears in the topic variable $ARG, + # and the result of the block is returned. + # * The list generated by the map {} is assigned to array + # @legal_disks. + my @legal_disks = map { $ARG * 2 + 1 } + MAX_DISKS + 1 - $size .. MAX_DISKS; + + # Generate the board. This is an array of needles, indexed from + # zero. Each needle is represented by a reference to an array + # containing the disks on that needle, bottom to top. + my @board = ( + [ reverse @legal_disks ], + [], + [] + ); + + display( \@board ); # Display the initial board. + + my $moves = 0; # Move counter. + + while ( 1 ) { # Iterate until something makes us stop. + my $disk = get_input( + 'Which disk would you like to move? ', + sub { + # Accept any odd integer in the required range. + # NOTE that 'and' performs the same operation as &&, but + # binds much more loosely. + return m/ \A [0-9]+ \z /smx && + $ARG % 2 && + $ARG >= ( MAX_DISKS + 1 - $size ) * 2 + 1 && + $ARG <= MAX_DISKS * 2 + 1; + }, + 3, + do { # Compound statement and scope for 'local' + + # We want to interpolate @legal_disks into our warning. + # Interpolation of an array places $LIST_SEPARATOR + # between the elements of the array. The default is ' ', + # but we want ', '. We use 'local' to restrict the + # change to the current block and code called by it. + # Failure to localize the change can cause Spooky Action + # at a Distance. + local $LIST_SEPARATOR = ', '; + + "Illegal entry... You may only type @legal_disks\n"; + }, + "Stop wasting my time. Go bother someone else.\n", + ); + + # Return the number (from zero) of the needle which has the + # desired disk on top. If the desired disk is not found, we got + # undef back. In this case we redo the innermost loop. + redo unless defined( my $from = find_disk( $disk, \@board ) ); + + # Find out where the chosen disk goes. + # NOTE that unlike the BASIC implementation, we require the + # needle to be moved. + my $to = get_input( + 'Place disk on which needle? ', + sub { + # Accept integers 1 through 3, but not the current + # location of the disk + return m/ \A [0-9]+ \z /smx && + $ARG > 0 && + $ARG <= 3 && + $ARG != $from + 1; + }, + 2, + <<'EOD', +I'll assume you hit the wrong key this time. But watch it, +I only allow one mistake. +EOD + <<'EOD', +I tried to warn you, but you wouldn't listen. +Bye bye, big shot. +EOD + ) - 1; + + # Check for placing a larger disk on a smaller one. The check is + # that the destination needle has something on it (an empty + # array is false in Boolean context) and that the destination + # needle's top disk ([-1] selects the last element of an array) + # is smaller than the source needle's disk. + if ( @{ $board[$to] } && $board[$to][-1] < $board[$from][-1] ) { + warn <<'EOD'; +You can't place a larger disk on top of a smaller one, +It might crush it! +EOD + redo; + } + + # Remove the selected disk from its needle, and place it on the + # destination needle. + push @{ $board[$to] }, pop @{ $board[$from] }; + + $moves++; # Count another move. + + display( \@board ); # Display the current board. + + # If all the disks are on the last needle, we are done. + if ( @{ $board[2] } == $size ) { + + # Print a success message + print <<"EOD"; +Congratulations! + +You have performed the task in $moves moves. + +EOD + last; # Exit the innermost loop. + + # If the maximum allowed moves have been exceeded + } elsif ( $moves >= 2 ** MAX_DISKS ) { + + # Warn + warn <<"EOD"; +Sorry, but I have orders to stop if you make more than +$moves moves. +EOD + + last; # Exit the innermost loop. + } + } + + say ''; + get_input( + 'Try again? [y/N]: ', + sub { + exit if $ARG eq '' || m/ \A n /smxi; + return m/ \A y /smxi; + }, + ~0, # The 1's complement of 0 = largest possible integer + "Please respond 'y' or 'n'\n", + ); +} + +# Display the board, which is passed in as a reference. +sub display { + my ( $board ) = @_; + say ''; + + # Use a manifest constant for an empty needle. This is global + # despite its appearing to be nested in the subroutine. Perl uses + # 'x' as its string replication operator. The initial 4 blanks + # accommodate the disk number and spacing between needles. + use constant EMPTY_NEEDLE => ' ' x 4 . ' ' x MAX_DISKS . '|' . + ' ' x MAX_DISKS; + + # Iterate over the rows to be printed. + foreach my $inx ( reverse 0 .. MAX_DISKS ) { + + my $line; # Line buffer. + + # Iterate over needles. + foreach my $col ( 0 .. 2 ) { + + # If this position on the needle is occupied + if ( my $disk_num = $board->[$col][$inx] ) { + + # Compute the width of a half disk + my $half_width = ( $disk_num - 1 ) / 2; + + # Compute the graphic for the half disk. Perl uses 'x' + # as its string replication operator. + my $half_disk = '*' x $half_width; + + # Append the disk to the line. The inner sprintf() does + # most of the work; the outer simply pads the graphic to + # the required total width. + $line .= sprintf( '%*s', -( MAX_DISKS * 2 + 5 ), + sprintf( '%*d %s|%s', MAX_DISKS + 3 - $half_width, + $disk_num, $half_disk, $half_disk ) ); + + # Else this position is not occupied + } else { + + # So just append the empty needle. + $line .= EMPTY_NEEDLE; + } + } + + # Remove white space at the end of the line + $line =~ s/ \s+ \z //smx; + + # Display the line + say $line; + } + { # Display the needle numbers + my $line; + foreach my $col ( 0 .. 2 ) { + $line .= sprintf '%*d%*s', MAX_DISKS + 5, $col + 1, + MAX_DISKS, ' '; + } + $line =~ s/ \s+ \z //smx; + say $line; + } + + say ''; # Empty line + + return; +} + +# Find the named disk. The arguments are the disk number (which is +# assumed valid) and a reference to the board. If the disk is found on +# the top of a needle, the needle's index (from zero) is returned. +# Otherwise a warning is issued and undef is returned. +sub find_disk { + my ( $disk, $board ) = @_; + foreach my $inx ( 0 .. 2 ) { + @{ $board->[$inx] } # If the needle is occupied + and $disk == $board->[$inx][-1] # and we want its topmost + and return $inx; # return needle index + } + + # Since we assume the disk number is valid but we did not find it, + # it must not be the topmost disk. + warn "That disk is below another one. Make another choice.\n"; + + return undef; +} + +# Input subroutine. The arguments are: +# * The prompt. +# * Validation code. This recieves the input in the topic variable $ARG, +# and returns a true value if the validation passed, and a false value +# if it failed. +# * The maximum number of tries before dying. +# * The warning message for a validation failure, with trailing "\n". +# * The error message when the number of tries is exceeded, with +# trailing "\n". +# The return is the valid input. We exit if end-of-file is reached, +sub get_input { + my ( $prompt, $validate, $tries, $warning, $error ) = @_; + + # Instantiate the readline object. A state variable is only + # initialized once. + state $term = Term::ReadLine->new( 'tower' ); + + while ( 1 ) { # Iterate until something makes us stop. + + # The input gets read into the localized topic variable. If it + # is undefined, it signals end-of-file, so we exit. + exit unless defined( local $ARG = $term->readline( $prompt ) ); + + # Call the validation code. If it returns a true value, we + # return our input. + return $ARG if $validate->(); + + # Die if we are out of retries. In Perl, 0 is false and all + # other integers are true. + die $error unless --$tries; + + # Warn. + warn $warning; + } +} + +__END__ + +=head1 TITLE + +tower.pl - Play the game 'tower' from Basic Computer Games + +=head1 SYNOPSIS + + tower.pl + +=head1 DETAILS + +This Perl script is a port of C, which is the 90th entry in Basic +Computer Games. + +=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 :