From a418099b1e9b4e3f76f5c92a3027672d7f0db4bb Mon Sep 17 00:00:00 2001 From: PerlMonk Athanasius Date: Fri, 3 Apr 2020 21:14:53 -0700 Subject: Perl & Raku solutions to Tasks 1 & 2 of the Perl Weekly Challenge #054 On branch branch-for-challenge-054 Changes to be committed: new file: challenge-054/athanasius/perl/ch-1.pl new file: challenge-054/athanasius/perl/ch-2.pl new file: challenge-054/athanasius/raku/ch-1.raku new file: challenge-054/athanasius/raku/ch-2.raku --- challenge-054/athanasius/perl/ch-1.pl | 94 +++++++++++++++ challenge-054/athanasius/perl/ch-2.pl | 196 ++++++++++++++++++++++++++++++++ challenge-054/athanasius/raku/ch-1.raku | 81 +++++++++++++ challenge-054/athanasius/raku/ch-2.raku | 154 +++++++++++++++++++++++++ 4 files changed, 525 insertions(+) create mode 100644 challenge-054/athanasius/perl/ch-1.pl create mode 100644 challenge-054/athanasius/perl/ch-2.pl create mode 100644 challenge-054/athanasius/raku/ch-1.raku create mode 100644 challenge-054/athanasius/raku/ch-2.raku (limited to 'challenge-054') diff --git a/challenge-054/athanasius/perl/ch-1.pl b/challenge-054/athanasius/perl/ch-1.pl new file mode 100644 index 0000000000..dbe74ce474 --- /dev/null +++ b/challenge-054/athanasius/perl/ch-1.pl @@ -0,0 +1,94 @@ +#!perl + +################################################################################ +=comment + +Perl Weekly Challenge 054 +========================= + +Task #1 +*kth Permutation Sequence* + +Write a script to accept two integers *n (>=1)* and *k (>=1)*. It should print +the *kth permutation* of *n integers*. For more information, please follow the +[ https://en.wikipedia.org/wiki/Permutation#k-permutations_of_n |wiki page]. + +For example, *n=3* and *k=4*, the possible permutation sequences are listed +below: + + 123 + 132 + 213 + 231 + 312 + 321 + +The script should print the *4th* permutation sequence *231*. + +=cut +################################################################################ + +#--------------------------------------# +# Copyright © 2020 PerlMonk Athanasius # +#--------------------------------------# + +use strict; +use warnings; +use Algorithm::Loops qw( NextPermuteNum ); +use Const::Fast; +use Scalar::Util::Numeric qw( isint ); + +const my $USAGE => + "USAGE: perl $0 - Find the Kth permutation of the sequence 1 .. N\n" . + " where N and K are integers >= 1\n"; + +#------------------------------------------------------------------------------- +BEGIN +#------------------------------------------------------------------------------- +{ + $| = 1; + print "\n"; +} + +#=============================================================================== +MAIN: +#=============================================================================== +{ + print "Challenge 054, Task #1: kth Permutation Sequence (Perl)\n\n"; + + scalar @ARGV == 2 or die "ERROR: Incorrect number of arguments\n$USAGE"; + + my ($n, $k) = @ARGV; + + isint($n) && $n > 0 or die "ERROR: '$n' is not a valid value for N\n$USAGE"; + isint($k) && $k > 0 or die "ERROR: '$k' is not a valid value for K\n$USAGE"; + + my @list = 1 .. $n; + my $sep = ($n < 10) ? '' : ' '; + + NextPermuteNum( @list ) for 2 .. $k; + + printf "The %s permutation of %s is %s\n", + ordinal($k), join($sep, 1 .. $n), join($sep, @list); +} + +#------------------------------------------------------------------------------- +sub ordinal +#------------------------------------------------------------------------------- +{ + my ($n) = @_; + my $suffix = 'th'; + my $dig1 = int(($n % 100) / 10); + + unless ($dig1 == 1) + { + my $dig0 = $n % 10; + $suffix = $dig0 == 1 ? 'st' : + $dig0 == 2 ? 'nd' : + $dig0 == 3 ? 'rd' : 'th'; + } + + return $n . $suffix; +} + +################################################################################ diff --git a/challenge-054/athanasius/perl/ch-2.pl b/challenge-054/athanasius/perl/ch-2.pl new file mode 100644 index 0000000000..4b75646b73 --- /dev/null +++ b/challenge-054/athanasius/perl/ch-2.pl @@ -0,0 +1,196 @@ +#!perl + +################################################################################ +=comment + +Perl Weekly Challenge 054 +========================= + +Task #2 +*Collatz Conjecture* +*Contributed by Ryan Thompson* + +It is thought that the following sequence will always reach 1: + + $n = $n / 2 when $n is even + $n = 3*$n + 1 when $n is odd + +For example, if we start at 23, we get the following sequence: + +23 → 70 → 35 → 106 → 53 → 160 → 80 → 40 → 20 → 10 → 5 → 16 → 8 → 4 → 2 → 1 + +Write a function that finds the *Collatz* sequence for any positive integer. +Notice how the sequence itself may go far above the original starting number. + +*Extra Credit* + +Have your script calculate the sequence length for _all_ starting numbers up to +1000000 (1e6), and output the starting number and sequence length for the long- +est 20 sequences. + +=cut +################################################################################ + +#--------------------------------------# +# Copyright © 2020 PerlMonk Athanasius # +#--------------------------------------# + +use strict; +use warnings; +use Const::Fast; +use List::Priority; +use Scalar::Util::Numeric qw( isint ); +use constant +{ + DEBUG => 0, + TIMER => 1, +}; + +const my $MAX_TERMS => 20; +const my $MAX_N => 1e6; +const my $MAX_N_STR => commas( $MAX_N ); +const my $BAR => '-' x 30 . "\n"; +const my $USAGE => + "USAGE: perl $0 - find the Collatz sequence for positive integer N\n" . + " OR perl $0 - find the $MAX_TERMS longest sequences for N up to " . + "$MAX_N_STR\n"; + +#------------------------------------------------------------------------------- +BEGIN +#------------------------------------------------------------------------------- +{ + $| = 1; + print "\n"; +} + +#=============================================================================== +MAIN: +#=============================================================================== +{ + use if TIMER, 'Time::HiRes' => qw( gettimeofday tv_interval ); + + my $t0 = [gettimeofday] if TIMER; + + print "Challenge 054, Task #2: Collatz Conjecture (Perl)\n\n"; + + if (scalar @ARGV == 0) + { + printf "The %d longest Collatz sequences for N up to %s:\n\n%s " . + " Starting Sequence\n Rank Number (N) Length\n%s", + $MAX_TERMS, $MAX_N_STR, $BAR, $BAR; + + my $seqs = find_longest_seqs(); + + printf "%4d%13s%10d\n", ($_ + 1), commas($seqs->[$_][0]), $seqs->[$_][1] + for 0 .. $MAX_TERMS - 1; + + print $BAR; + } + elsif (scalar @ARGV == 1) + { + my $n = $ARGV[0]; + my $seq = find_seq($n); + my $terms = scalar @$seq; + + printf "The Collatz sequence (of %d term%s) for N = %s:\n%s\n", + $terms, $terms == 1 ? '' : 's', commas($n), join ' -> ', @$seq; + } + else + { + die $USAGE; + } + + printf "\n%.1f seconds\n", tv_interval($t0) if TIMER; +} + +#------------------------------------------------------------------------------- +sub find_longest_seqs +#------------------------------------------------------------------------------- +{ + my $longest_seqs = List::Priority->new(capacity => $MAX_TERMS); + $longest_seqs->insert(1, 1); + + my $max = 1 if DEBUG; + print "Max seq length: [ 1, 1]\n" if DEBUG; + + for my $start (2 .. $MAX_N) + { + my $terms = count_terms($start); + + if (DEBUG && $terms > $max) + { + $max = $terms; + printf "Max seq length: [%3d, %7d]\n", $terms, $start; + } + + $longest_seqs->insert($terms, $start); + } + + my @longest_seqs; + + while ($longest_seqs->size > 0) + { + my $seq_len = $longest_seqs->highest_priority; + my $start = $longest_seqs->pop; + + push @longest_seqs, [ $start, $seq_len ]; + } + + return \@longest_seqs; +} + +#=============================================================================== +# Memoize Collatz sequences (chains) +#=============================================================================== +{ + my %chains; + + #--------------------------------------------------------------------------- + BEGIN + #--------------------------------------------------------------------------- + { + $chains{ 1 } = 1; + } + + #--------------------------------------------------------------------------- + sub count_terms + #--------------------------------------------------------------------------- + { + my ($n) = @_; + + return $chains{ $n } if exists $chains{ $n }; + + no warnings 'recursion'; + + return $chains{ $n } = 1 + count_terms( $n / 2 ) unless $n % 2; + return $chains{ $n } = 1 + count_terms( $n * 3 + 1 ); + } +} + +#------------------------------------------------------------------------------- +sub find_seq +#------------------------------------------------------------------------------- +{ + my ($n) = @_; + + die $USAGE unless isint($n) && $n > 0; + + my @seq = ($n); + + push @seq, $n = ($n % 2) ? (3 * $n + 1) : ($n / 2) while $n > 1; + + return \@seq; +} + +#------------------------------------------------------------------------------- +sub commas +#------------------------------------------------------------------------------- +{ + my ($number) = @_; + + # Regex from perlfaq5: "How can I output my numbers with commas added?" + + return $number =~ s/(^\d+?(?=(?>(?:\d{3})+)(?!\d))|\G\d{3}(?=\d))/$1,/gr; +} + +################################################################################ diff --git a/challenge-054/athanasius/raku/ch-1.raku b/challenge-054/athanasius/raku/ch-1.raku new file mode 100644 index 0000000000..7662b59d7b --- /dev/null +++ b/challenge-054/athanasius/raku/ch-1.raku @@ -0,0 +1,81 @@ +use v6d; + +################################################################################ +=begin comment + +Perl Weekly Challenge 054 +========================= + +Task #1 +*kth Permutation Sequence* + +Write a script to accept two integers *n (>=1)* and *k (>=1)*. It should print +the *kth permutation* of *n integers*. For more information, please follow the +[ https://en.wikipedia.org/wiki/Permutation#k-permutations_of_n |wiki page]. + +For example, *n=3* and *k=4*, the possible permutation sequences are listed +below: + + 123 + 132 + 213 + 231 + 312 + 321 + +The script should print the *4th* permutation sequence *231*. + +=end comment +################################################################################ + +#--------------------------------------# +# Copyright © 2020 PerlMonk Athanasius # +#--------------------------------------# + +#------------------------------------------------------------------------------- +BEGIN ''.put; +#------------------------------------------------------------------------------- + +#=============================================================================== +sub MAIN +( + #| Integer >= 1, upper bound of integer series 1..N to be permuted + UInt:D $N where $_ >= 1, + + #| Integer >= 1, the number of the required permutation of the series + UInt:D $K where $_ >= 1, +) +#=============================================================================== +{ + "Challenge 054, Task #1: kth Permutation Sequence (Raku)\n".put; + + my UInt @list = 1 .. $N; + my UInt $size = [*] @list; + my UInt $index = ($K - 1) % $size; + my List $perm = @list.permutations[ $index ]; + my Str $sep = $N < 10 ?? '' !! ' '; + + "The %s permutation of %s is %s\n".printf: + ordinal($K), (1 .. $N).join($sep), $perm.list.join($sep); +} + +#------------------------------------------------------------------------------- +sub ordinal(UInt:D $n --> Str:D) +#------------------------------------------------------------------------------- +{ + my Str $suffix = 'th'; + my UInt $dig1 = (($n % 100) / 10).UInt; + + unless $dig1 == 1 + { + my UInt $dig0 = $n % 10; + + $suffix = $dig0 == 1 ?? 'st' !! + $dig0 == 2 ?? 'nd' !! + $dig0 == 3 ?? 'rd' !! 'th'; + } + + return $n ~ $suffix; +} + +############################################################################### diff --git a/challenge-054/athanasius/raku/ch-2.raku b/challenge-054/athanasius/raku/ch-2.raku new file mode 100644 index 0000000000..a42c1f6fd1 --- /dev/null +++ b/challenge-054/athanasius/raku/ch-2.raku @@ -0,0 +1,154 @@ +use v6d; + +################################################################################ +=begin comment + +Perl Weekly Challenge 054 +========================= + +Task #2 +*Collatz Conjecture* +*Contributed by Ryan Thompson* + +It is thought that the following sequence will always reach 1: + + $n = $n / 2 when $n is even + $n = 3*$n + 1 when $n is odd + +For example, if we start at 23, we get the following sequence: + +23 → 70 → 35 → 106 → 53 → 160 → 80 → 40 → 20 → 10 → 5 → 16 → 8 → 4 → 2 → 1 + +Write a function that finds the *Collatz* sequence for any positive integer. +Notice how the sequence itself may go far above the original starting number. + +*Extra Credit* + +Have your script calculate the sequence length for _all_ starting numbers up to +1000000 (1e6), and output the starting number and sequence length for the +longest 20 sequences. + +=end comment +################################################################################ + +#--------------------------------------# +# Copyright © 2020 PerlMonk Athanasius # +#--------------------------------------# + +use Lingua::EN::Numbers; # For the comma() subroutine +use List::Priority:from; + +my UInt constant MAX-N = 1e6.UInt; +my UInt constant MAX-TERMS = 20; +my Str constant BAR = '-' x 30; +my Bool constant DEBUG = False; + +my Instant $t0; + +#------------------------------------------------------------------------------- +BEGIN +#------------------------------------------------------------------------------- +{ + $t0 = now; + ''.put; +} + +#------------------------------------------------------------------------------- +END "\n%.1f seconds\n".printf: now - $t0; +#------------------------------------------------------------------------------- + +#=============================================================================== +multi sub MAIN #= Find the MAX-TERMS longest sequences for N up to MAX-N +#=============================================================================== +{ + "Challenge 054, Task #2: Collatz Conjecture (Raku)\n".put; + + ("The %d longest Collatz sequences for N up to %s:\n\n%s\n " ~ + " Starting Sequence\n Rank Number (N) Length\n%s\n").printf: + MAX-TERMS, comma(MAX-N), BAR, BAR; + + my @seqs = find-longest-seqs(); + + "%4d%13s%10d\n".printf: ($_ + 1), comma( @seqs[$_][0] ), @seqs[$_][1] + for 0 .. MAX-TERMS - 1; + + BAR.put; +} + +#------------------------------------------------------------------------------- +sub find-longest-seqs( --> Array:D ) +#------------------------------------------------------------------------------- +{ + my $longest-seqs = List::Priority.new(capacity => MAX-TERMS); + $longest-seqs.insert(1, 1); + + my UInt $max = 1 if DEBUG; + print "Max seq length: [ 1, 1]\n" if DEBUG; + + #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + # N.B.: For MAX-N == 1e6, this for loop takes ~20 minutes to complete! + #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + for 2 .. MAX-N -> UInt $start + { + my UInt $terms = count-terms($start); + + if (DEBUG && $terms > $max) + { + $max = $terms; + "Max seq length: [%3d, %7d]\n".printf: $terms, $start; + } + + $longest-seqs.insert($terms, $start); + } + + my @longest-seqs; + + while $longest-seqs.size > 0 + { + my UInt $seq-len = $longest-seqs.highest_priority.UInt; + my UInt $start = $longest-seqs.pop; + + push @longest-seqs, [ $start, $seq-len ]; + } + + return @longest-seqs; +} + +#------------------------------------------------------------------------------- +sub count-terms( UInt:D $n --> UInt:D ) +#------------------------------------------------------------------------------- +{ + state %chains = 1 => 1; # Memoize + + return %chains{$n} if %chains{$n}:exists; + return %chains{$n} = 1 + count-terms(($n / 2).UInt) if $n % 2 == 0; + return %chains{$n} = 1 + count-terms( $n * 3 + 1 ); +} + +#=============================================================================== +multi sub MAIN +( + UInt:D $N where $_ > 0 #= Find the Collatz sequence for positive integer N +) +#=============================================================================== +{ + "Challenge 054, Task #2: Collatz Conjecture (Raku)\n".put; + + my UInt @seq = $N; + my UInt $n = $N; + + while $n > 1 + { + $n = ($n % 2 == 0) ?? ($n / 2 ).UInt + !! ($n * 3 + 1); + @seq.push: $n; + } + + my UInt $terms = @seq.elems; + + "The Collatz sequence (of %d term%s) for N = %s:\n%s\n".printf: + $terms, ($terms == 1 ?? '' !! 's'), comma($N), @seq.join: ' -> '; +} + +################################################################################ -- cgit