RogerBW's Blog

I’ve been doing the Perl Weekly Challenges. The latest involved an obscure class of number and a self-consistent string format. (Note that this is open until 7 March 2021.)

TASK #1 › Rare Numbers

You are given a positive integer $N.

Write a script to generate all Rare numbers of size $N if exists. Please checkout the page for more information about it.

I don't really recommend that you look at that page; the guy may be mathematically competent, but nobody should ever have told him how to change text colour or increase font size.

But anyway, this is clearly a large search space, so I'll take him at his word and use the optimisations he gives.

sub rn {
  my $d=shift;
  my @out;
  my $mxm=10**($d-2)-1;

The first digit has to have one of these values.

  foreach my $a (2,4,6,8) {

And the final digit, one of these.

    foreach my $q (0,2,3,5,7,8) {

Then we can constrain on possible combinations.

      if ($a==2 && $q!=2) {
        next;
      }
      if ($a==4 && $q!=0) {
        next;
      }
      if ($a==6 && $q!=0 && $q!=5) {
        next;
      }
      if ($a==8 && $q!=2 && $q!=3 && $q!=7 && $q!=8) {
        next;
      }

If we're dealing with just two digits, that's it for eliminating candidates, so on to the final check.

      if ($d==2) {
        my $t="$a$q";
        if (is_rare($t)) {
          push @out,$t;
        }

I couldn't be bothered to do the three-digit case, and there aren't any valid answers of three digits anyway (by inspection at OEIS). So we move straight on to longer examples.

      } else {

Iterate over all middle values. (I could have made this faster by taking only valid second and penultimate digits, then filling in any remaining middle digits for the 5+-digit case, but I was getting very bored by this point. So if you actually have a use for this code, there's an optimisation for you.)

        foreach my $middledigits (map {sprintf('%0'.($d-2).'d',$_)} 0..$mxm) {
          my $b=substr($middledigits,0,1);
          my $p=substr($middledigits,-1,1);

More constraints on these digit combinations.

          if ($a==2 && $b!=$p) {
            next;
          }
          if ($a==4 && abs($b-$p)%2 != 0) {
            next;
          }
          if ($a==6 && abs($b-$p)%2 != 1) {
            next;
          }
          if ($a==8) {
            if ($q==2 && $b+$p != 9) {
              next;
            } elsif ($q==3 && $b-$p != 7 && $p-$b != 3) {
              next;
            } elsif ($q==7 && $b+$p != 1 && $b+$p != 11) {
              next;
            } elsif ($q==8 && $b!=$p) {
              next;
            }
          }

Finally, test for rare-ness.

          my $t="$a$middledigits$q";
          if (is_rare($t)) {
            push @out,$t;
          }
        }
      }
    }
  }
  return \@out;
}

And that rarity test is to reverse, check that the number is larger than its reverse, then check that the difference and the sum are both perfect squares.

sub is_rare {
  my $t=shift;
  my $d=join('',reverse(split '',$t));
  if ($d >= $t) {
    return 0;
  }
  foreach my $c ($t+$d,$t-$d) {

No perfect square ends with these digits, and checking that is faster than actually taking the square root if we don't have to.

    if ($c =~ /[2378]$/) {
      return 0;
    }
    my $s=int(sqrt($c));
    unless ($s*$s==$c) {
      return 0;
    }
  }
  return 1;
}

So that's that. It's basically the same in other languages, though Rust makes the transitions between string and integer relatively hard work and Ruby makes it very easy.

This seemed like a long enough task to be worth a timing test, so I did. In each case, the test was run on the same unloaded system, running the program twice and timing the second run. Perl took 132 seconds; Python 151; Ruby 211; and naïve Rust (compiling at the start of the run and leaving all debug info in place) 177. When I set the Rust code to optimise for release, it still compiled in less than a second, and the execution time dropped to 17 seconds flat.

I don't know how long Raku would have taken; I gave up after half an hour (1800 seconds). Even with all the optimisations turned on. Maybe modern Raku is faster than the version in Debian/stable (Rakudo 2018.12, compiled 9 January 2019).

TASK #2 › Hash-counting String

You are given a positive integer $N.

Write a script to produce Hash-counting string of that length.

The definition of a hash-counting string is as follows:

• the string consists only of digits 0-9 and hashes, ‘#’
• there are no two consecutive hashes: ‘##’ does not appear in your string
• the last character is a hash
• the number immediately preceding each hash (if it exists) is the position of that hash in the string, with the position being counted up from 1

It can be shown that for every positive integer N there is exactly one such length-N string.

I'll take your word for it, but this does mean that a depth-first search is an obvious solution. I represent the string as the series of integers that will lie in it, with an initial "#" shown as a value of 1. In Raku:

sub hcs($n) {
  my @s;
  my @t;
  while (1) {
    @s=();
    my $l=0;

If we have a candidate stub, load it into @s and calculate its current length.

    if (@t.elems) {
      @s=(pop @t).flat;
      $l=sum(map {($_==1 ?? 0 !! chars($_))+1}, @s);
    }

If that's the target length, that valid answer must be the only one, so drop out with it. If it's longer than the target, no point in extending it further.

    if ($l==$n) {
      last;
    }
    if ($l > $n) {
      next;
    }

If we're still here, it's shorter than the target, so work out possible extensions. Most of the time there will only be one, which keeps the search space conveniently small: if you have "#3#" then the only possible extension is "5#". But an empty string can be extended to make "#" or "2#"; a 7-character string can be extended by "9#" or "10#"; and so on at ~100 characters, ~1000, etc.

    my $c=$l;
    while (1) {
      my $tt=($c==1 ?? 0 !! chars($c))+$l+1;
      if ($c==$tt) {
        my @k=(@s».List.flat);
        push @k,$c;
        push @t,@k;
      }
      if ($c > $tt) {
        last;
      }
      $c++;
    }
  }
  return join('',map {($_==1 ?? '' !! $_) ~ '#'}, @s);
}

and the other languages look basically similar.

Full code on github.