I’ve been doing the Perl Weekly Challenges. The latest involved more bit counts and an innovative use of histograms.

TASK #1 › Count Set Bits

You are given a positive number $N.

Write a script to count the total numbrer of set bits of the binary representations of all numbers from 1 to $N and return $total_count_set_bit % 1000000007.

The number of set bits (aka population count or Hamming weight) is a standard CS problem, and it's one that's come up before in PWC. In fact the result of this particular challenge is OEIS #A000788. But I'll write my own code here.

In Perl I want to be unconstrained by MAXINT, and so I'll use Math::GMPz which is unreasonably shiny. (There are other ways to use GMP from Perl which are less close to the sharp moving blades of the underlying C library, Math::GMP and even Math::BigInt::GMP, but I want the dangerous functions exposed so that I can use some of them.) I could move the modulus operation out of the loop but let's pretend it's important.

sub csb {
  my $tot=shift;
  my $n=Math::GMPz->new(1);
  my $bits=Math::GMPz->new(0);
  my $m=Math::GMPz->new(1000000007);
  while ($n <= $tot) {
    Rmpz_add_ui($bits,$bits,Rmpz_popcount(Math::GMPz->new($n)));
    Rmpz_mod($bits,$bits,$m);
    Rmpz_add_ui($n,$n,1);
  }
  return Rmpz_get_str($bits,10);
}

For Raku I want to optimise for speed, so I do a straightforward bit comparison. (+& is bitwise and, while +> is bitwise shift right.)

sub csb($tot) {
  my $bits=0;
  my $m=1000000007;
  for 1..$tot -> $n {
    my $k=$n;
    while ($k > 0) {
      $bits += $k +& 1;
      $k +>= 1;
    }
    $bits %= $m;
  }
  return $bits;
}

For Python I'm taking a stringified binary representation and counting the "1" digits.

def csb(tot): bits=0 m=1000000007; for n in range(1,tot+1): bits += bin(n).count("1") bits %= m return bits

The latter two would work in each other's languages, and in Perl, too; I just felt like taking some different approaches.

TASK #2 › Trapped Rain Water

You are given an array of positive numbers @N.

Write a script to represent it as Histogram Chart and find out how much water it can trap.

The examples make this slightly clearer: if you drop water from +Y onto the chart, how much will remain rather than running off? Well, really, this is two separate problems, and the challenging one isn't the graphical bit.

I came up with a raster-based algorithm: for each row on the chart, make a list of the column numbers which reach at least as high as this row. For any pair, if they're not immediately adjacent, that's a trapped bit of water, so add it to the overall capacity.

sub capacity {
  my @n=@{shift @_};
  my $cap=0;
  foreach my $r (min(@n)..max(@n)) {
    my @b=grep {$n[$_]>=$r} (0..$#n);
    if (scalar @b > 1) {
      foreach my $i (0..$#b-1) {
        $cap += $b[$i+1]-$b[$i]-1;
      }
    }
  }
  return $cap;
}

Raku is basically the same:

sub capacity(@n) {
  my $cap=0;
  for (min(@n)..max(@n)) -> $r {
    my @b=grep {@n[$_] >= $r}, (0..@n.end);
    if (@b.elems > 1) {
      for (0..@b.end-1) -> $i {
        $cap += @b[$i+1]-@b[$i]-1;
      }
    }
  }
  return $cap;
}

And Python (though I use a list comprehension rather than a grep):`

def capacity(n):
    cap=0
    for r in range(min(n),max(n)+1):
        b=[i for i in range(0,len(n)) if n[i] >= r]
        if(len(b)>1):
            for i in range(0,len(b)-1):
                cap += b[i+1]-b[i]-1
    return cap

The histogram plotter is broadly the same code that I wrote for fun as the verbose solution to #75. It's very Perlish with ?: and x operators.

sub histo {
  my @n=@{shift @_};
  my $mx=max(@n);
  my $cw=int(log($mx+1)/log(10)+.9999);
  for (my $r=$mx;$r>0;$r--) {
    my @row=(sprintf('%'.$cw.'d',$r));
    push @row,map {($n[$_]>=$r?'#' x $cw:' ' x $cw)} (0..$#n);
    print join(' ',@row),"\n";
  }
  print join(' ',('-' x $cw) x (1+scalar @n)),"\n";
  print join(' ',map {sprintf('%'.$cw.'s',$_)} ('',@n)),"\n";
}

So it's a little bit of work to Raku-ify it (x is the string extender, xx is the array extender):

sub histo(@n) {
  my $mx=max(@n);
  my $cw=floor(log($mx+1)/log(10)+.9999);
  loop (my $r=$mx;$r>0;$r--) {
    my @row=(sprintf('%' ~ $cw ~ 'd',$r));
    push @row,map {(@n[$_]>=$r ?? '#' x $cw !! ' ' x $cw)}, (0..@n.end);
    say join(' ',@row);
  }
  say join(' ',('-' x $cw) xx (1+@n.elems));
  say join(' ',map {sprintf('%' ~ $cw ~ 's',$_)}, ('',@n).flat);
}

And rather more to Python-ify it, starting with no standard access to sprintf (the built-in format is all right but has its own special language). I unrolled the maps from the Perl version for ease of comprehension. Turns out that * is the equivalent of Perl's x in string-lengthening mode; not sure what the single-operator equivalent in array-lengthening mode is yet, though since a string is a special case of a list it may be the same thing.

def histo(n):
    mx=max(n)
    cw=int(log10(mx+1)+.9999);
    for r in reversed(range(1,mx+1)):
        row=list()
        row.append(format(r,str(cw)))
        for i in range(0,len(n)):
            s = ' '
            if(n[i] >= r):
                s = '#'
            s *= cw
            row.append(s)
        print(' '.join(row))
    s='-' * cw;
    print(' '.join([s for i in range(0,len(n)+1)]))
    row=list()
    row.append(' ' * cw)
    for i in n:
        row.append(format(i,str(cw)))
    print(' '.join(row))

Full code on github.