# ABC ACB BAC BCA CAB CBA: Perl Weekly Challenge #115

For last week’s Challenge, I used the same technique to handle two tasks, being the infinite `while(1)`

loop.

This week, I go to one well for two tasks again, and this is permutations. Given an array `['A', 'B', 'C']`

, you want to get every possible arrangement of those three characters. See the title for the (sorted) result, but the mechanism to get this is within Algorithm::Permute.

```
use Algorithm::Permute;
my @x = 'A' ... 'C';
my $ap = Algorithm::Permute->new( \@x );
my @pers;
while ( my @arr = $ap->next ) {
push @pers, join '', @arr;
}
say join ' ', sort @pers;
```

`Algorithm::Permute->new()`

creates an iterator, which simply allows you to grab the next permutation instead of creating a whole array of them.

They don’t come out in any particular order, so to get them into the form I wanted for the blog title, I `join`

ed and then `sort`

ed, using the default “It’s a string” behavior for the sort.

### TASK #1 › String Chain

Submitted by: Mohammad S Anwar

You are given an array of strings.Write a script to find out if the given strings can be chained to form a circle. Print 1 if found otherwise 0.

A string $S can be put before another string $T in circle if the last character of $S is same as first character of $T.

So, we’re given a list of strings, and simply put, the first character of one string in the list must match the last of another. They also must be *one* chain: `abc dea ijk lmi`

would give us two chains, not one, and should not match.

This looks like a job for permute to me, and the iterator form is great because we don’t fill up an array with permutations beyond what you test.

I start with `f_char`

and `l_char`

, instead of putting the `substr`

commands in directly, because I for one find `substr( $str, -1 + length $str, 1 )`

a little long and clunky. A perfectly cromulent addition is memoization, either with Memoize or a static hashref within the functions, but for this toy code, I’m happy as is.

We can iteratively test `f_char($arr[$i])`

against `l_char($i-1)`

, but if we leave it to that, we miss a link in the chain. I start with `if ( f_char( $res[0] ) eq l_char( $res[-1] ) ) { ... }`

to ensure that the non-iteratable link is covered.

And again, with the iterator and Algorithm::Permute, we only go through every permutation if there’s no chain.

#### Show Me The Code!

```
#!/usr/bin/env perl
use strict;
use warnings;
use feature qw{ postderef say signatures state };
no warnings qw{ experimental };
use Algorithm::Permute;
my @input;
push @input, [ "abc", "dea", "cd" ];
push @input, [ "ade", "cbd", "fgh" ];
for my $i (@input) {
my $v = is_chain( $i->@* );
say join " | ", $i->@*;
say $v? 'We can form a circle' : 'We cannot for a circle';
say ' ';
}
sub is_chain ( @links ) {
my $p = Algorithm::Permute->new( [@links] );
while ( my @res = $p->next ) {
my $i = join '-', @res;
my $c = 1;
if ( f_char( $res[0] ) eq l_char( $res[-1] ) ) {
for my $i ( 1 .. -1 + scalar @res ) {
$c++ if l_char( $res[ $i - 1 ] ) eq f_char( $res[$i] );
}
return 1 if $c == scalar @links;
}
}
return 0;
}
sub f_char( $str ) {
return substr( $str, 0, 1 );
}
sub l_char( $str ) {
return substr( $str, -1 + length $str, 1 );
}
```

```
abc | dea | cd
We can form a circle
ade | cbd | fgh
We cannot for a circle
```

### TASK #2 › Largest Multiple

Submitted by: Mohammad S Anwar

You are given a list of positive integers (0-9), single digit.Write a script to find the largest multiple of 2 that can be formed from the list.

We have two parts to this task:

- number formed with this list
- that is even (largest multiple of 2)

Without that “largest multiple of 2” requirement, it would be simple: `$n = join '', sort {$b<=>$a} @digits`

, or reverse sorting the digits and making a number out of, which Perl does implicitly.

This makes the easiest solution Algorithm::Permute (if it’s installed on your system), with `$i = 0 + join '', @res`

(which is not a verbatim quote from my code), and testing `$i % 2 == 0`

for evenness.

#### Show Me The Code!

```
#!/usr/bin/env perl
use strict;
use warnings;
use feature qw{ postderef say signatures state };
no warnings qw{ experimental };
use Algorithm::Permute;
my @input;
push @input, [ 1, 0, 2, 6 ];
push @input, [ 1, 4, 2, 8 ];
push @input, [ 4, 1, 7, 6 ];
for my $i (@input) {
my @arr = $i->@*;
my $join = join ', ', @arr;
my $len = largest_even_number( @arr );
say <<"END";
INPUT: ($join)
OUTPUT: $len
END
}
sub largest_even_number( @digits ) {
my $max = -1;
my $p = Algorithm::Permute->new( [@digits] );
while ( my @res = $p->next ) {
my $i = join '', @res;
$i += 0;
next unless $i % 2 == 0;
$max = $i if $i > $max;
}
return $max;
}
```

```
INPUT: (1, 0, 2, 6)
OUTPUT: 6210
INPUT: (1, 4, 2, 8)
OUTPUT: 8412
INPUT: (4, 1, 7, 6)
OUTPUT: 7614
```