HKPS Programming Game Nov 28

q3.pl

=pod
time perl q3.pl
3 12312341235432
4 12312341235432
4 12312341235432
4 12312341235432
4 12312341235432
4 12312341235432
4 12312341235432
4 12312341235432
4 12312341235432
4 12312341235432
4 12312341235432
4 12312341235432
3 12312341235432
4 12312341235432
4 12312341235432
4 12312341235432
4 12312341235432
4 12312341235432
4 12312341235432
4 12312341235432
4 12312341235432
4 12312341235432
4 12312341235432
4 12312341235432

real	0m18.358s
user	0m18.312s
sys	0m0.008s
=cut


=pod
By observation and some combinatorial arguments which we will skip here,
we can say the ending should be 12345321 -> 12345123.

By trial and error, we get a sequence 12312341235432 which involves 4 digit changes.
So we try to find whether there are any possible smaller digit changes.
=cut
# Programming Competition by HKPS 2023-11-28 night
# Question 3
use v5.30.0;
use warnings;
use List::Util qw/sum/;
use Algorithm::Combinatorics qw/variations_with_repetition/;

my @arr = split "",   "12452341233432";
# my @arr = split "", "1245234123343212345321";
# my @arr = split "", "1434554415";

my @good = qw{12
    123
    1234
    12345
    54321
    5432
    543};


my $num = 1+$#arr;

for my $grp (2 .. 2 << $num) {
    my $str = unpack("b$num", pack("s", $grp-1));
    my @bin = split "", $str;
    if (sum(@bin) <= 4) {
        my @ints = map {$bin[$_] ? 0 : $arr[$_]} 0..$#arr;
        fill_good([@ints], sum(@bin));
    }
}

sub fill_good {
    my @ints = $_[0]->@*;
    my $num = $_[1];
    my $iter = variations_with_repetition([1..5], $num);
    while (my $p = $iter->next) {
        my @test;
        my $j = 0;
        for my $i (0..$#ints) {
            if ($ints[$i] != 0) {
                push @test, $ints[$i]; 
            } 
            else {
                push @test, $p->[$j];
                $j++;
            }
        }
        say "DIGITS:", $num, " ", "STRING: ", (join "", @test) if check_good(@test);
    }
}

sub check_good {
    my @news;
    my @r = @_;
    my $curr = $r[0].$r[1];
    for my $x (1..$#r-1) {
        if (  (length $curr == 1)
                        ||    
            (($r[$x-1]+1 == $r[$x]) && ($r[$x]+1 == $r[$x+1])) 
                           ||
            (($r[$x-1] == $r[$x]+1) && ($r[$x] == $r[$x+1]+1))
        ) {
            $curr .= $r[$x+1]
        } 
        else {
            push @news, $curr;
            $curr = $r[$x+1];
        }
    }
    push @news, $curr if $curr ne "";
    my $ans = 0;
    for my $term (@news) {
        for my $g (@good) {
            $ans++ if $term eq $g;
        }
    }
    return 1 if $ans == scalar @news;  # satisfy the criteria
    return 0;                          # not satisfy
}

my @arr = split "", "1434554415";

3 1234554312
4 1234554312
4 1234554312
4 1234554312
4 1234554312
4 1234554312
4 1234554312
4 1234554312
4 1234554321
3 1234554312
4 1234554312
4 1234554312
4 1234554312
4 1234554312
4 1234554312
4 1234554312
4 1234554312
4 1234554321

real 0m2.771s
user 0m2.757s
sys 0m0.004s