Merge pull request #209 from yzhernand/ch-010-yozen

Added solutions for challenge 10 by Yozen Hernandez

4 files changed, 204 insertions, 2 deletions

diff --git a/challenge-010/yozen-hernandez/README b/challenge-010/yozen-hernandez/README
index 0fc2b4a2cc..07779f04ee 100644
--- a/challenge-010/yozen-hernandez/README
+++ b/challenge-010/yozen-hernandez/README
@@ -1,3 +1 @@
 Solutions by Yozen Hernandez.
-
-WDI Gini data sourced from the World Bank from https://data.worldbank.org/indicator/SI.POV.GINI/?view=map and http://wdi.worldbank.org/table/1.3. Those data are licensed CC BY-4.0 by the World Bank (http://www.worldbank.org/).
diff --git a/challenge-010/yozen-hernandez/blog.txt b/challenge-010/yozen-hernandez/blog.txt
new file mode 100644
index 0000000000..66c0f49f34
--- /dev/null
+++ b/challenge-010/yozen-hernandez/blog.txt
@@ -0,0 +1 @@
+https://yzhernand.github.io/posts/perl-weekly-challenge-10/
\ No newline at end of file
diff --git a/challenge-010/yozen-hernandez/perl5/ch-1.pl b/challenge-010/yozen-hernandez/perl5/ch-1.pl
new file mode 100755
index 0000000000..ae24a9eff2
--- /dev/null
+++ b/challenge-010/yozen-hernandez/perl5/ch-1.pl
@@ -0,0 +1,116 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use Carp;
+use feature 'say';
+use constant MAX_INT => 3999;
+
+# Write a script to encode/decode Roman numerals.
+# For example, given Roman numeral CCXLVI, it should return 246.
+# Similarly, for decimal number 39, it should return XXXIX.
+
+# https://stackoverflow.com/a/267405/876844
+my $valid_roman
+    = qr/^M{0,4}(CM|CD|D?C{0,3})(XC|XL|L?X{0,3})(IX|IV|V?I{0,3})$/;
+
+my %roman_vals = (
+    'I' => 1,
+    'V' => 5,
+    'X' => 10,
+    'L' => 50,
+    'C' => 100,
+    'D' => 500,
+    'M' => 1000,
+);
+
+my %val_to_roman = (
+    1    => 'I',
+    4    => 'IV',
+    5    => 'V',
+    9    => 'IX',
+    10   => 'X',
+    40   => 'XL',
+    50   => 'L',
+    90   => 'XC',
+    100  => 'C',
+    400  => 'CD',
+    500  => 'D',
+    900  => 'CM',
+    1000 => 'M',
+);
+
+sub roman_to_int {
+    my $roman = shift;
+
+    # Won't happen with the way this script is coded
+    return 0 if $roman eq "";
+    croak "Error: Invalid Roman numeral.\n" unless $roman =~ $valid_roman;
+    my @roman_arr = split //, $roman;
+
+    my $decoded = 0;
+    my $val;
+
+    # Traverse string from left to right.
+    # Assume subtractive notation and increment while
+    # the value is the same or decreasing. Subtract
+    # from current if value increases.
+    # Assumes regex above allows only valid numerals
+    for ( my $r = 0; $r < @roman_arr; ) {
+        my $curr = $roman_arr[$r];
+        $val = $roman_vals{ $roman_arr[$r] };
+
+        # Consume all of the same value, adding along the way
+        while ( ++$r < @roman_arr && $curr eq $roman_arr[$r] ) {
+            $val += $roman_vals{ $roman_arr[$r] };
+        }
+
+        # If there's still more of the array, and the next
+        # value is greater than that of the current symbol,
+        # subtract value of current symbol. That is the new
+        # current value.
+        # This actually ignores the "extra" symbols in something
+        # like IIIX, which would be considered invalid anyway.
+        if (   $r < @roman_arr
+            && $roman_vals{$curr} < $roman_vals{ $roman_arr[$r] } )
+        {
+            $val = $roman_vals{ $roman_arr[$r] } - $roman_vals{$curr};
+            ++$r;
+        }
+
+        $decoded += $val;
+    }
+
+    return $decoded;
+}
+
+sub int_to_roman {
+    my $int = shift;
+    croak "Error: Integer exceeds maximum representable value."
+        if $int > MAX_INT;
+
+    my $str;
+    for my $val ( sort ( { $b <=> $a } keys %val_to_roman ) ) {
+
+        # Must find the largest numeral which can be subtracted
+        while ( $val <= $int ) {
+            $int -= $val;
+            $str .= $val_to_roman{$val};
+        }
+    }
+
+    return $str;
+}
+
+my $rm_num = shift or die "Usage: $0 <roman numeral>\n";
+my $to_int = roman_to_int($rm_num);
+say "$rm_num = $to_int";
+my $to_rm = int_to_roman($to_int);
+say "$to_int = $to_rm";
+
+if ( $rm_num eq $to_rm ) {
+    say "Hey, it worked!";
+}
+else {
+    say "Something's definitely wrong...";
+}
diff --git a/challenge-010/yozen-hernandez/perl5/ch-2.pl b/challenge-010/yozen-hernandez/perl5/ch-2.pl
new file mode 100755
index 0000000000..a331a857a8
--- /dev/null
+++ b/challenge-010/yozen-hernandez/perl5/ch-2.pl
@@ -0,0 +1,87 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use feature qw(say signatures);
+no warnings 'experimental::signatures';
+use List::Util qw(sum);
+
+# Write a script to find Jaro-Winkler distance between two strings.
+
+sub max ( $a, $b ) { ( $a > $b ) ? $a : $b }
+sub min ( $a, $b ) { ( $a < $b ) ? $a : $b }
+
+sub jaro {
+    my ( $s1, $s2 ) = @_;
+    my ( $len1, $len2 ) = ( length($s1), length($s2) );
+    my @s1 = split //, uc($s1);
+    my @s2 = split //, uc($s2);
+    return 0 if ( $len1 == 0 || $len2 == 0 );
+
+    # Find matching characters from s1 in s2
+    my $match_dist = int( max( $len1, $len2 ) / 2 ) - 1;
+    my ( @s1_matches, @s2_matches );
+
+    for ( my $i = 0; $i < @s1; ++$i ) {
+        my $win_start = max( 0, $i - $match_dist );
+        my $win_stop = min( $len2, $i + $match_dist + 1 );
+
+        for ( my $j = $win_start; $j < $win_stop; ++$j ) {
+            next if ( $s2_matches[$j] );
+            if ( $s1[$i] eq $s2[$j] ) {
+                $s1_matches[$i] = 1;
+                $s2_matches[$j] = 1;
+                last;
+            }
+        }
+    }
+
+    # Now count transpositions
+    # Get only the matching characters from each string.
+    @s1_matches = @s1[ grep { $s1_matches[$_] } 0 .. @s1_matches ];
+    @s2_matches = @s2[ grep { $s2_matches[$_] } 0 .. @s2_matches ];
+    my $matches = @s1_matches;
+
+    # Score is 0 if there are no matches
+    return 0 unless $matches;
+
+    my $transpositions;
+
+    # If sequence of characters is not the same, a transposition occurred
+    for ( my $i = 0; $i < @s1_matches; ++$i ) {
+        $transpositions += ( $s1_matches[$i] ne $s2_matches[$i] );
+    }
+
+    $transpositions /= 2;
+    return ( ( $matches / $len1 )
+        + ( $matches / $len2 )
+            + ( ( $matches - $transpositions ) / $matches ) ) / 3;
+}
+
+sub jaro_winkler {
+    my ( $s1, $s2 ) = @_;
+    my $sim_j = jaro( $s1, $s2 );
+    return 0 if $sim_j == 0;
+
+    my $p = 0.1;
+    my $max_len = max( length($s1), length($s2) );
+
+    # Find length of common prefix
+    my $l = 1;
+    while ( $l <= min( 4, $max_len ) ) {
+        last if ( substr( $s1, 0, $l ) ne substr( $s2, 0, $l ) );
+        ++$l;
+    }
+
+    $l--;
+
+    return $sim_j + $l * $p * ( 1 - $sim_j );
+}
+
+# Some test strings:
+my @set1 = qw(RICK DWAYNE MARTHA DIXON JELLYFISH);
+my @set2 = qw(RICK DUANE MARHTA DICKSONX SMELLYFISH);
+
+for ( my $i = 0; $i < @set1; ++$i ) {
+    say "$set1[$i]\t$set2[$i]\t" . (1-jaro_winkler( $set1[$i], $set2[$i] ));
+}