diff options
| -rwxr-xr-x | challenge-061/jaredor/perl/ch-1.pl | 293 | ||||
| -rwxr-xr-x | challenge-061/jaredor/perl/ch-2.pl | 191 | ||||
| -rwxr-xr-x | challenge-062/jaredor/perl/ch-1.pl | 272 |
3 files changed, 756 insertions, 0 deletions
diff --git a/challenge-061/jaredor/perl/ch-1.pl b/challenge-061/jaredor/perl/ch-1.pl new file mode 100755 index 0000000000..90aec18484 --- /dev/null +++ b/challenge-061/jaredor/perl/ch-1.pl @@ -0,0 +1,293 @@ +#!/usr/bin/env perl + +use v5.012; +use warnings; +use integer; +use Getopt::Long; +use Pod::Usage; +use List::Util qw(product all); +use Scalar::Util qw(looks_like_number); + +# PWC 061, TASK #1 : Product SubArray + +# Validate Input + +Getopt::Long::Configure( 'bundling_values', 'ignorecase_always', + 'pass_through' ); + +GetOptions( + 'help|h!' => \( my $help ), + 'task|t!' => \( my $task ), + 'test' => \( my $test ) +); + +pod2usage(1) if $help; +pod2usage( -exitval => 0, -verbose => 2 ) if $task; + +if ($test) { + + test(); + +} +else { + + # Use side-effect of modifying element in grep to remove "," & "[" & "]". + + my @intargs = grep { tr/][, //d; s/\A 0+ \B//xms; /\S/ } @ARGV; + + # Bundle up fatal input errors to report them all at once. + + my @errors; + push @errors, "Four or more integers needed" + unless 4 <= @intargs; + push @errors, "Some arguments do not look numeric" + unless all { looks_like_number $_ } @intargs; + push @errors, "Some arguments are not integers" + unless all { /\A [+-]? \d+ \Z/xms } @intargs; + pod2usage( join "\n", map { "ERROR: " . $_ } @errors ) if @errors; + + # Get the solution. + + output_results(@intargs); +} + +exit; # End of main script. + +# The main algorithm. + +sub get_maximal_product_sublists { + + return ( undef, [] ) unless @_ >= 4; + + my @list_of_ints = @_; + my ( $prev_prod, @prev, @curr, @hold ) = ( 0, ); + + for my $intarg ( ( @list_of_ints, 0 ) ) { + if ( $intarg <= 0 ) { + if ( $intarg < 0 ) { + if (@hold) { + @curr = ( @hold, @curr, $intarg ); + undef @hold; + } + else { + @hold = ( @curr, $intarg ); + undef @curr; + } + } + else { + pop @hold; # Remove neg val + for my $sublist ( \@hold, \@curr ) { + my $sublist_prod = product @$sublist; + if ( @$sublist and $sublist_prod >= $prev_prod ) { + @prev = () if $sublist_prod > $prev_prod; + push @prev, [@$sublist]; + $prev_prod = $sublist_prod; + } + } + undef @hold; + undef @curr; + } + } + else { + push @curr, $intarg; + } + } + + ( $prev_prod, @prev ) = ( 0, ( [@list_of_ints], ) ) unless @prev; + + return ( $prev_prod, [@prev] ); +} + +# Report to STDOUT from user command line input. + +sub output_results { + + my ( $max_prod, $max_sublists ) = get_maximal_product_sublists @_; + my @max_sublists = @$max_sublists; + + my $s = @max_sublists > 1 ? 's' : ''; + + say "\nMaximum product: $max_prod"; + + say "Maximal contiguous sublist$s with product:"; + + while (@max_sublists) { + my $sublist = shift @max_sublists; + say "\t[ ", join( ', ', @$sublist ), " ]"; + } +} + +# Built in test for the algorithm function. + +sub test { + + use Test::More; + my @input; + + @input = 1 .. 4; + is_deeply( + [ get_maximal_product_sublists @input ], + [ 24, [ [@input] ] ], + 'Basic start' + ); + + @input = (0) x 4; + is_deeply( + [ get_maximal_product_sublists @input ], + [ 0, [ [@input] ] ], + 'Four Zeroes' + ); + + @input = qw(2 5 -1 3); + is_deeply( + [ get_maximal_product_sublists @input ], + [ 10, [ [ 2, 5 ] ] ], + 'Task Example' + ); + + @input = qw(-1 0 -2 0 -3 0 -4 0 -5); + is_deeply( + [ get_maximal_product_sublists @input ], + [ 0, [ [@input] ] ], + 'No positive products' + ); + @input = qw(1 -1 0 -2 0 -3 0 -4 0 -5); + is_deeply( + [ get_maximal_product_sublists @input ], + [ 1, [ [1] ] ], + 'Leading 1, otherwise no positive prodcuts' + ); + @input = qw(-1 -1 0 -2 0 -3 0 -4 0 -5); + is_deeply( + [ get_maximal_product_sublists @input ], + [ 1, [ [ -1, -1 ] ] ], + 'Leading -1, first two terms are -1' + ); + + # The next 4 tests cumulatively modify the @input array. + + @input = 1 .. 10; + is_deeply( + [ get_maximal_product_sublists @input ], + [ 3628800, [ [@input] ] ], + 'Ten factorial' + ); + + $input[3] *= -1; + is_deeply( + [ get_maximal_product_sublists @input ], + [ 151200, [ [ @input[ 4 .. 9 ] ] ] ], + 'Ten factorial with a -4 factor instead of +4' + ); + + $input[6] *= -1; + is_deeply( + [ get_maximal_product_sublists @input ], + [ 3628800, [ [@input] ] ], + 'Ten factorial with a -4 & -7 factors instead of +4 & +7' + ); + + $input[8] *= -1; + is_deeply( + [ get_maximal_product_sublists @input ], + [ 40320, [ [ @input[ 0 .. 7 ] ] ] ], + 'Ten factorial with a -4 & -7 & -9 factors instead of +4 & +7 & +9' + ); + + # The next two tests demonstrate the illustration at the end of the + # INTERPRETATION section in the task. + + @input = qw(2 -1 -1 0 1 0); + is_deeply( + [ get_maximal_product_sublists @input ], + [ 2, [ [ @input[ 0 .. 2 ] ] ] ], + 'The [ 2, -1, -1 ] example from INTERPRETATION.' + ); + + push @input, 2; + is_deeply( + [ get_maximal_product_sublists @input ], + [ 2, [ [ @input[ 0 .. 2 ] ], [ $input[-1] ] ] ], + 'The [ 2, -1, -1 ] & [ 2 ] example from INTERPRETATION.' + ); + + done_testing(); +} + +__END__ + +=head1 NAME + +PWC 061, TASK #1 : Product SubArray + +=head1 SYNOPSIS + + ch-1.pl [options] integer1 integer2 integer3 integer4 [integer5 ... integerN] + + Options: + --help Brief help + --task Full description + --test Run embedded test + + Arguments: + Four or more integers must be supplied as input arguments. + +=head1 OPTIONS + +=over 8 + +=item B<--help> + +Brief help message. + +=item B<--task> + +Complete description of task and the script's attempt to satisfy it. + +=item B<--test> + +Run the embedded test suite for this script. + +=back + +=head1 DESCRIPTION + +Given a list of 4 or more numbers, write a script to find the contiguous sublist +that has the maximum product. The length of the sublist is irrelevant; your job +is to maximize the product. + +=head2 Example + +=head3 Input: + + [ 2, 5, -1, 3 ] + +=head3 Output: + + [ 2, 5 ] which gives maximum product 10. + +=head1 INTERPRETATION + +The problem says "4 or more numbers" but the example shows integers, so I +decided that "number" meant "integer" in this case. Things would be more +complicated (I think) if the problem allowed floating point, so I interpreted +"number" as "integer". + +The Input and Output in the example was a mix of notation for a perl array and +text, so I split the difference and allowed for anything that looked like the +task input on the command line, but it really just needs numeric arguments and +the command and brackets are just stripped out of the input. + +There can be more than one sub-list that produces a maximum product, so instead +of producing all sublists, only the maximal sublists are given. This effectively +means that padding with 1 and -1 are included in a sublist, e.g., both [ 2 ] and +[2, -1, -1] have a product of 2, but for the run of numbers, [2, -1, -1], only +the [2, -1, -1] sublist will be listed because the [ 2 ] list is a sublist +contained within. If [ 2 ] appears as a sublist somewhere else, it will be +listed if it is maximal. For example, with the list of integers +[ 2, -1, -1, 0, 1, 0 ] there is only one maximal sublist, [ 2, -1, -1 ], but for +the list [ 2, -1, -1, 0, 1, 0, 2 ] there are two maximal sublists [ 2, -1, -1 ] +and [ 2 ], the [ 2 ] list being the maximal sublist at the very end of the input +list. + +=cut diff --git a/challenge-061/jaredor/perl/ch-2.pl b/challenge-061/jaredor/perl/ch-2.pl new file mode 100755 index 0000000000..b1d2bfd8a3 --- /dev/null +++ b/challenge-061/jaredor/perl/ch-2.pl @@ -0,0 +1,191 @@ +#!/usr/bin/env perl + +use v5.012; +use warnings; +use integer; +use Getopt::Long; +use Pod::Usage; + +# PWC 061, TASK #2 : IPv4 Partition + +# Validate Input + +Getopt::Long::Configure( 'bundling_values', 'ignorecase_always', + 'pass_through' ); + +GetOptions( + 'help|h!' => \( my $help ), + 'task|t!' => \( my $task ), + 'test' => \( my $test ) +); + +pod2usage(1) if $help; +pod2usage( -exitval => 0, -verbose => 2 ) if $task; + +if ($test) { + + test(); + +} +else { + + # Bundle up fatal input errors to report them all at once. + + my @errors; + push @errors, "Only one argument allowed." + unless @ARGV == 1; + push @errors, "Only a string of 4 to 12 digits allowed." + unless $ARGV[0] =~ /\A \d{4,12} \Z/xms; + pod2usage( join "\n", map { "ERROR: " . $_ } @errors ) if @errors; + + my $digit_string = $ARGV[0]; + + # Get the solution. + + output_results($digit_string); +} + +exit; # End of main script. + +# The main algorithm. + +sub get_octets { + + my ( $octnum, $dstr ) = @_; + return undef if $octnum < 1; + $octnum -= 1; + + my $o_end = length($dstr) - $octnum; + my $o_beg = $octnum ? 1 : $o_end; + $o_end = 3 if $o_end > 3; + + my @octets; + for my $o_len ( $o_beg .. $o_end ) { + my ( $otet, $ostr ) = + ( substr( $dstr, 0, $o_len ), substr( $dstr, $o_len ) ); + next if $otet =~ /0\d/ or $otet > 255; + if ($octnum) { + push @octets, map { "$otet.$_" } get_octets( $octnum, $ostr ); + } + else { + push @octets, "$otet" unless "$ostr"; + } + } + return @octets; +} + +# Report to STDOUT from user command line input. + +sub output_results { + + my ($digit_string) = @_; + my @octets = get_octets( 4, $digit_string ); + if (@octets) { + say join( "\n", map { "\t$_" } @octets ); + } + else { + say "No IPv4 octets can be made from digit string, $digit_string."; + } +} + +# Built in test for the algorithm function. + +sub test { + + use Test::More; + my $input; + + $input = '25525511135'; + is_deeply( + [ get_octets 4, $input ], + [ '255.255.11.135', '255.255.111.35' ], + 'Task Example.' + ); + + $input = '0000'; + is_deeply( [ get_octets 4, $input ], ['0.0.0.0'], 'Four zeros' ); + + $input = '8675309'; + is_deeply( [ get_octets 4, $input ], ['86.75.30.9'], "Jenny's number" ); + + $input = '2311233211'; + is_deeply( + [ get_octets 4, $input ], + [ + '23.11.233.211', '23.112.33.211', + '231.1.233.211', '231.12.33.211', + '231.123.3.211', '231.123.32.11', + ], + "Six possibilities" + ); + + done_testing(); +} + +__END__ + +=head1 NAME + +PWC 061, TASK #2 : IPv4 Partition + +=head1 SYNOPSIS + + ch-2.pl [options] digit_string + + Options: + --help Brief help + --task Full description + --test Run embedded test + + Arguments: + The digit string must be 4 to 12 digits long. + +=head1 OPTIONS + +=over 8 + +=item B<--help> + +Brief help message. + +=item B<--task> + +Complete description of task and the script's attempt to satisfy it. + +=item B<--test> + +Run the embedded test suite for this script. + +=back + +=head1 DESCRIPTION + +You are given a string containing only digits (0..9). The string should have +between 4 and 12 digits. + +Write a script to print every possible valid IPv4 address that can be made by +partitioning the input string. + +For the purpose of this challenge, a valid IPv4 address consists of four +"octets" i.e. A, B, C and D, separated by dots (.). + +Each octet must be between 0 and 255, and must not have any leading zeroes. +(e.g., 0 is OK, but 01 is not.) + +=head2 Example + +=head3 Input: + + 25525511135 + +=head3 Output: + + 255.255.11.135 + 255.255.111.35 + +=head1 INTERPRETATION + +The DESCRIPTION was pretty complete. The recursive subroutine was written +directly from the spec, with a few logical deductions thrown in. + +=cut diff --git a/challenge-062/jaredor/perl/ch-1.pl b/challenge-062/jaredor/perl/ch-1.pl new file mode 100755 index 0000000000..9e55a2dedd --- /dev/null +++ b/challenge-062/jaredor/perl/ch-1.pl @@ -0,0 +1,272 @@ +#!/usr/bin/env perl + +# PWC 062, TASK #1 : Sort Email Addresses + +use v5.012; +use warnings; +use autodie; +use Getopt::Long; +use Pod::Usage; +use List::Util qw(first uniq); + +# Validate Input + +Getopt::Long::Configure( 'bundling_values', 'ignorecase_always', + 'pass_through' ); + +GetOptions( + 'unique|u' => \( my $unique ), + 'help|h!' => \( my $help ), + 'task|t!' => \( my $task ), + 'test' => \( my $test ) +); + +pod2usage(1) if $help; +pod2usage( -exitval => 0, -verbose => 2 ) if $task; + +my @errors; +-r or push @errors, "File $_ is not readable or non-existent." for @ARGV; +pod2usage( join "\n", map { "ERROR: " . $_ } @errors ) if @errors; + +test() and exit() if $test; + +# Get the solution. + +my $list = get_emails(); + +my @bogus_emails = remove_bogus_emails($list); + +say $_ for sort_emails( $list, $unique ); + +exit; # End of main script. + +#------------------------------------------------------------------------------- + +sub get_emails { + + my $lref; + s/\s//xmsg and /\S/ and push @{ $lref->{ lc $_ } }, $_ while (<>); + return $lref; +} + +sub remove_bogus_emails { + my ( $lref, ) = @_; + return map { @$_ } delete @$lref{ grep { 1 != tr/@/@/ } keys %$lref }; +} + +sub sort_emails { + my ( $lref, $uniq ) = @_; + + my @keys_sorted = + map { $_->[1] } + sort { $a->[0] cmp $b->[0] } + map { [ ( split '@' )[1], $_ ] } + keys %$lref; + + my $select_uniq = sub { + my ( %mailboxes, $m, $d ); + ( $m, $d ) = split '@' and push @{ $mailboxes{$m} }, $_ for @{ $_[0] }; + return map { ( sort @{ $mailboxes{$_} } )[0] } sort keys %mailboxes; + }; + + my $select_all = sub { + return + map { $_->[1] } + sort { $a->[0] cmp $b->[0] } + map { [ ( split '@' )[0], $_ ] } @{ $_[0] }; + }; + + my $select = $uniq ? $select_uniq : $select_all; + + return map { $select->($_) } @$lref{@keys_sorted}; +} + +sub test { + + use Test::More; + + require File::Temp; + use File::Temp (); + use File::Temp qw/ :seekable /; + close STDIN; + + my ( $lref, $aref, $uflag ); + my ( @list, @answ ); + + # Test get_emails() + + my ( $tmp, ) = File::Temp->new(); + print $tmp q{ + name@example.org + rjt@cpan.org + Name@example.org + rjt@CPAN.org + user@alpha.example.org + }; + close $tmp; + @ARGV = ( $tmp->filename, ); + + $lref = get_emails(); + $aref = { + 'user@alpha.example.org' => ['user@alpha.example.org'], + 'rjt@cpan.org' => [ 'rjt@cpan.org', 'rjt@CPAN.org' ], + 'name@example.org' => [ 'name@example.org', 'Name@example.org' ], + }; + is_deeply( $lref, $aref, 'Task Example.' ); + + # Test remove_bogus_emails() + + # First add in the bogus emails. + + open my $fh, '>>', $tmp->filename; + say $fh 'bogusATbogusATbogus.com'; + say $fh 'bogus@bogus@bogus.com'; + close $fh; + $aref->{'bogusatbogusatbogus.com'} = [ 'bogusATbogusATbogus.com', ]; + $aref->{'bogus@bogus@bogus.com'} = [ 'bogus@bogus@bogus.com', ]; + @ARGV = ( $tmp->filename, ); + $lref = get_emails(); + is_deeply( $lref, $aref, 'Task Example with two bogus emails added.' ); + + # Now take them out. + delete $aref->{'bogusatbogusatbogus.com'}; + delete $aref->{'bogus@bogus@bogus.com'}; + my @bogus_emails = remove_bogus_emails($lref); + is_deeply( $lref, $aref, + 'Task Example with two added bogus emails now removed.' ); + + # Test sort_emails() default + + $uflag = 0; + + @list = sort_emails( $lref, $uflag ); + @answ = ( + 'user@alpha.example.org', 'rjt@cpan.org', + 'rjt@CPAN.org', 'Name@example.org', + 'name@example.org', + ); + is_deeply( \@list, \@answ, 'Task Example with regular sort.' ); + + # Test sort_emails() unique + + $uflag = 1; + + @list = sort_emails( $lref, $uflag ); + @answ = ( + 'user@alpha.example.org', 'rjt@CPAN.org', + 'Name@example.org', 'name@example.org', + ); + is_deeply( \@list, \@answ, 'Task Example with unique sort.' ); + + done_testing(); +} + +__END__ + +=head1 NAME + +PWC 062, TASK #1 : Sort Email Addresses + +=head1 SYNOPSIS + + ch-1.pl [options] [ file_1 ... ] + + Options: + --unique Output one physical address per logical address. + --help Brief help + --task Full description + --test Run embedded test + + Arguments: + One or more files that consist solely of one email address per line. + + If no arguments are given, input data will be read from STDIN. + +=head1 OPTIONS + +=over 8 + +=item B<--unique> + +Implement a -u option analogous to the sort -u option. Since only the domain of +an email address is case-insensitive, this means that email addresses that only +differ by the case of the domain are functionally equivalent. When --unique is +used, the script must "decide" which email to use for all the functionally +equivalent ones. + +=item B<--help> + +Brief help message. + +=item B<--task> + +Complete description of task and the script's attempt to satisfy it. + +=item B<--test> + +Run the embedded test suite for this script. + +=back + +=head1 DESCRIPTION + +Write a script that takes a list of email addresses (one per line) and sorts +them first by the domain part of the email address, and then by the part to the +left of the @ (known as the mailbox). + +Note that the domain is case-insensitive, while the mailbox part is case +sensitive. (Some email providers choose to ignore case, but that's another +matter entirely.) + +If your script is invoked with arguments, it should treat them as file names and +read them in order, otherwise your script should read email addresses from +standard input. + +=head2 Bonus + +Add a -u option which only includes unique email addresses in the output, just +like sort -u. + +=head2 Example + +If given the following list: + + name@example.org + rjt@cpan.org + Name@example.org + rjt@CPAN.org + user@alpha.example.org + +Your script (without -u) would return: + + user@alpha.example.org + rjt@cpan.org + rjt@CPAN.org + Name@example.org + name@example.org + +With -u, the script would return: + + user@alpha.example.org + rjt@CPAN.org + Name@example.org + name@example.org + +=head1 INTERPRETATION + +The problem statement seems to imply a requirement that email addresses have +one and only one "@" symbol. In this script, only those strings with exactly +one "@" symbol will be sorted and output. The strings that fail this test, +"bogus emails" will be discarded. The script saves the discarded strings in a +separate array for testing and debugging purposes. + +One ambiguity is in how the unique address will be selected from a group of +functionally equivalent addresses. The example given narrows down the number of +ways to do this, there are still two plausible ones: 1) select the last +functionally equivalent email encountered; 2) select the one that would sort to +first position; + +For this script when a unique email is requested of a group of functionally +equivalent emails, the first email in the sorted group is returned. + +=cut |