Perl Weekly Challenge W025 - Longest Pokemon Sequence, Chaocipher
New week new challenge!
And for this week we have two awesome tasks for this week's challenge, too awesome not to blog about it.
If you'd like to join the fun and contribute, please visit the site site managed by Mohammad S Anwar.
Task #1 - Longest Pokémon Sequence:
Generate a longest sequence of the following “English Pokemon” 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 wiki page.
Solution:
After reading the task, recursive function automatically comes to mind.
But first, I grouped each pokémon names by the starting letter so that I won't have to filter out the list in each iteration. I used hash of arrays which will be structured like so:
#%hash = (
a => ["aduino"],
...
e => ["emboar", "emolga", "exeggcute"],
..
y => ["yamask"],
)Each pokémon name will be used as a starting point. And the next name(s) will be supplied by the hash of array using the last letter of the previous name as key.
machamp
________________________|________________________
| | | | |
petilil pidgeotto pikachu pinsir ... porygonz
This will be done until no next candidate can be found. The length of the sequence was determined by the number of names in each. The sequences are stored in Array of arrays using the length of the sequence as index, hence the longest sequence(s) will be stored in @array[-1]
PERL5
use strict;
use warnings;
use 5.010;
my $start_run = time();
my @names = qw(bagon audino 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 %hash;
my $max_length = 0;
my @chain;
for my $n (@names) {
my $first = substr $n,0,1;
push @{$hash{$first}}, $n;
}
#Iterate in each name in @names as start of sequence
for my $name (@names) {
my $last_char = substr $name,-1;
&iter($name, "", @{$hash{$last_char}} );
}
sub iter {
my ($m_name, $m_name_arr , @m_name_list ) = @_;
$m_name_arr .= "> $m_name ";
for my $name (@m_name_list) {
#check and skip if the $name is already in the name sequence in string format (stored in $m_name_arr, not really an 'ARR'ay lols)
if (index($m_name_arr, $name) <0) {
my $last_char = substr $name,-1;
&iter($name, $m_name_arr, @{$hash{$last_char}} );
}
}
#Only do computation when name list is empty
if (!@m_name_list) {
my $length = $m_name_arr=~y/>//;
if ($length >= $max_length) {
push @{$chain[$length]}, $m_name_arr;
$max_length = $length;
}
}
}
#Print the longest sequence
#Print all when they are tied
say "Sequence:";
for my $seq (@{$chain[-1]}) {
say "$seq\n";
}
say "Highest chain count: $#chain";
say "Number of Sequence found: ".@{$chain[-1]};
my $run_time = time() - $start_run;
say "Run Time: $run_time sec";
My perl5 solution took 5 seconds to complete on average. For me, this is already acceptable considering the number of elements(70) and paths it has to go through.
I was surprised when I converted my perl5 solution to perl6. I initially used grep to filter the names to get the next name candidates instead of doing it prior using hash of arrays. It took an hour to complete, this is understandable because grep will be executed in each recursion. So I went back to using hash of arrays and it took 5 mins to complete, it is still slow compared to perl5.
Then I thought of doing it backwards starting from the "possible" last names. These are names ending with letter which is NOT a starting letter of any name in the pokémon name list. This took the execution time down to a minute. While the method worked in the list provided by the task, it won't work on general case as pointed out by Laurent in our discussion in his blog entry for the same task.
PERL6
my Str @names = <bagon audino 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 Array @chain;
my %hash = ();
my int $max_length = 0;
sub MAIN {
for 'a'..'z' -> $n {
%hash{$n} = @names.grep(/$n$/);
}
my Str @last_names;
for @names -> $name {
my $last = $name.substr(*-1);
(!grep {/^$last/}, @names) && @last_names.push($name);
}
my @best_last;
for @last_names -> $lname {
my $first = $lname.substr(0,1);
my $count = grep { /$first$/}, @names;
@best_last[$count].push($lname);
}
#Use the @best_last as starting point
for @best_last[*-1] -> @last {
for @last -> $e {
my Str $m_name_chain = "";
iter($e, $m_name_chain, %hash{$e.substr(0,1)}.Seq );
}
}
#Print the longest sequence
#Print all when they are tied
say "Sequence:";
for @chain[*-1] -> @r {
for @r -> $e {
say ">"~$e.chop~"\n";
}
}
say "Highest chain count: "~@chain.end;
say "Number of Sequence found: "~(1+@chain[*-1].end);
say "Run Time: "~(now - INIT now)~" sec";
}
sub iter {
my (Str $m_name, Str $m_name_chain, Str @m_name_list) = @_;
$m_name_chain = " $m_name >" ~ $m_name_chain;
for @m_name_list -> $name {
#check and skip if the $name is already in the name sequence in string format
#(stored in $m_name_chain)
if (!$m_name_chain.contains($name)) {
iter($name, $m_name_chain, %hash{$name.substr(0,1)}.Seq);
}
}
my int $length = +$m_name_chain.comb: ">";
if ($length >= $max_length) {
@chain[$length].push($m_name_chain);
$max_length = $length;
}
}
Task #2 - Chaocipher:
Create script to implement Chaocipher. Please checkout wiki page for more information.
From the wiki,
The Chaocipher is a cipher method invented by John Francis Byrne in 1918 and described in his 1953 autobiographical Silent Years. He believed Chaocipher was simple, yet unbreakable. Byrne stated that the machine he used to encipher his messages could be fitted into a cigar box. He offered cash rewards for anyone who could solve it.
How it works:
The Chaocipher system consists of two alphabets, with the "right" alphabet used for locating the plaintext letter while the other ("left") alphabet is used for reading the corresponding ciphertext letter. The underlying algorithm is related to the concept of dynamic substitution whereby the two alphabets are slightly modified after each input plaintext letter is enciphered. This leads to nonlinear and highly diffused alphabets as encryption progresses.
Deciphering is identical to enciphering, with the ciphertext letter being located in the "left" alphabet while the corresponding plaintext letter being read from the "right" alphabet.
A detailed description of the Chaocipher algorithm is available as well as discussions of the deciphered plaintexts and the solution to Byrne's challenge.
The wiki description on how it works wasn't very clear to me, but this video helped me understand the algorithm easily.
Solution:
I used a randomly generated string containing all the alphabet (both uppercase and lowercase), numbers from 0 to 9 and some symbols for the cipher text and plain text.
Note that in the chaocipher revealed document, the cipher text and plain text used is as follows:
LEFT (ct): HXUCZVAMDSLKPEFJRIGTWOBNYQ
RIGHT (pt): PTLNBQDEOYSFAVZKGJRIHWXUMC
Two fixed points named as Zenith and Nadir were set to 0 and 13 respectively (0-based index). These points are used as reference when permuting (basically rotating) the cipher text and plain text.
PERL5
use strict;
use warnings;
use 5.010;
die "Usage:\n\tch-2.pl <-d|e> \"\"\n\n" if @ARGV<2;
my $encrypt = $ARGV[0] eq '-e';
my $text_string = $ARGV[1];
#It should be okay to modify the zenith/nadir (0 to $wheelsize)
use constant ZENITH => 0;
use constant NADIR => 13;
#Initialize wheels (chaocipher with bigger wheels!)
my @pt = "7bqkj9l2hOWyzA8SLPEtRvBwUQVmxa45g ufspeTF1KHd0DrGMCZoJXi3YIN6nc"=~/./g;
my @ct = "vEDclCHZYeWo9drb6Jnkf5MRXOt UgN4Fi231GzQIx7sPaLK8TBuVpA0yjShqwm"=~/./g;
my $wheel_size = $#pt;
# This function rotates the given array or a portion of the given array
# Rotation count is defined by $r
# The whole array will be rotated by default
# but the range can be specified in $from and $to variable
sub rot {
my ($r,$array, $from, $to) = @_;
$r %= ($wheel_size+1);
return if $r == 0;
if (!(defined $to && defined $from)) {
@{$array} = (@{$array}[$r..$#{$array}], @{$array}[0..~-$r]);
} else {
$r += $from;
@{$array} = (@{$array}[0..~-$from], @{$array}[$r..$to], @{$array}[$from..~-$r],@{$array}[$to+1..$#{$array}]);
}
}
sub cipher {
my ($text,$enc,$ret) = @_;
for my $c ($text=~/./g) {
#find where $c is in the plain text @pt (or @ct when decrypting)
#grep wont stop when first occurence was found
my $pt_pos = (grep {($enc?$pt[$_]:$ct[$_]) eq $c} 0..$wheel_size)[0];
#Get the character from the cipher text in that position($pt_pos)
$ret .= $enc?$ct[$pt_pos]:$pt[$pt_pos];
#rotate @pt and @ct from $pt_pos to ZENITH
&rot($pt_pos-ZENITH, \@pt);
&rot($pt_pos-ZENITH, \@ct);
#permute @ct: move the char in ZENITH + 1 to NADIR
&rot(1,\@ct,ZENITH+1,NADIR);
#permute @pt: rotate1 then move the char in ZENITH + 2 to NADIR
&rot(1,\@pt);
&rot(1,\@pt,ZENITH+2,NADIR);
}
return $ret;
}
say &cipher($text_string,$encrypt);
And that's it for this week. Task #3 was put on hold while they work on a new format. I am really excited for the next week's challenge!
Happy Coding!
-Yet
I blog about Perl.
Leave a comment