In which we move beyond Perfect Permutation.

TWC Task #1 - Common Characters

Task:

Given a list of words, return the sorted list of the characters common to every word.

Raku

Map each word into a Set of characters, take the intersection of those Sets.

sub task1 ( @words --> Seq ) {
    return sort keys [∩] map *.lc.comb.Set, @words;
}

I needed keys because Sets are represented like Hashes of KEY => True, and we only want the key.

.Set was not actually needed within the map, because the intersection operator would interpret its input as Sets. I made it explicit for clarity.

Perl

Build a Bag of (character => count), then extract those characters with the same count as the number of words.

use v5.36;
use List::Util qw<uniq>;
sub task1 ( @words ) {
    my %h;
    $h{$_}++ for map { uniq split '', lc $_ } @words;

    return [ grep { $h{$_} == @words } sort keys %h ];
}

Note that uniq is key to making this work, otherwise multiples of a character within a word would fool the logic.

TWC Task #2 - Squareful

Task:

Given a list of integers, return all the permutations that are "squareful" (the sum of every adjacent pair is a perfect square).

Observations:

• We will need:

  1. A way to identify a perfect square.

  2. A way to either: A. identify that all adjacent pairs have a property, and a way to filter all permutations against it, or B. permute with early identification that some adjacent pair lack the property.

• I use $n.sqrt.round.² == $n (in Raku) or (int(sqrt $n) ** 2) == $n (in Perl) to spot perfect squares. Other methods that do not re-square the integer portion of the square root, such as .sqrt == .sqrt.Int and .sqrt % 1, will fail at (2 ** 26)² == 67108864² and above. .sqrt.narrow ~~ Int fails at 22351742².

• In Raku, sub task2_slow is my "permute and filter" solution. I did not use that approach in Perl.

• Handling our own permutation via recursion allows us to terminate branches early when we detect a failure, offering a huge performance increase. For example, [1..8] would have 8! == 40320 permutations, but we only have to check 24 of them.

Raku

Subroutine task2 can handle my whole test suite (which includes [1..25]) in 3 seconds.

sub is-perfect-square ( UInt $n --> Bool ) {
    return $n.sqrt.round.² == $n;
}

sub task2_slow ( @ns --> Seq ) {
    sub all-pairs-sum-to-perfect-squares ( @p --> Bool ) {
        return @p.rotor(2 => -1)
                 .map( *.sum.&is-perfect-square ).all.so;
    }
    return @ns.permutations
              .grep(&all-pairs-sum-to-perfect-squares)
              .sort.squish(:with(&[eqv]));
}

sub task2 ( @ns --> Seq ) {
    my %square_pairs = @ns.map: -> $a {
        $a => @ns.grep(-> $b { is-perfect-square($a + $b) }).Set;
    }

    my BagHash $n_count = @ns.BagHash;

    sub recursing ( UInt $head ) {
        return $head if not $n_count;

        return gather for %square_pairs{$head}{$n_count.keys}:k -> $c {
            $n_count{$c}--;
            .take for recursing( $c ).map({ $head, |$_ });
            $n_count{$c}++;
        }
    }

    return sort gather for $n_count.keys -> $head {
        $n_count{$head}--;
        .take for recursing( $head );
        $n_count{$head}++;
    }
}

Perl

Translation of the Raku code, with these notable changes:

1. My implementation of Bag is "insulated".

2. $square_pairs{$x}{$y} = $y; Set up for :k-replacing all-square-candidates

Note also the use of __SUB__ to recurse from within a anonymous sub.

use v5.36;
sub is_perfect_square ( $n ) {
    return $n == ( int(sqrt $n) ** 2 );
}

sub task2 ( @ns ) {

    my %square_pairs;
    for     my $x (@ns) {
        for my $y (@ns) {
            if ( is_perfect_square( $x + $y ) ) {
                $square_pairs{$x}{$y} = $y;
                $square_pairs{$y}{$x} = $x;
            }
        }
    }

    my ( $bag_add, $bag_del, $bag_keys, $bag_empty );
    {
        my %n_count;
        $bag_add   = sub($n){$n_count{$n}++};
        $bag_del   = sub($n){$n_count{$n}--;  delete $n_count{$n} if not $n_count{$n}};
        $bag_keys  = sub()  {sort { $a <=> $b } keys %n_count};
        $bag_empty = sub()  {                    not %n_count};
    }

    $bag_add->($_) for @ns;

    my $recursing = sub ( $head ) {
        return [$head] if $bag_empty->();

        my @ret;
        for my $c (grep {defined} @{$square_pairs{$head}}{$bag_keys->()}){
            $bag_del->($c);
            push @ret, map { [$head, @{$_} ] } __SUB__->( $c );
            $bag_add->($c);
        }
        return @ret;
    };

    my @ret;
    for my $head ( $bag_keys->() ) {
        $bag_del->($head);
        push @ret, $recursing->( $head );
        $bag_add->($head);
    }

    return \@ret;
}