RogerBW's Blog

Perl Weekly Challenge 54: permutations and Collatz 21 April 2020

I’ve been doing the Perl Weekly Challenges. The latest involved generating permutations and checking the Collatz Conjecture.

Write a script to accept two integers n (>=1) and k (>=1). It should print the kth permutation of n integers. For more information, please follow the wiki page.

For example, n=3 and k=4, the possible permutation sequences are listed below:

123 132 213 231 312 321

The script should print the 4th permutation sequence 231.

I felt that the ordering of permutation sequences was not well-defined, but the example gives lexical order, so that's what I settled on. This means one doesn't have to generate the whole set of permutations; rather, one can use the index number (k in this example) to generate a Lehmer code that describes the individual permutation desired.

use integer;

my ($n,$k)=@ARGV;

This means we need to convert the index into factorial base, and the first step there is to generate a table of factorials.

my @f;
my $b=1;
my $v=1;
while ((scalar @f == 0) || $f[-1] < $k) {
  push @f,$v;
  $v*=$b;
  $b++;
}

Then, starting with the highest factorial generated, do a standard base conversion. (Note that the least significant digit is at the start of the array. Also that the unmodified sequence, "first permutation", is Lehmer code 0).

my $nk=$k-1;
my @n;
for (my $i=$#f;$i>=0;$i--) {
  unshift @n,$nk/$f[$i];
  $nk-=$f[$i]*$n[0];
}

Now we interpret that by pulling the indexed entries out of the unpermuted sequence.

my @i=(1..$n);
my @o;
for (my $i=$n;$i>=1;$i--) {
  my $f=$n[$i-1] || 0;
  push @o,splice @i,$f,1;
}

print join($n>9?',':'',@o),"\n";

Perl6 is basically identical modulo syntax, except that we don't have use integer;. This has most of the fiddly differences that have been tripping me up on previous occasions, so I'll include it in full.

my ($n,$k)=@*ARGS;

my @f;
my $b=1;
my $v=1;
while ((@f.elems == 0) || @f[@f.end] < $k) {
  push @f,$v;
  $v*=$b;
  $b++;
}

my $nk=$k-1;
my @n;
loop (my $i=@f.end;$i>=0;$i--) {
  unshift @n,floor($nk/@f[$i]);
  $nk-=@f[$i]*@n[0];
}

my @i=(1..$n);
my @o;
loop (my $j=$n;$j>=1;$j--) {
  my $f=@n[$j-1] || 0;
  push @o,splice @i,$f,1;
}

say join($n>9 ?? ',' !! '',@o);

It is thought that the following sequence will always reach 1:

$n = $n / 2 when $n is even $n = 3*$n + 1 when $n is odd For example, if we start at 23, we get the following sequence:

23 → 70 → 35 → 106 → 53 → 160 → 80 → 40 → 20 → 10 → 5 → 16 → 8 → 4 → 2 → 1

Write a function that finds the Collatz sequence for any positive integer. Notice how the sequence itself may go far above the original starting number.

Well, that's obvious enough:

use integer;

while (my $n=shift @ARGV) {
  my @k=($n);
  while ($n != 1) {
    if ($n % 2 == 0) {
      $n/=2;
    } else {
      $n*=3;
      $n++;
    }
    push @k,$n;
  }
  print join(', ',@k),"\n";
}

and Perl6 differs only as needed.

Extra Credit

Have your script calculate the sequence length for all starting numbers up to 1000000 (1e6), and output the starting number and sequence length for the longest 20 sequences.

One could do this by brute force, but one can short-cut evaluation by keeping a log of the length of each sequence that's already been evaluated. So in the example above, by the time we get to 23, we've already evaluated 20, so we don't need to recalculate the last seven steps from 20 down to 1.

use integer;

my %l;
my %s;

$l{1}=1;

foreach my $n (1..1e6) {
  my $k=1;
  my $na=$n;
  while (!exists $l{$na}) {
    if ($na % 2 == 0) {
      $na/=2;
    } else {
      $na*=3;
      $na++;
    }
    $k++;
  }
  $l{$n}=$k+$l{$na};
  push @{$s{$l{$n}}},$n;
}

The keys of %s are sequence lengths and the values are lists of starting numbers that give that length of sequence, so we just iterate down the keys until we've printed enough numbers.

my $k=20;
foreach my $c (sort {$b <=> $a} keys %s) {
  print "$c: ".join(', ',sort @{$s{$c}}),"\n";
  $k-=scalar @{$s{$c}};
  if ($k<=0) {
    last;
  }
}

The whole thing takes about 3½ seconds on my desktop machine. A potentially faster approach, though it would use more memory, would be to retain indices for the entire sequence; "26" already appears in the sequence for "7" so no new calculations need be done at all. However, on the same machine this version takes a little over 5 seconds.

I didn't do this one in Perl6; the syntax needed for its equivalent of push @{$s{$l{$n}}},$n with autovivification eluded me.

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 advent of code aeronautics aikakirja anecdote animation anime army astronomy audio audio tech base commerce battletech beer boardgaming book of the week bookmonth chain of command children chris chronicle church of no redeeming virtues cold war comedy computing contemporary cornish smuggler cosmic encounter coup covid-19 crime crystal cthulhu eternal cycling dead of winter doctor who documentary drama driving drone ecchi economics en garde espionage essen 2015 essen 2016 essen 2017 essen 2018 essen 2019 essen 2022 essen 2023 existential risk falklands war fandom fanfic fantasy feminism film firefly first world war flash point flight simulation food garmin drive gazebo genesys geocaching geodata gin gkp gurps gurps 101 gus harpoon historical history horror hugo 2014 hugo 2015 hugo 2016 hugo 2017 hugo 2018 hugo 2019 hugo 2020 hugo 2021 hugo 2022 hugo 2023 hugo 2024 hugo-nebula reread in brief avoid instrumented life javascript julian simpson julie enfield kickstarter kotlin learn to play leaving earth linux liquor lovecraftiana lua mecha men with beards mpd museum music mystery naval noir non-fiction one for the brow opera parody paul temple perl perl weekly challenge photography podcast politics postscript 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 rust scala science fiction scythe second world war security shipwreck simutrans smartphone south atlantic war squaddies stationery steampunk stuarts suburbia superheroes suspense television the resistance the weekly challenge 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