Challenge 075 solutions in perl

2 files changed, 87 insertions, 0 deletions

diff --git a/challenge-075/shawn-wagner/perl/ch-1.pl b/challenge-075/shawn-wagner/perl/ch-1.pl
new file mode 100755
index 0000000000..51e2afceef
--- /dev/null
+++ b/challenge-075/shawn-wagner/perl/ch-1.pl
@@ -0,0 +1,44 @@
+#!/usr/bin/env perl
+use warnings;
+use strict;
+use feature qw/say/;
+use List::Util qw/sum0/;
+
+sub solve {
+  my ($C, $S) = @_;
+  if ($S == 0) {
+    return ([]);
+  }
+  my @solutions;
+  for my $coin (@$C) {
+    if ($S - $coin >= 0) {
+      push @solutions,  grep { sum0(@$_) == $S }
+        map { [ $coin, @$_ ] } solve($C, $S - $coin);
+    }
+  }
+  return @solutions;
+}
+
+sub task1 :prototype(\@$) {
+  my ($C, $S) = @_;
+  my @solutions = solve $C, $S;
+  # Get rid of duplicates. There's gotta be a cleaner way than this...
+  my %canonical;
+  local $" = ", ";
+  for my $solution (@solutions) {
+    my @sorted = sort { $a <=> $b } @$solution;
+    $canonical{"@sorted"}++;
+  }
+  @solutions = sort keys %canonical;
+  my $num = @solutions;
+  say "There are $num possible ways to make sum $S";
+  my $id = "a";
+  for my $solution (@solutions) {
+    say "$id) ($solution)";
+    $id++;
+  }
+}
+
+my @C = (1, 2, 4);
+my $S = 6;
+task1 @C, $S;
diff --git a/challenge-075/shawn-wagner/perl/ch-2.pl b/challenge-075/shawn-wagner/perl/ch-2.pl
new file mode 100755
index 0000000000..e95f1ec475
--- /dev/null
+++ b/challenge-075/shawn-wagner/perl/ch-2.pl
@@ -0,0 +1,43 @@
+#!/usr/bin/env perl
+use warnings;
+use strict;
+use utf8;
+use open qw/:std encoding(UTF-8)/;
+use feature qw/say/;
+use List::Util qw/max/;
+
+# Fancy unicode histogram printer
+sub histogram {
+  my @A = @_;
+  my $rows = max @A;
+  for my $row (reverse (1 .. $rows)) {
+    print $row, "│";
+    for my $col (@A) {
+      print $col >= $row ? "█" : " ", " ";
+    }
+    print "\n";
+  }
+  print " └", "──" x @A, "\n  ";
+  print $_, " " for @A;
+  print "\n";
+}
+
+sub task2 {
+  my @A = @_;
+  histogram @A;
+  my $maxsize = 0;
+  for my $left (0 .. $#A) {
+    for my $top (1 .. $A[$left]) {
+      for my $right ($left+1 .. $#A) {
+        last if ($A[$right] < $top);
+        my $size = ($right - $left + 1) * $top;
+        $maxsize = max $maxsize, $size;
+      }
+    }
+  }
+  say "Largest rectangle area: $maxsize";
+}
+
+task2 2, 1, 4, 5, 3, 7;
+print "\n";
+task2 3, 2, 3, 5, 7, 5;