Commit solutions for perl weekly challenge 025

2 files changed, 352 insertions, 0 deletions

diff --git a/challenge-025/duane-powell/perl5/ch-1.pl b/challenge-025/duane-powell/perl5/ch-1.pl
new file mode 100755
index 0000000000..a471c2a363
--- /dev/null
+++ b/challenge-025/duane-powell/perl5/ch-1.pl
@@ -0,0 +1,166 @@
+#!/usr/bin/perl
+use Modern::Perl;
+
+# Generate a longest sequence of the following English Pokemon names where each name starts with the last letter of previous name.
+
+my @pokemon = 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
+);
+
+my @test = qw(
+bad good dog cat fish boy girl tree house lost 
+);
+
+# The plan is to build a tree of all possible name combinations. 
+# While the tree is building note the longest 3 paths:
+#
+# Code below finds over 5 million unique combinations of names in @pokemon array
+# It takes 2 min 30 secs to run on my Intel Next Unit of Computing with 16GB RAM,
+# needs to be optimized.
+
+my %args    = @ARGV;
+my $verbose = $args{verbose} || 0;
+my $test    = $args{test}    || 0;
+
+@pokemon = @test if ($test);
+@pokemon = (sort @pokemon);
+
+my $tree = PokemonNameTree->new($verbose,@pokemon);
+$tree->grow(); 
+$tree->announce_top3();
+exit;
+
+package PokemonNameTree;
+sub new {
+        my ($class,$verbose,@name) = @_;
+        my $self = {
+		__root => {
+			name => "__root_node_of_pokemon_name_tree__",
+			kids => [],
+		},
+		verbose => $verbose,
+		top3    => ['','',''],
+		top3_n  => [0,0,0],
+        };
+        bless $self, $class;
+
+	# Init root node of tree with all names nodes
+	foreach (sort (@name)) {
+		push( @{ $self->{__root}{kids} }, $self->new_node($_) );
+	}
+	return $self;
+}
+
+sub new_node {
+	my ($self,$name) = @_;
+	return {
+		name => $name,
+		kids => [],
+	};
+}
+sub grow {
+	my $self = shift;
+	# Begin tree growth at ply 1, where we initialized our name nodes
+	my @parents = qw();
+	foreach my $node ( @{ $self->{__root}{kids} } ) {
+		$self->_grow(1,$node,@parents,$node->{name});
+	}
+}
+sub _grow {
+	my ($self,$ply,$node,@parents) = @_;
+
+	if ($self->{verbose}) {
+		# say every sequence found
+		print "/$_" foreach (@parents);
+		say " $ply";
+	} else {
+		# otherwise build array 3 longest sequences
+		if ($ply >= @{$self->{top3_n}}[0]) {
+			unshift(@{$self->{top3}}, '/'.join('/',@parents));
+			unshift(@{$self->{top3_n}}, $ply);
+			pop(@{$self->{top3}});
+			pop(@{$self->{top3_n}});
+		}
+	}
+	# Get every name node we were initialized with (i.e. all the names in @pokemon)
+	GROW: foreach ( @{ $self->{__root}{kids} } ) {
+		my $n = $_->{name};
+		foreach my $p (@parents) {
+			# Don't grow tree by reusing any parent name, otherwise we get circular (infinite long) names
+			# For example,  /exeggcute/exeggcute/exeggcute ... /exeggcute 
+			next GROW if ($n eq $p);
+		}
+		my $last_char = substr($node->{name},-1,1);
+		my $next_char = substr($n,            0,1);
+		last if ($next_char gt $last_char); # No point in looking further since @pokemon is sorted alphabetically
+		if ($last_char eq $next_char) {
+			# Name match, create new node in tree, insert into kids of parent node
+			my $new_node = $self->new_node($n);
+			push( @{ $node->{kids} }, $new_node);
+			# Recurse depth first, note how $n is natrually added to @parents in the param pass
+			$self->_grow($ply+1,$new_node,@parents,$n); 
+		}
+	}
+}
+sub announce_top3 {
+	my $self = shift;
+	unless ($self->{verbose}) {
+		foreach (0..2) {
+			say @{$self->{top3}}[$_], " ", @{$self->{top3_n}}[$_];
+		}
+	}
+}
+
+1;
+
+__END__
+
+./time ch-1.pl verbose 1 > out.txt <==== verbose mode, lists all 5 million unique sequences
+real    2m24.354s
+user    2m22.564s
+sys     0m1.052s
+
+grep 23 out.txt | wc -l
+1248 <================================== 1,248 name paths tied for first place with 23 names in the sequence
+
+./ch-1.pl <============================= Quiet mode, just return top 3 longest sequences. Last 3 paths found get reported.
+/machamp/pinsir/rufflet/trapinch/heatmor/remoraid/darmanitan/nosepass/starly/yamask/kricketune/exeggcute/emboar/relicanth/haxorus/simisear/registeel/landorus/seaking/girafarig/gabite/emolga/audino 23
+/machamp/pinsir/rufflet/trapinch/heatmor/remoraid/darmanitan/nosepass/starly/yamask/kricketune/exeggcute/emboar/registeel/landorus/simisear/relicanth/haxorus/seaking/girafarig/gabite/emolga/audino 23
+/machamp/pinsir/rufflet/trapinch/heatmor/remoraid/darmanitan/nosepass/starly/yamask/kricketune/emboar/relicanth/haxorus/simisear/registeel/landorus/seaking/girafarig/gabite/exeggcute/emolga/audino 23
+
+./ch-1.pl test 1 verbose 1 <============ Lightweight test case
+/bad 1
+/bad/dog 2
+/bad/dog/girl 3
+/bad/dog/girl/lost 4
+/bad/dog/girl/lost/tree 5
+/bad/dog/good 3
+/boy 1
+/cat 1
+/cat/tree 2
+/dog 1
+/dog/girl 2
+/dog/girl/lost 3
+/dog/girl/lost/tree 4
+/dog/good 2
+/fish 1
+/fish/house 2
+/girl 1
+/girl/lost 2
+/girl/lost/tree 3
+/good 1
+/good/dog 2
+/good/dog/girl 3
+/good/dog/girl/lost 4
+/good/dog/girl/lost/tree 5
+/house 1
+/lost 1
+/lost/tree 2
+/tree 1
+
diff --git a/challenge-025/duane-powell/perl5/ch-2.pl b/challenge-025/duane-powell/perl5/ch-2.pl
new file mode 100755
index 0000000000..546221d4d8
--- /dev/null
+++ b/challenge-025/duane-powell/perl5/ch-2.pl
@@ -0,0 +1,186 @@
+#!/usr/bin/perl
+use Modern::Perl;
+
+# Create script to implement Chaocipher.
+# http://www.chaocipher.com/ActualChaocipher/Chaocipher-Revealed-Algorithm.pdf
+# I remained true to "The Algorithm Revealed" as described in the above .pdf
+
+my $p_msg   = "WELLDONEISBETTERTHANWELLSAID";
+my $c_msg   = "OAHQHCNYNXTSZJRRHJBYHQKSOUJY";
+my @disk_ct = split(//,"HXUCZVAMDSLKPEFJRIGTWOBNYQ");
+my @disk_pt = split(//,"PTLNBQDEOYSFAVZKGJRIHWXUMC");
+
+usage() if (@ARGV % 2);
+my %args    = @ARGV;
+my $text    = $args{'--text'}    || $p_msg;
+my $verbose = $args{'--verbose'} || 0;
+my $decrypt = $args{'--decrypt'} || 0; 
+my $key_gen = $args{'--key-gen'} || 0;
+my $ct_key  = $args{'--ct-key'}  || 0;
+my $pt_key  = $args{'--pt-key'}  || 0;
+
+$text = $c_msg if ($decrypt and $text eq $p_msg);
+
+@disk_ct = split(//,$ct_key) if ($ct_key);
+@disk_pt = split(//,$pt_key) if ($pt_key);
+
+if ($key_gen) {
+	@disk_ct = key_gen();
+	@disk_pt = key_gen();
+	say "keys;";
+	say "ct " . join("",@disk_ct);
+	say "pt " . join("",@disk_pt);
+	exit;
+}
+
+chaocipher();
+exit;
+
+sub chaocipher {
+	my @output; 
+	# Convert text to uppercase and remove all chars not in our alphabet
+	$text = uc($text);
+	$text =~ s/[^A-Z]//g;
+	foreach my $char (split(//,$text)) {
+		print join("",@disk_ct) . " " . join("",@disk_pt) . "\n" if ($verbose);
+
+		if ($decrypt) {
+			my $i = char_pos($char, @disk_ct);
+			permutate_ct($i);
+			push(@output, permutate_pt($i));
+		} else {
+			my $i = char_pos($char, @disk_pt);
+			push(@output, permutate_ct($i));
+			permutate_pt($i);
+		} 
+	}
+	print join("",@disk_ct) . " " . join("",@disk_pt) . "\n" if ($verbose);
+	say join("",@output);
+}
+
+sub permutate_ct {
+	my ($c) = @_;
+	my ($zenith, $nadir, $hole) = (0,13,'.');
+	# Steps from Chaocipher-Revealed-Algorithm.pdf
+        # 1. Rotate char to zenith
+        rotate(1, $c, \@disk_ct);
+        # 2. Extract char at $zenith+1 and fill with "hole"
+        my $extract = $disk_ct[$zenith+1];
+        $disk_ct[$zenith+1] = $hole;
+        # 3-4. Move chars 1 postion left and replace hole with $extract
+        my @slice = (@disk_ct[$zenith+2 .. $nadir],$extract);
+        splice(@disk_ct, $zenith+1, $nadir, @slice);
+        return $disk_ct[0];
+}
+
+sub permutate_pt {
+	my ($p) = @_;
+	my ($zenith, $nadir, $hole) = (0,13,'.');
+	# Steps from Chaocipher-Revealed-Algorithm.pdf
+        # 1-2. Rotate char to zenith
+        rotate(1, $p+1, \@disk_pt);
+        # 3. Extract char at $zenith+2 and fill with "hole"
+        my $extract = $disk_pt[$zenith+2];
+        $disk_pt[$zenith+2] = $hole;
+        # 4-5 Move chars 1 postion left and replace hole with $extract
+        my @slice = (@disk_pt[$zenith+3 .. $nadir],$extract);
+        splice(@disk_pt, $zenith+2, $nadir-1, @slice);
+	return $disk_pt[25];
+}
+
+sub rotate {
+	my ($left,$clicks,$array) = @_;
+	for (1 .. $clicks) {
+		if ($left) {
+			push( @{$array}, shift @{$array} );
+		} else {
+			unshift( @{$array}, pop @{$array} );
+		}
+	}
+}
+
+sub char_pos {
+	my ($char, @array) = @_;
+	my $p;
+	foreach my $i (0 .. 25) {
+		$p = $i;
+		last if ($array[$i] eq $char);
+	}
+	return $p;
+}
+
+sub key_gen {
+	my @alphabet = ('A'..'Z');
+        my @key;
+        while (@alphabet) {
+                push(@key, splice(@alphabet, int(rand @alphabet)-1, 1));
+        }
+        return @key;
+}
+
+sub usage {
+        print <<EOU;
+Usage:
+	$0
+	 --decrypt 1
+	 --decrypt 1 --verbose 1
+	             --text my-message-here
+	 --decrypt 1 --text my-message-here 
+	 --key-gen 1
+	             --text my-message-here --ct-key the-ct-key --pt the-pt-key
+	 --decrypt 1 --text my-message-here --ct-key the-ct-key --pt the-pt-key
+EOU
+	exit;
+}
+
+__END__
+
+./ch-2.pl
+OAHQHCNYNXTSZJRRHJBYHQKSOUJY
+
+./ch-2.pl --decrypt 1
+WELLDONEISBETTERTHANWELLSAID
+
+./ch-2.pl --decrypt 1 --verbose 1
+HXUCZVAMDSLKPEFJRIGTWOBNYQ PTLNBQDEOYSFAVZKGJRIHWXUMC
+ONYQHXUCZVAMDBSLKPEFJRIGTW XUCPTLNBQDEOYMSFAVZKGJRIHW
+ADBSLKPEFJRIGMTWONYQHXUCZV OYSFAVZKGJRIHMWXUCPTLNBQDE
+HUCZVADBSLKPEXFJRIGMTWONYQ NBDEOYSFAVZKGQJRIHMWXUCPTL
+QUCZVADBSLKPEHXFJRIGMTWONY NBEOYSFAVZKGQDJRIHMWXUCPTL
+HFJRIGMTWONYQXUCZVADBSLKPE JRHMWXUCPTLNBIEOYSFAVZKGQD
+CVADBSLKPEHFJZRIGMTWONYQXU YSAVZKGQDJRHMFWXUCPTLNBIEO
+NQXUCVADBSLKPYEHFJZRIGMTWO BIOYSAVZKGQDJERHMFWXUCPTLN
+YHFJZRIGMTWONEQXUCVADBSLKP RHFWXUCPTLNBIMOYSAVZKGQDJE
+NQXUCVADBSLKPEYHFJZRIGMTWO MOSAVZKGQDJERYHFWXUCPTLNBI
+XCVADBSLKPEYHUFJZRIGMTWONQ AVKGQDJERYHFWZXUCPTLNBIMOS
+TONQXCVADBSLKWPEYHUFJZRIGM IMSAVKGQDJERYOHFWZXUCPTLNB
+SKWPEYHUFJZRILGMTONQXCVADB RYHFWZXUCPTLNOBIMSAVKGQDJE
+ZILGMTONQXCVARDBSKWPEYHUFJ LNBIMSAVKGQDJOERYHFWZXUCPT
+JILGMTONQXCVAZRDBSKWPEYHUF LNIMSAVKGQDJOBERYHFWZXUCPT
+RBSKWPEYHUFJIDLGMTONQXCVAZ RYFWZXUCPTLNIHMSAVKGQDJOBE
+RSKWPEYHUFJIDBLGMTONQXCVAZ YFZXUCPTLNIHMWSAVKGQDJOBER
+HFJIDBLGMTONQUXCVAZRSKWPEY LNHMWSAVKGQDJIOBERYFZXUCPT
+JDBLGMTONQUXCIVAZRSKWPEYHF MWAVKGQDJIOBESRYFZXUCPTLNH
+BGMTONQUXCIVALZRSKWPEYHFJD VKQDJIOBESRYFGZXUCPTLNHMWA
+YFJDBGMTONQUXHCIVALZRSKWPE HMAVKQDJIOBESWRYFGZXUCPTLN
+HIVALZRSKWPEYCFJDBGMTONQUX RYGZXUCPTLNHMFAVKQDJIOBESW
+QXHIVALZRSKWPUEYCFJDBGMTON SWYGZXUCPTLNHRMFAVKQDJIOBE
+KPUEYCFJDBGMTWONQXHIVALZRS NHMFAVKQDJIOBRESWYGZXUCPTL
+SPUEYCFJDBGMTKWONQXHIVALZR NHFAVKQDJIOBRMESWYGZXUCPTL
+OQXHIVALZRSPUNEYCFJDBGMTKW WYZXUCPTLNHFAGVKQDJIOBRMES
+UEYCFJDBGMTKWNOQXHIVALZRSP GVQDJIOBRMESWKYZXUCPTLNHFA
+JBGMTKWNOQXHIDVALZRSPUEYCF OBMESWKYZXUCPRTLNHFAGVQDJI
+YFJBGMTKWNOQXCHIDVALZRSPUE JIBMESWKYZXUCOPRTLNHFAGVQD
+WELLDONEISBETTERTHANWELLSAID
+
+./ch-2.pl --key-gen 1
+keys;
+ct COTUARBGQHZWXIELJMYKNSDFVP
+pt PGLNWYMFQKSUTEZVOJBXDAHIRC
+
+./ch-2.pl --text "Turning and turning in the widening gyre the falcon cannot hear the falconer" --ct-key COTUARBGQHZWXIELJMYKNSDFVP --pt-key PGLNWYMFQKSUTEZVOJBXDAHIRC
+XZDCKPDODILXCJPOIKISGJMZUZMVRCHOJAHYIZPAVZSAGJFQXUGXOIGOMIZWMIRN
+
+./ch-2.pl --decrypt 1 --text XZDCKPDODILXCJPOIKISGJMZUZMVRCHOJAHYIZPAVZSAGJFQXUGXOIGOMIZWMIRN --ct-key COTUARBGQHZWXIELJMYKNSDFVP --pt-key PGLNWYMFQKSUTEZVOJBXDAHIRC
+TURNINGANDTURNINGINTHEWIDENINGGYRETHEFALCONCANNOTHEARTHEFALCONER
+