diff --git a/95_Weekday/perl/README.md b/95_Weekday/perl/README.md index e69c8b81..ac8ee399 100644 --- a/95_Weekday/perl/README.md +++ b/95_Weekday/perl/README.md @@ -1,3 +1,20 @@ Original source downloaded [from Vintage Basic](http://www.vintage-basic.net/games.html) Conversion to [Perl](https://www.perl.org/) + +I have replaced the manual date logic with Perl built-ins to the extent +possible. Unfortunately the kind of date math involved in the "time +spent doing ..." functionality is not well-defined, so I have been +forced to retain the original logic here. Sigh. + +You can use any punctuation character you please in the date +input. So something like 2/29/2020 is perfectly acceptable. + +It would also have been nice to produce a localized version that +supports day/month/year or year-month-day input, but that didn't happen. + +Also nice would have been language-specific output -- especially if it +could have accommodated regional differences in which day of the week or +month is unlucky. + +Tom Wyant diff --git a/95_Weekday/perl/weekday.pl b/95_Weekday/perl/weekday.pl new file mode 100755 index 00000000..e1820af6 --- /dev/null +++ b/95_Weekday/perl/weekday.pl @@ -0,0 +1,249 @@ +#!/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 +use Time::Local qw{ timelocal }; # date-time to epoch +# FIXME timelocal() is too smart for its own good in the interpretation +# of years, and caused a bunch of Y2020 problems in Perl code that used +# it. I believe that this script avoids these problems (which only occur +# if the year is less than 1000), but it is probably safer in general to +# use timelocal_modern() or timelocal_posix(). These are also exported +# by Time::Local, but only by versions 1.28 and 1.30 respectively. This +# means that they only come (by default) with Perl 5.30 and 5.34 +# respectively. Now, Time::Local is a dual-life module, meaning it can +# be upgraded from the version packaged with older Perls. But I did not +# want to assume that it HAD been upgraded. Caveat coder. +use Time::Piece; # O-O epoch to date-time, plus formatting + +our $VERSION = '0.000_01'; + +print <<'EOD'; + + WEEKDAY + Creative Computing Morristown, New Jersey + + + +WEEKDAY is a computer demonstration that +gives facts about a date of interest to you. + +EOD + +my $now = localtime; +my $default_date = join ',', map { $now->$_() } qw{ mon mday year }; + +my $today = get_date( + "Enter today's date in the form month,day,year (default: $default_date): ", + "Please enter month,day,year or return for default\n", + $default_date, +); + +my $birthday = get_date( + 'Ender day of birth (or other day of interest): ', + "Please enter month,day,year\n", +); + +say ''; +printf "%d/%d/%d %s a %s\n", $birthday->mon, $birthday->mday, + $birthday->year, tense( $today, $birthday), + ( $birthday->mday == 13 && $birthday->wday == 6 ) ? + $birthday->fullday . ' the thirteenth --- Beware!' : + $birthday->fullday . '.'; + +if ( $birthday->epoch <= $today->epoch ) { + + say '*** Happy Birthday! ***' + if $birthday->mon == $today->mon && + $birthday->mday == $today->mday; + + print <<'EOD'; + Years Months Days + ----- ------ ---- +EOD + + my @delta = map { $today->$_() - $birthday->$_() } qw{ year mon mday }; + if ( $delta[2] < 0 ) { + $delta[2] += 30; + $delta[1] -= 1; + } + if ( $delta[1] < 0 ) { + $delta[1] += 12; + $delta[0] -= 1; + } + my @residue = @delta; + + my $delta_days = 365 * $delta[0] + 30 * $delta[1] + $delta[2]; + + display_ymd( 'Your age (if birthdate)', compute_ymd( $delta_days ) ); + display_ymd( 'You have slept', compute_ymd( $delta_days, 0.35, + \@residue ) ); + display_ymd( 'You have eaten', compute_ymd( $delta_days, 0.17, + \@residue ) ); + display_ymd( + $residue[0] > 9 ? 'You have worked/played' : + $residue[0] > 3 ? 'You have played/studied' : + 'You have played', + compute_ymd( $delta_days, 0.23, + \@residue ) ); + display_ymd( 'You have relaxed', \@residue ); + + say ''; + say "\t\t*** You may retire in @{[ $birthday->year + 65 ]} ***"; +} + +say ''; + +sub compute_ymd { + my ( $delta_days, $fract, $residue ) = @ARG; + my $days = defined $fract ? int ( $delta_days * $fract ) : $delta_days; + my $years = int( $days / 365 ); + $days -= $years * 365; + my $months = int( $days / 30 ); + $days -= $months * 30; + + if ( $residue ) { + $residue->[2] -= $days; + if ( $residue->[2] < 0 ) { + $residue->[2] += 30; + $residue->[1] -= 1; + } + $residue->[1] -= $months; + if ( $residue->[1] < 0 ) { + $residue->[1] += 12; + $residue->[0] -= 1; + } + $residue->[0] -= $years; + } + + return [ $years, $months, $days ]; +} + +sub display_ymd { + my ( $label, $ymd ) = @ARG; + printf "%-24s%4d%6d%8d\n", $label, @{ $ymd }; + return; +} + +sub get_date { + my ( $prompt, $warning, $default ) = @ARG; + my ( $month, $day, $year ) = split qr< [[:punct:]] >smx, get_input( + $prompt, + sub { + return 0 unless m/ \A (?: [0-9]+ [[:punct:]] ){2} ( [0-9]+ ) \z /smx; + return 1 if $1 >= 1582; + warn "Not prepared to give day of week prior to MDLXXXII.\n"; + return 0; + }, + $warning, + $default, + ); + return localtime timelocal( 0, 0, 0, $day, $month - 1, $year ); +} + +sub tense { + my ( $today, $birthday ) = @ARG; + my $cmp = $birthday->epoch <=> $today->epoch + or return 'is'; + return $cmp < 0 ? 'was' : 'will be'; +} + +# 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. +# * A default to return if the user simply presses . +# The first valid response is returned. An end-of-file terminates the +# script. +sub get_input { + my ( $prompt, $validate, $warning, $default ) = @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 default if it exists AND we got an empty line + return $default if defined( $default ) && $ARG eq ''; + + # Return the input if it is valid. + return $ARG if $validate->(); + + # Issue the warning, and go around the merry-go-round again. + warn $warning; + } +} + +__END__ + +=head1 TITLE + +weekday - Play the game 'Weekday' from Basic Computer Games + +=head1 SYNOPSIS + + weekday.pl + +=head1 DETAILS + +This Perl script is a port of weekday.bas, which is the 95th entry in +Basic Computer Games. + +I have replaced the manual date logic with Perl built-ins to the extent +possible. Unfortunately the kind of date math involved in the "time +spent doing ..." functionality is not well-defined, so I have been +forced to retain the original logic here. Sigh. + +You can use any punctuation character you please in the date +input. So something like 2/29/2020 is perfectly acceptable. + +It would also have been nice to produce a localized version that +supports day/month/year or year-month-day input, but that didn't happen. + +Also nice would have been language-specific output -- especially if it +could have accommodated regional differences in which day of the week or +month is unlucky. + +=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 :