I’ve been doing the Perl Weekly
Challenges. The
latest
involved building set values of coins and finding rectangles in
histograms.
TASK #1 › Coins Sum
You are given a set of coins @C
, assuming you have infinite amount
of each coin in the set.
Write a script to find how many ways you make sum $S
using the
coins from the set @C
.
This could be done with a BFS and FIFO buffer, but I think it's more
efficient to iterate over plausible values.
For convenience I'll bring the input list into an array rather than
just work with the reference.
sub coinsum {
my $c=shift;
my @c=@{$c};
my $s=shift;
For each coin value, generate the maximum number of coins that is less
than or equal to the sum. We need never consider a number of that
coin that's greater than this.
my @m;
foreach (0..$#c) {
push @m,int($s/$c[$_]);
}
Now @b
will be the number of each coin in the sum under
consideration: (1,0,0) represents 1 of the first coin and none of the
others.
my @out;
my @b=(0) x scalar @c;
OUTER:
while (1) {
Generate the value of the pile of coins defined by @b
, and store the
solution. (This is actually a bug, see later, but for this minimal
solution it doesn't matter.)
my $v=sum(map {$c[$_]*$b[$_]} (0..$#c));
if ($v==$s) {
push @out,\@b;
}
Now increment @b
. Start at the first value, increment it, and if it
exceeds the maximum zero it and increment the next one. When you try
to increment off the end, break the loop because you've tried all
possible values. (This same basic pattern is one I quite often use for
an arbitrary number of nested loops.)
my $i=0;
while (1) {
$b[$i]++;
if ($b[$i]>$m[$i]) {
$b[$i]=0;
$i++;
if ($i>$#b) {
last OUTER;
}
} else {
last;
}
}
}
return scalar @out;
}
A more efficient version would iterate over just the first two
elements and calculate a suitable value for the last one (e.g. if I
have 2 already, a single 4 will do the job), but in a problem this
size it's not worth the optimisation.
I also wrote a "verbose" solution to produce the actual results, as
given in the examples. This starts off as before but replaces that
buggy line with
push @out,[@b];
because we want a snapshot of the values in @b
at that moment. Once
we have a valid @out
, we iterate through it to show the actual coin
values.
my $o=scalar @out;
if ($o==1) {
print "There is 1 possible way to make sum $s.\n";
} else {
print "There are $o possible ways to make sum $s.\n";
}
my @index=('a'..'z');
foreach my $li (0..$#out) {
my @a;
foreach my $i (0..$#{$out[$li]}) {
push @a,($c[$i]) x $out[$li][$i];
}
print $index[$li].') ('.join(', ',@a).")\n";
}
I didn't bother with verbose solutions for the other languages. The
basic version in Raku is quite similar (note @b.clone
), and of
course I have to use a temporary variable because breaking two loops
at once doesn't work in my (Debian/stable) interpreter.
sub coinsum(@c,$s) {
my @m;
for (0..@c.end) {
push @m,floor($s/@c[$_]);
}
my @out;
my @b=(0) xx @c.elems;
my $of=1;
while ($of) {
my $v=sum(map {@c[$_]*@b[$_]}, (0..@c.end));
if ($v==$s) {
push @out,@b.clone;
}
my $i=0;
while (1) {
@b[$i]++;
if (@b[$i]>@m[$i]) {
@b[$i]=0;
$i++;
if ($i>@b.end) {
$of=0;
last;
}
} else {
last;
}
}
}
return @out.elems;
}
Python turned out to be worryingly easy: I wrote it, and it worked
first time. That's not right. But breaking out of an inner loop is
impossible by design, so this ends up looking slightly more like the
Raku code than like the Perl.
List comprehensions are definitely feeling like the all-purpose tool
in Python that map
is in Perl. I probably could have used one while
constructing m
as well.
def coinsum(c,s):
m=list()
for i in range(len(c)):
m.append(int(s/c[i]))
out=list()
b=[0 for i in range(len(c))]
of=1
while of:
v=sum(c[i]*b[i] for i in range(len(c)))
if v==s:
out.append(b.copy())
i=0
while 1:
b[i]+=1
if b[i]>m[i]:
b[i]=0
i+=1
if i>len(b)-1:
of=0
break;
else:
break;
return len(out)
TASK #2 › Largest Rectangle Histogram
You are given an array of positive numbers @A.
Write a script to find the larget rectangle histogram created by the
given array.
BONUS: Try to print the histogram as shown in the example, if
possible.
Working out the algorithm is really the only challenging part of this.
sub lrhist {
my @c=@_;
my $bestarea=0;
my @n=(0,0);
I'll iterate across each possible column range (making this O(N²)),
and find the minimum value in that range. Multiply that by the number
of columns, and I get the area. Then store it if it's higher than any
previously-found areas. (I initially misread the problem and thought
that the actual column contents were wanted; you could omit both lines
with @n
in them.)
foreach my $a (0..$#c-1) {
foreach my $b ($a+1..$#c) {
my $area=($b-$a+1)*min(@c[$a..$b]);
if ($area>$bestarea) {
$bestarea=$area;
@n=($a,$b);
}
}
}
return $bestarea;
}
The bonus code continues rather than returning. First we calculate the
needed column width, based on the largest value:
my $mx=max(@c);
my $cw=int(log($mx+1)/log(10)+.9999);
Then for each row, descending, we print the value and the histogram
block. That's uglier than it needs to be, because I wanted to keep it
all inside a single map
, and using ($c[$_]>=$r?'#':' ') x $cw
puts
the x
operator into its list-generating mode.
for (my $r=$mx;$r>0;$r--) {
my @row=(sprintf('%'.$cw.'d',$r));
push @row,map {($c[$_]>=$r?'#' x $cw:' ' x $cw)} (0..$#c);
print join(' ',@row),"\n";
}
print join(' ',('-' x $cw) x (1+scalar @c)),"\n";
print join(' ',map {sprintf('%'.$cw.'s',$_)} ('',@c)),"\n";
Raku is basically the same.
This Python code also worked first time. Something wrong here! List
comprehension does the job of array slicing, and I will take a long
time to get used to that range
operator stopping one short of where
it "should". But not needing all those closing braces does at least
make the code a bit more vertically compact.
def lrhist(c):
bestarea=0
n=[0,0]
for a in range(len(c)-1):
for b in range(a+1,len(c)):
area=(b-a+1)*min(c[h] for h in range(a,b+1))
if (area>bestarea):
bestarea=area
n=[a,b]
return bestarea
Comments on this post are now closed. If you have particular grounds for adding a late comment, comment on a more recent post quoting the URL of this one.