Merge pull request #630 from PerlMonk-Athanasius/branch-for-challenge-025

Perl 5 & 6 solutions to Task #1 of the Perl Weekly Challenge #025

2 files changed, 286 insertions, 0 deletions

diff --git a/challenge-025/athanasius/perl5/ch-1.pl b/challenge-025/athanasius/perl5/ch-1.pl
new file mode 100644
index 0000000000..29b9f3cd78
--- /dev/null
+++ b/challenge-025/athanasius/perl5/ch-1.pl
@@ -0,0 +1,164 @@
+#!perl
+
+################################################################################
+=comment
+
+Perl Weekly Challenge 025
+=========================
+
+Task #1
+-------
+Generate a longest sequence of the following *English Pokeman* names where each
+name starts with the last letter of previous name.
+
+  audino bagon baltoy banette bidoof braviary bronzor carracosta charmeleon
+  cresselia croagunk darmanitan deino emboar emolga exeggcute gabite girafarig
+  gulpin haxorus heatmor heatran ivysaur jellicent jumpluff kangaskhan
+  kricketune landorus ledyba loudred lumineon lunatone machamp magnezone
+  mamoswine nosepass petilil pidgeotto pikachu pinsir poliwrath poochyena
+  porygon2 porygonz registeel relicanth remoraid rufflet sableye scolipede
+  scrafty seaking sealeo silcoon simisear snivy snorlax spoink starly tirtouga
+  trapinch treecko tyrogue vigoroth vulpix wailord wartortle whismur wingull
+  yamask
+
+The above names borrowed from
+[ https://en.wikipedia.org/wiki/List_of_Pok%C3%A9mon |wiki page].
+
+=cut
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2019 PerlMonk Athanasius #
+#--------------------------------------#
+
+use strict;
+use warnings;
+use utf8;
+use Const::Fast;
+use List::MoreUtils qw( uniq );
+use constant DEBUG => 1;
+
+const my @NAMES =>
+qw(
+    audino bagon baltoy banette bidoof braviary bronzor carracosta charmeleon
+    cresselia croagunk darmanitan deino emboar emolga exeggcute gabite girafarig
+    gulpin haxorus heatmor heatran ivysaur jellicent jumpluff kangaskhan
+    kricketune landorus ledyba loudred lumineon lunatone machamp magnezone
+    mamoswine nosepass petilil pidgeotto pikachu pinsir poliwrath poochyena
+    porygon2 porygonz registeel relicanth remoraid rufflet sableye scolipede
+    scrafty seaking sealeo silcoon simisear snivy snorlax spoink starly tirtouga
+    trapinch treecko tyrogue vigoroth vulpix wailord wartortle whismur wingull
+    yamask
+  );
+
+const my $NUM_NAMES => scalar @NAMES;
+
+BEGIN
+{
+    $| = 1;
+    print "\n";
+}
+
+#===============================================================================
+MAIN:
+#===============================================================================
+{
+    print("There are $NUM_NAMES different Pokémon names\n") if DEBUG;
+
+    my   %pairs;
+    push $pairs{ substr($_, 0, 1) . substr($_, -1) }->@*, $_ for @NAMES;
+    my   @chains   = sort keys %pairs;
+    my   %dominoes = map { $_ => scalar( $pairs{$_}->@* ) } @chains;
+
+    printf("%2d: %6d\n", 1, scalar @chains) if DEBUG;
+
+    for my $i (2 .. $NUM_NAMES)
+    {
+        my @new_chains;
+
+        for my $chain (@chains)
+        {
+            my $last = substr $chain, -1;
+            my %local_dominoes = %dominoes;
+             --$local_dominoes{ $1 } while $chain =~ /(..)/g;
+
+            for my $domino (sort keys %local_dominoes)
+            {
+                push @new_chains, $chain . $domino
+                    if $local_dominoes{$domino} > 0 &&
+                       $last eq substr($domino, 0, 1);
+            }
+        }
+
+        last if scalar @new_chains == 0;
+
+        @chains = uniq @new_chains;
+
+        printf("%2d: %6d\n", $i, scalar @chains) if DEBUG;
+    }
+
+    my $solution = $chains[0];
+
+    printf "The longest sequences of the %d given Pokémon names contain %d " .
+           "elements; e.g.:\n\n%s\n", $NUM_NAMES, length($solution) / 2,
+            join ', ', decode_chain($solution, \%pairs);
+}
+
+#-------------------------------------------------------------------------------
+sub decode_chain
+#-------------------------------------------------------------------------------
+{
+    my ($chain, $pairs) = @_;
+    my  @sequence;
+
+    while ($chain =~ /(..)/g)
+    {
+        my $pair  = $1;
+        my @names = $pairs->{$pair}->@*;
+        my $name  = shift @names;
+
+        push @sequence, $name;
+
+        $pairs->{$pair} = \@names;
+    }
+
+    return @sequence;
+}
+
+################################################################################
+
+__END__
+
+ 2:27 >perl ch-1.pl
+
+There are 70 different Pokémon names
+ 1:     64
+ 2:    153
+ 3:    414
+ 4:   1025
+ 5:   2433
+ 6:   5529
+ 7:  11964
+ 8:  24270
+ 9:  46046
+10:  81197
+11: 131728
+12: 194642
+13: 260203
+14: 311684
+15: 331912
+16: 310198
+17: 249704
+18: 169904
+19:  96066
+20:  43676
+21:  15128
+22:   3648
+23:    416
+The longest sequences of the 70 given Pokémon names contain 23 elements; e.g.:
+
+machamp, petilil, loudred, darmanitan, nosepass, seaking, girafarig, gabite, exe
+ggcute, emboar, relicanth, heatmor, registeel, landorus, simisear, rufflet, trap
+inch, haxorus, scrafty, yamask, kricketune, emolga, audino
+
+ 2:30 >
diff --git a/challenge-025/athanasius/perl6/ch-1.p6 b/challenge-025/athanasius/perl6/ch-1.p6
new file mode 100644
index 0000000000..7af8b5f4e6
--- /dev/null
+++ b/challenge-025/athanasius/perl6/ch-1.p6
@@ -0,0 +1,122 @@
+use v6;
+
+################################################################################
+=begin comment
+
+Perl Weekly Challenge 025
+=========================
+
+Task #1
+-------
+Generate a longest sequence of the following *English Pokeman* names where each
+name starts with the last letter of previous name.
+
+  audino bagon baltoy banette bidoof braviary bronzor carracosta charmeleon
+  cresselia croagunk darmanitan deino emboar emolga exeggcute gabite girafarig
+  gulpin haxorus heatmor heatran ivysaur jellicent jumpluff kangaskhan
+  kricketune landorus ledyba loudred lumineon lunatone machamp magnezone
+  mamoswine nosepass petilil pidgeotto pikachu pinsir poliwrath poochyena
+  porygon2 porygonz registeel relicanth remoraid rufflet sableye scolipede
+  scrafty seaking sealeo silcoon simisear snivy snorlax spoink starly tirtouga
+  trapinch treecko tyrogue vigoroth vulpix wailord wartortle whismur wingull
+  yamask
+
+The above names borrowed from
+[ https://en.wikipedia.org/wiki/List_of_Pok%C3%A9mon |wiki page].
+
+=end comment
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2019 PerlMonk Athanasius #
+#--------------------------------------#
+
+my Bool constant $DEBUG = True;
+
+my constant @NAMES =
+<
+    audino bagon baltoy banette bidoof braviary bronzor carracosta charmeleon
+    cresselia croagunk darmanitan deino emboar emolga exeggcute gabite girafarig
+    gulpin haxorus heatmor heatran ivysaur jellicent jumpluff kangaskhan
+    kricketune landorus ledyba loudred lumineon lunatone machamp magnezone
+    mamoswine nosepass petilil pidgeotto pikachu pinsir poliwrath poochyena
+    porygon2 porygonz registeel relicanth remoraid rufflet sableye scolipede
+    scrafty seaking sealeo silcoon simisear snivy snorlax spoink starly tirtouga
+    trapinch treecko tyrogue vigoroth vulpix wailord wartortle whismur wingull
+    yamask
+>;
+
+my UInt constant $NUM-NAMES = @NAMES.elems;
+
+BEGIN say '';
+
+#===============================================================================
+sub MAIN()
+#===============================================================================
+{
+    "There are $NUM-NAMES different Pokemon names".say if $DEBUG;
+
+    my %pairs;
+       %pairs{ .substr(0, 1) ~ .substr(*-1) }.push($_) for @NAMES;
+    my @chains   = %pairs.keys.sort;
+    my %dominoes = @chains.map: { $_ => %pairs{$_}.elems };
+
+    "%2d: %6d\n".printf(1, @chains.elems) if $DEBUG;
+
+    for 2 .. $NUM-NAMES -> UInt $i
+    {
+        my @new-chains;
+
+        for @chains -> Str $chain
+        {
+            my Str $last      = $chain.substr(*-1);
+            my     %available = %dominoes;
+            my     @matches   = m:g/(..)/ given $chain;
+
+            --%available{ $_ } for @matches;
+
+            for %available.keys.sort -> Str $domino
+            {
+                if %available{$domino} > 0
+                {
+                    my Str $first = $domino.substr(0, 1);
+                    @new-chains.push: $chain ~ $domino if $last eq $first;
+                }
+            }
+        }
+
+        last if @new-chains.elems == 0;
+
+        @chains = @new-chains.unique;
+
+        "%2d: %6d\n".printf($i, @chains.elems) if $DEBUG;
+    }
+
+    my Str $solution = @chains[0];
+
+    ("The longest sequences of the %d given Pokemon names contain %d " ~
+       "elements; e.g.:\n\n%s\n").printf: $NUM-NAMES, $solution.chars / 2,
+        decode-chain($solution, %pairs).join(', ');
+}
+
+#-------------------------------------------------------------------------------
+sub decode-chain(Str:D $chain, %pairs)
+#-------------------------------------------------------------------------------
+{
+    my @sequence;
+    my @matches = m:g/(..)/ given $chain;
+
+    for @matches.map: { .Str } -> Str $pair
+    {
+        my @names = @( %pairs{$pair} );
+        my $name  = @names.shift;
+
+        @sequence.push: $name;
+
+        %pairs{$pair} = @names;
+    }
+
+    return @sequence;
+}
+
+################################################################################