Merge pull request #5611 from ccntrq/challenge-150

Challenge 150

4 files changed, 163 insertions, 0 deletions

diff --git a/challenge-150/alexander-pankoff/blog1.txt b/challenge-150/alexander-pankoff/blog1.txt
new file mode 100644
index 0000000000..576871fc50
--- /dev/null
+++ b/challenge-150/alexander-pankoff/blog1.txt
@@ -0,0 +1 @@
+https://pankoff.net/pages/perl-weekly-challenge/challenge-150-task-1.html
\ No newline at end of file
diff --git a/challenge-150/alexander-pankoff/blog2.txt b/challenge-150/alexander-pankoff/blog2.txt
new file mode 100644
index 0000000000..72a14acf2d
--- /dev/null
+++ b/challenge-150/alexander-pankoff/blog2.txt
@@ -0,0 +1 @@
+https://pankoff.net/pages/perl-weekly-challenge/challenge-150-task-2.html
\ No newline at end of file
diff --git a/challenge-150/alexander-pankoff/perl/ch-1.pl b/challenge-150/alexander-pankoff/perl/ch-1.pl
new file mode 100755
index 0000000000..ae2a254887
--- /dev/null
+++ b/challenge-150/alexander-pankoff/perl/ch-1.pl
@@ -0,0 +1,74 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use feature qw'say state signatures';
+no warnings qw'experimental::signatures';
+
+# TASK #1 › Fibonacci Words
+# Submitted by: Mohammad S Anwar
+#
+# You are given two strings having same number of digits, $a and $b.
+#
+# Write a script to generate Fibonacci Words by concatenation of the previous
+# two strings. Finally print 51st digit of the first term having at least 51
+# digits.
+# Example:
+#
+#     Input: $a = '1234' $b = '5678'
+#     Output: 7
+#
+#     Fibonacci Words:
+#
+#     '1234'
+#     '5678'
+#     '12345678'
+#     '567812345678'
+#     '12345678567812345678'
+#     '56781234567812345678567812345678'
+#     '1234567856781234567856781234567812345678567812345678'
+#
+#     The 51st digit in the first term having at least 51 digits
+#     '1234567856781234567856781234567812345678567812345678' is 7.
+
+run() unless caller();
+
+sub run() {
+
+    # For the current challenge we start by getting the two input words from the
+    # argument list.
+    my ( $a, $b ) = @ARGV;
+
+    # Afterwards we ensure both strings have equal lengths. We will not check
+    # that both words only contain digits as it doesn't matter for the algorithm
+    # wether we restrict the input to be only digits or allow arbitrary
+    # characters. (Actually it doesn't even matter that they are of the same
+    # length, but I will work with that restriction)
+    die "Expect two input words of equal length!\n"
+      unless length($a) && length($a) == ( length($b) // 0 );
+
+    # Now we pass both words to the meat of this solution, the `fibonacci_word`
+    # routine. We additionaly pass the minimum length of 51 charachters up to
+    # which we will build the fibonnaci word
+    my $fibonacci_word = fibonacci_word( $a, $b, 51 );
+
+    # Finally we extract the 51st charachter (at index 50) from the build word
+    # and print it out as our result.
+    my $target = substr( $fibonacci_word, 50, 1 );
+    say $target;
+
+}
+
+sub fibonacci_word ( $a, $b, $length ) {
+
+    # The actual fibonacci_word routine cries for a recursive solution. As
+    # always with a recursive solution we start with defining the exit
+    # condition, which is fullfilled as soon as the $a string reaches at least
+    # the requested length $length. In that case $a is the final fibonacci word
+    # and we return it to the caller
+    return $a if length($a) >= $length;
+
+    # Otherwise we continue the process, by passing $b as the new $a to the
+    # fibonacci_word routine and accumulating the next fibonacci word (the
+    # concatenation of $a and $b) into $b
+    return fibonacci_word( $b, $a . $b, $length );
+}
diff --git a/challenge-150/alexander-pankoff/perl/ch-2.pl b/challenge-150/alexander-pankoff/perl/ch-2.pl
new file mode 100755
index 0000000000..d150a933b4
--- /dev/null
+++ b/challenge-150/alexander-pankoff/perl/ch-2.pl
@@ -0,0 +1,87 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use feature qw'say state signatures';
+no warnings qw'experimental::signatures';
+
+# TASK #2 › Square-free Integer
+# Submitted by: Mohammad S Anwar
+#
+# Write a script to generate all square-free integers <= 500.
+#
+#     In mathematics, a square-free integer (or squarefree integer) is an
+#     integer which is divisible by no perfect square other than 1. That is, its
+#     prime factorization has exactly one factor for each prime that appears in
+#     it. For example, 10 = 2 ⋅ 5 is square-free, but 18 = 2 ⋅ 3 ⋅ 3 is not,
+#     because 18 is divisible by 9 = 3**2.
+#
+# Example
+#
+# The smallest positive square-free integers are
+#     1, 2, 3, 5, 6, 7, 10, 11, 13, 14, 15, 17, 19, 21, 22, 23, 26, 29, 30, ...
+
+run() unless caller();
+
+sub run() {
+
+    # For this challenge we can take advantage of perls builtin `grep` routine
+    # to filter the list of integers <=500 with a is_squarefree routine that we
+    # are about to define.
+    my @square_free = grep { is_squarefree($_) } 1 .. 500;
+
+    # Afterwards we print the filtered list, seperated by commas.
+    say join( ', ', @square_free );
+
+    # Done.
+}
+
+sub is_squarefree($x) {
+
+    # According to the description, we have to do two things to check if a
+    # number is squarefree.  First we get the prime factors of that number,
+    my @prime_factors = prime_factors($x);
+
+    # and then we check wether this list is free of duplicates.
+    return no_dupes(@prime_factors);
+}
+
+sub prime_factors($x) {
+    my @factors;
+    my $prime = 0;
+    while ( $x > 1 ) {
+        my $test_factor = primes($prime);
+        $prime++;
+        next unless $x % $test_factor == 0;
+        push @factors, $test_factor;
+        $x     = $x / $test_factor;
+        $prime = 0;
+    }
+    return @factors;
+}
+
+sub primes($n) {
+    state @primes = (2);
+
+    for ( my $i = $primes[-1] + 1 ; $#primes < $n ; $i++ ) {
+        push @primes, $i if is_prime($i);
+    }
+
+    return $primes[$n];
+}
+
+sub is_prime($x) {
+    return 0 if $x <= 1;
+    return 1 if $x <= 3;
+    for ( my $i = 2 ; $i < sqrt($x) ; $i++ ) {
+        return 0 if $x % $i == 0;
+    }
+    return 1;
+}
+
+sub no_dupes(@xs) {
+    my %seen;
+    for my $x (@xs) {
+        return 0 if $seen{$x}++;
+    }
+    return 1;
+}