Merge pull request #2492 from ccntrq/challenge-081

Challenge 081

3 files changed, 96 insertions, 9 deletions

diff --git a/challenge-081/alexander-pankoff/README b/challenge-081/alexander-pankoff/README
index a74e2fd1ec..41f67807ac 100644
--- a/challenge-081/alexander-pankoff/README
+++ b/challenge-081/alexander-pankoff/README
@@ -1,10 +1 @@
 Solution by Alexander Pankoff
-
-# Run the Haskell solution
-
-With a `ghc` installation you can run the haskell solution with `runghc`
-
-```
-$ runghc haskell/ch-1.hs 1 2 3 -1 4
-5
-```
diff --git a/challenge-081/alexander-pankoff/perl/ch-1.pl b/challenge-081/alexander-pankoff/perl/ch-1.pl
new file mode 100644
index 0000000000..8dfb88a719
--- /dev/null
+++ b/challenge-081/alexander-pankoff/perl/ch-1.pl
@@ -0,0 +1,43 @@
+#!/usr/bin/env perl
+use v5.20;
+use utf8;
+use strict;
+use warnings;
+use autodie;
+use feature qw(say signatures);
+no warnings 'experimental::signatures';
+
+use List::Util qw(any);
+
+my ( $A, $B ) = @ARGV;
+$A //= "";
+$B //= "";
+
+say '(' . join( ', ', map { quote($_) } common_base_strings( $A, $B ) ) . ')';
+
+sub common_base_strings ( $a, $b ) {
+    return intersection( [ base_strings($a) ], [ base_strings($b) ] );
+}
+
+# finds all base strings of str
+sub base_strings($str) {
+    my @candidates =
+      map { substr( $str, 0, $_ ) } 1 .. length($str);
+    return grep { is_base_string( $_, $str ) } @candidates;
+}
+
+sub is_base_string ( $base, $str ) {
+    return $str =~ /^($base)+$/;
+}
+
+# returns a list of elems from $a that are also in $b
+sub intersection ( $a, $b ) {
+    grep {
+        my $a_elem = $_;
+        any { $_ eq $a_elem } @$b;
+    } @$a;
+}
+
+sub quote($str) {
+    return '"' . $str . '"';
+}
diff --git a/challenge-081/alexander-pankoff/perl/ch-2.pl b/challenge-081/alexander-pankoff/perl/ch-2.pl
new file mode 100644
index 0000000000..c560ba5cac
--- /dev/null
+++ b/challenge-081/alexander-pankoff/perl/ch-2.pl
@@ -0,0 +1,53 @@
+#!/usr/bin/env perl
+use v5.20;
+use utf8;
+use strict;
+use warnings;
+use autodie;
+use feature qw(say signatures);
+no warnings 'experimental::signatures';
+
+use List::Util qw(reduce);
+
+run_challenge();
+
+sub run_challenge() {
+    my ($input_file) = @ARGV;
+    my $frequencies_to_words =
+      frequency_sort( words( sanitize_input( read_file($input_file) ) ) );
+    print_word_frequencies($frequencies_to_words);
+}
+
+sub print_word_frequencies($frequencies) {
+    say join( ' ', $_, @{ $frequencies->{$_} } )
+      for sort { $a <=> $b } keys %{$frequencies};
+}
+
+sub frequency_sort(@words) {
+    my %word_count;
+    $word_count{$_}++ for @words;
+    my %frequencies;
+    push @{ $frequencies{ $word_count{$_} } }, $_ for sort keys %word_count;
+
+    return \%frequencies;
+}
+
+# split the given string into words
+sub words($str) {
+    return split( /\s+/, $str );
+}
+
+# replace illegal chars with whitespace
+sub sanitize_input($input) {
+    return $input =~ s/[\."\(\),]|--|'s/ /rg;
+}
+
+# read the whole file
+sub read_file($filename) {
+    local $/ = undef;
+    open( my $fh, '<', $filename );
+    my $out = <$fh>;
+    close($fh);
+    return $out;
+}
+