RogerBW's Blog

Perl Weekly Challenge 75: coins and rectangles 27 August 2020

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

  1. Posted by RogerBW at 05:08pm on 01 September 2020

    Looking at other solutions, the combinations function in Raku would have been useful for both problems.

    Naturally part 1 could have been done recursively, but I find that a FIFO buffer containing possible solutions gives better performance and is easier to debug.

Add A Comment

Your Name
Your Email
Your Comment

Your submission will be ignored if any field is left blank, but your email address will not be displayed. Comments will be processed through markdown.

Search
Archive
Tags 1920s 1930s 1940s 1950s 1960s 1970s 1980s 1990s 2000s 2010s 3d printing action aeronautics aikakirja anecdote animation anime army astronomy audio audio tech base commerce battletech beer boardgaming book of the week bookmonth chain of command children chronicle church of no redeeming virtues cold war comedy computing contemporary cornish smuggler cosmic encounter coup covid-19 cycling dead of winter doctor who documentary drama driving drone ecchi economics espionage essen 2015 essen 2016 essen 2017 essen 2018 essen 2019 existential risk falklands war fandom fanfic fantasy feminism film firefly first world war flash point flight simulation food garmin drive gazebo geodata gin gurps gurps 101 harpoon historical history horror hugo 2014 hugo 2015 hugo 2016 hugo 2017 hugo 2018 hugo 2019 hugo 2020 hugo-nebula reread humour in brief avoid instrumented life kickstarter learn to play leaving earth linux lovecraftiana mecha men with beards museum mystery naval non-fiction one for the brow opera perl perl weekly challenge photography podcast politics powers prediction privacy project woolsack pyracantha python quantum rail raku ranting raspberry pi reading reading boardgames social real life restaurant reviews romance rpg a day rpgs science fiction scythe second world war security shipwreck simutrans smartphone south atlantic war squaddies stationery steampunk stuarts suburbia superheroes suspense television the resistance thirsty meeples thriller tin soldier torg toys trailers travel type 26 type 31 type 45 vietnam war war wargaming weather wives and sweethearts writing about writing x-wing young adult
Special All book reviews, All film reviews
Produced by aikakirja v0.1