Re^4: Challenge: "Insanity" Cube Puzzle

[Ieronim]

I compared my new solution with your final and semi-final.

Here's the benchmark's code:

#!/usr/bin/perl

use warnings;
use strict;
use Benchmark 'cmpthese';

print limbic_final();
print "--------------------\n";
print ieronim_pure();

cmpthese( 500, {
    'ieronim (new)'  => 'my @results = ieronim_pure()',
    'L~R (semi)' => 'my @results = limbic_semifinal()',
    'L~R (final)' => 'my @results = limbic_final()'
});

sub ieronim_pure {
    #my @cubes = qw/pgpygr rprrgy ppryyg rrygpy/;
    my @cubes = qw/rprrgy ppryyg rrygpy/;
    my %seen;
    my $str = join("", map {$_, scalar reverse $_} "pgpy","ggry","pygr
+")
                ."!".join "!", 
                map { join "", grep {!$seen{$_}++} map {join "", @$_} 
+@$_} 
                map { [ rotate([@{$_}[0,1,2,3]]),
                        rotate([@{$_}[4,1,5,3]]),
                        rotate([@{$_}[0,4,2,5]]) ] } map { [split //] 
+} @cubes;

    my @result;
    my $re = qr/^(?:[^!]{4})*
                 (?:
                    ([^!])
                    ([^!])
                    ([^!])
                    ([^!])
                 )
                 (?:[^!]{4})*!
                 (?:[^!]{4})*
                 (?:
                    (?!\1)([^!])
                    (?!\2)([^!])
                    (?!\3)([^!])
                    (?!\4)([^!])
                 )
                 (?:[^!]{4})*!
                 (?:[^!]{4})*
                 (?:
                    (?!\1|\5)([^!])
                    (?!\2|\6)([^!])
                    (?!\3|\7)([^!])
                    (?!\4|\8)([^!])
                 )
                 (?:[^!]{4})*!
                 (?:[^!]{4})*
                 (?:
                    (?!\1|\5|\9)([^!])
                    (?!\2|\6|\10)([^!])
                    (?!\3|\7|\11)([^!])
                    (?!\4|\8|\12)([^!])
                 )(?{
                    push @result, [join("", $1,$2,$3,$4), 
                                   join("", $5,$6,$7,$8), 
                                   join("", $9,$10,$11,$12),
                                   join("", $13,$14,$15,$16)]
                })
                (?!)
                /x;
    #print $str;

    $str =~ /$re/;
    return map { join "\n", @$_, "", ""} @result;
}


sub rotate {
    my @strips;
    $strips[0] = shift;
    $strips[1] = [reverse @{$strips[0]}];
    my @rotated;
    foreach (0..$#{$strips[0]}) {
        foreach my $strip (@strips) {
            push @$strip, shift @$strip;
            push @rotated, [@$strip];
        }
    }
    return @rotated;
}

sub permute {
    my $ary = shift;
    return [$ary] if @$ary == 1;
    my @result;
    foreach my $i (0..$#{$ary}) {
        push @result, map { [$ary->[$i], @$_] } @{permute([@{$ary}[0..
+$i-1, $i+1..$#{$ary}]])};
    }
    return \@result;
}

##################################################################

sub limbic_final {
    my @result;
    my @cube = (
        [[qw/p g p y/], [qw/g g y r/], [qw/g g r p/]],
        rotations('rprrgy'),
        rotations('ppryyg'),
    );
    my %cube4 = map {("@$_" => 1)} @{rotations('rrygpy')};

    my @used;
    for my $c1 (@{$cube[0]}) {
        @used = map {{$_ => 1}} @$c1;
        CUBE2:
        for my $c2 (@{$cube[1]}) {
            $used[$_]{$c2->[$_]} && next CUBE2 for 0 .. 3;
            $used[$_]{$c2->[$_]} = 1 for 0 .. 3;
            CUBE3:
            for my $c3 (@{$cube[2]}) {
                $used[$_]{$c3->[$_]} && next CUBE3 for 0 .. 3;
                my $sol = find_sol($c1, $c2, $c3);
                push @result, "@$c1\n@$c2\n@$c3\n$sol\n\n" if $cube4{$
+sol};
            }
            $used[$_]{$c2->[$_]} = 0 for 0 .. 3;
        }
    }
    return @result;
}

sub find_sol {
    my ($c1, $c2, $c3) = @_;
    my @sol;
    for my $i (0 .. 3) {
        my %free = map {$_ => undef} qw/r g y p/;
        delete @free{ map $_->[$i], $c1, $c2, $c3 };
        push @sol, keys %free;
    }
    return "@sol";
}

sub rotations {
    my (%seen, @rot);
    my @cube = split //, shift @_;
    for ([0 .. 3], [1, 4, 3, 5], [4, 0, 5, 2]) {
        my @col = @cube[@$_];
        push @rot, map {push @col, shift @col; $seen{"@col"}++ ? () : 
+[@col]} 1..4;
        @col = reverse @{$rot[-1]};
        push @rot, map {push @col, shift @col; $seen{"@col"}++ ? () : 
+[@col]} 1..4;
    }
    return \@rot;
}

sub limbic_semifinal {
    my @result;
    my @cube = (
        [[qw/p g p y/], [qw/g g y r/], [qw/g g r p/]],
        rotations('rprrgy'),
        rotations('ppryyg'),
    );
    my %cube4 = map {("@$_" => 1)} @{rotations('rrygpy')};

    for my $c1 (@{$cube[0]}) {
        for my $c2 (@{$cube[1]}) {
            for my $c3 (@{$cube[2]}) {
                my $sol = find_sol($c1, $c2, $c3);
                push @result, "@$c1\n@$c2\n@$c3\n$sol\n\n" if $cube4{$
+sol};
            }
        }
    }
    return @result;
}

And here are the results:

                Rate    L~R (semi)   L~R (final) ieronim (new)
L~R (semi)    15.5/s            --          -94%          -97%
L~R (final)    258/s         1566%            --          -48%
ieronim (new)  500/s         3128%           94%            --