diff options
| -rwxr-xr-x | challenge-218/e-choroba/perl/ch-1.pl | 59 | ||||
| -rwxr-xr-x | challenge-218/e-choroba/perl/ch-2.pl | 74 |
2 files changed, 133 insertions, 0 deletions
diff --git a/challenge-218/e-choroba/perl/ch-1.pl b/challenge-218/e-choroba/perl/ch-1.pl new file mode 100755 index 0000000000..6e03c400c4 --- /dev/null +++ b/challenge-218/e-choroba/perl/ch-1.pl @@ -0,0 +1,59 @@ +#! /usr/bin/perl +use warnings; +use strict; +use experimental qw( signatures ); + +# Optimisation: Select the 3 least and 3 greatest numbers and build +# the maximum product from them by trying all the possibilities. The +# least numbers are needed as they might introduce negative numbers. +sub maximum_product (@list) { + return maximum_product_simple(@list) if @list <= 6; + return maximum_product_simple((sort { $a <=> $b } @list)[0, 1, 2, -3, -2, -1]) +} + +sub maximum_product_simple (@list) { + return product(@list) if 3 == @list; + + my $max_product = product(@list[0, 1, 2]); + for my $i (0 .. $#list - 2) { + for my $j ($i + 1 .. $#list - 1) { + my $p_ij = product(@list[$i, $j]); + for my $k ($j + 1 .. $#list) { + my $prod = $p_ij * $list[$k]; + $max_product = $prod if $prod > $max_product; + } + } + } + return $max_product +} + +sub product { + my $p = 1; + $p *= $_ for @_; + $p +} + +use Test::More tests => 2 * 4 + 1; + +for my $maximum_product (*maximum_product{CODE}, + *maximum_product_simple{CODE} +) { + is $maximum_product->(3, 1, 2), 6, 'Example 1'; + is $maximum_product->(4, 1, 3, 2), 24, 'Example 2'; + is $maximum_product->(-1, 0, 1, 3, 1), 3, 'Example 3'; + is $maximum_product->(-8, 2, -9, 0, -4, 3), 216, 'Example 4'; +} + +my @long = map int(rand 100) - 50, 1 .. 20; +is maximum_product(@long), maximum_product_simple(@long), "same @long"; + +use Benchmark qw{ cmpthese }; +cmpthese(-3, { + simple => sub { maximum_product_simple(@long) }, + preselect => sub { maximum_product(@long) }, +}); + +__END__ + Rate simple preselect +simple 8665/s -- -94% +preselect 140390/s 1520% -- diff --git a/challenge-218/e-choroba/perl/ch-2.pl b/challenge-218/e-choroba/perl/ch-2.pl new file mode 100755 index 0000000000..20714112d9 --- /dev/null +++ b/challenge-218/e-choroba/perl/ch-2.pl @@ -0,0 +1,74 @@ +#!/usr/bin/perl +use warnings; +use strict; +use experimental qw( signatures ); + +sub matrix_score($m) { + my $height = @$m; + my $width = @{ $m->[0] }; + my $ser = serialise($m); + my %agenda = my %done = ($ser => undef); + my $max = score($ser, $width); + + while (%agenda) { + my %next; + for my $s (keys %agenda) { + for my $i (0 .. ($width, $height)[$width < $height] - 1) { + my @flips; + push @flips, flip_col($s, $i, $width, $height) if $i < $width; + push @flips, flip_row($s, $i, $width, $height) if $i < $height; + for my $f (@flips) { + unless (exists $done{$f}) { + my $score = score($f, $width); + $max = $score if $score > $max; + undef $next{$f}; + undef $done{$f}; + } + } + } + } + %agenda = %next; + } + return $max +} + +sub serialise($m) { join "", map @$_, map @$_, @_ } + +sub flip_col($s, $x, $width, $height) { + for my $y (0 .. $height - 1) { + my $pos = $x + $y * $width; + substr $s, $pos, 1, substr($s, $pos, 1) ? 0 : 1; + } + return $s +} +sub flip_row($s, $y, $width, $height) { + my $pos = $y * $width; + for my $x (0 .. $width - 1) { + substr $s, $pos, 1, substr($s, $pos, 1) ? 0 : 1; + ++$pos; + } + return $s +} + +sub score($s, $width) { + my $score = 0; + my $pos = 0; + while (length(my $row = substr $s, $pos, $width)) { + $score += oct "0b$row"; + } continue { + $pos += $width; + } + return $score +} + +use Test::More tests => 3 + 2; + +is score('111110011111', 4), 39, 'score'; +is flip_col('001110', 1, 3, 2), '011100', 'flip column'; +is flip_row('001110', 1, 3, 2), '001001', 'flip row'; + +is matrix_score([ [0,0,1,1], + [1,0,1,0], + [1,1,0,0], ]), 39, 'Example 1'; + +is matrix_score([ [0] ]), 1, 'Example 2'; |