## TWC 220: Squared Shoulders

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 `Set`

s.

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

I needed `keys`

because `Set`

s are represented like `Hash`

es 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 `Set`

s. 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:

A way to identify a perfect square.

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:

My implementation of Bag is "insulated".

$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;
}
```

## Leave a comment