RogerBW's Blog

Perl Weekly Challenge 69: invertible numbers and very long strings 18 July 2020

I’ve been doing the Perl Weekly Challenges. The latest involved finding numbers that looked the same inverted, and generating a very long string.

A strobogrammatic number is a number that looks the same when looked at upside down.

You are given two positive numbers $A and $B such that 1 <= $A <= $B <= 10^15.

Write a script to print all strobogrammatic numbers between the given two numbers.

Example

Input: $A = 50, $B = 100 Output: 69, 88, 96

Not specified is whether "1" is regarded as looking the same upside down or not. I assume not.

I'm using Test::More as a harness as in the last few posts, and defining a function to do the work.

sub sg {
  my @range=@_;
  my @out;

Here is the key. Each entry in %charges shows the corresponding number after inversion. If 1 is allowed, add 1 => 1 to the list.

  my %charges=(
    6 => 9,
    9 => 6,
    8 => 8,
    0 => 0,
      );
  my $cm=join('',keys %charges);
 OUTER:
  foreach my $n ($range[0]..$range[1]) {

If the candidate number doesn't consist entirely of the digits in %charges, reject it. Also if it ends in zero.

    if ($n !~ /^[$cm]*$/) {
      next;
    }
    if ($n =~ /0$/) {
      next;
    }

Now build a list of the digits that must occur in the inverted number, indexed by their positions.

    my $nl=length($n)-1;
    my %locs;
    foreach my $pos (0..$nl) {
      $locs{$nl-$pos}=$charges{substr($n,$pos,1)};
    }

For each entry in that list, check whether it exists in the original number, and abort if not.

    foreach my $pos (keys %locs) {
      if (substr($n,$pos,1) ne $locs{$pos}) {
        next OUTER;
      }
    }

Otherwise, we have a valid invertible number.

    push @out,$n;
  }
  return \@out;
}

Raku was similar but had some key differences; I had to put the whole regexp into $cm rather than just the numeric contents, and my version of the interpreter still doesn't handle last OUTER correctly, so I patched round it with a trap value.

A 0/1 string is a string in which every character is either 0 or 1.

Write a script to perform switch and reverse to generate S30 as described below:

switch:

Every 0 becomes 1 and every 1 becomes 0. For example, “101” becomes “010”.

reverse:

The string is reversed. For example, "001” becomes “100”.

S0 = “” S1 = “0” S2 = “001” S3 = “0010011” … SN = SN-1 + “0” + switch(reverse(SN-1))

As originally stated, the problem required the generation of S1000; a casual inspection will show that the string length is 2^N-1, so this would take up approximately 10^301 bytes to represent, far larger than any plausible computer. This tasted like an Advent of Code problem: challenge accepted! (In AoC it would be something like "what is the value at position 3452348123879?")

Then later the problem was reduced to generating S30. Ah well, we can do that too.

Obviously a sequence of zeroes and ones isn't going to be a standard thing, but there are more zeroes than ones. So let's write the generator as proposed, but also output the indices of each one in the output. (Each string starts with the previous string, so that will be consistent.)

my $s='';
my $n=0;
while (1) {
  print "S$n = \"$s\"\n";
  my @i;
  my $l=-1;
  do {
    $l=index($s,'1',$l+1);
    if ($l>-1) {
      push @i,$l+1;
    }
  } while ($l!=-1);
  print join(',',@i),"\n";
  $s=plusone($s);
  $n++;
  sleep 1;
}

sub plusone {
  my $in=shift;
  return join('',$in,'0',switch(rev($in)));
}

sub switch {
  my $str=shift;
  $str =~ s/1/x/g;
  $str =~ s/0/1/g;
  $str =~ s/x/0/g;
  return $str;
}

sub rev {
  my @in=split '',shift;
  return join('',reverse @in);
}

That shows a sequence: 3,6,7,11,12,14,15,19,22,23,24,27,28,30,31,… and that can be fed into OEIS. Sure enough, out comes A091067.

(Probably one could prove this. I'm satisfied that the identity holds for arbitrarily high numbers.)

There's no generator code for that sequence, but there is for A060833 which is the same thing one higher. So I can implement that, which will give me the sequence of positions with 1s in them. All other positions have zeroes. And we know the total length.

(If you actually want S1000, you should probably use Math::BigInt.)

use List::Util qw(min);

my $s=1000; # or 30 if you're a wimp
my $l=2**$s-1;

my $pos=1;
my $seq=4;
while (1) {

Find the position of the next 1.

  my $p1=$seq-1;

Fill in the space up to that position with 0s.

  my $n0=min($p1-$pos,$l-$pos);
  print '0' x $n0;
  $pos+=$n0;

If there's string length left, print that 1.

  if ($p1<=$l) {
    print '1';
    $pos++;
  }
  if ($pos>$l) {
    last;
  }
  $seq=nextseq($seq);
}
print "\n";

sub nextseq {
  my $prev=shift;
  my $c=$prev;
  while (1) {
    $c++;
    my $t=$c-1;
    while (1) {
      my $r=int($t/2);
      if ($t % 2 != 0) {
        last;
      }
      $t=$r;
    }
    if ($t % 4 == 3) {
      last;
    }
  }
  return $c;
}

Raku is essentially identical.

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.

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 genesys 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 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 ruby 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