Last weekend during our annual family reunion it rained the whole time, so we played a lot of indoor games.
One game which my niece was trying to solve was called Insanity. It consisted simply of a set of 4 cubes with differently colored faces. The colors were green, purple, red and yellow, and the object was to stack the cubes on top of one another in such a way as to have no duplicate colors in any of the 4 columns.
I thought it would be fun to write a Perl script to solve it using "brute force", but didn't get it finished until after we returned Sunday night. I was mostly interested in seeing whether there was only a single solution, or multiple solutions  in addition, of course, to the enjoyment of writing a fun Perl script. I'm presenting this as a challenge in case other monks would like to try it for themselves. I'm fairly sure someone can come up with a more elegant solution than my "brute force" method, or at least improve on its readability and/or speed.
The following represents the 4 cubes:
my $cube1 = 'pgpygr';
my $cube2 = 'rprrgy';
my $cube3 = 'ppryyg';
my $cube4 = 'rrygpy';
where 'g', 'p', 'r' and 'y' represent the colors 'green', 'purple', 'red' and 'yellow' respectively, and the colors in each string are, in order, the left, front, right, back, top and bottom faces. Thus, cube1 'pgpygr' represents the cube:
++
 g 
 green 
 
+++++
 p  g  p  y 
purple  green purple yellow 
    
+++++
 r 
 red 
 
++
For those not interested in trying to solve it themselves, my program is behind the following spoiler tags.
You can see by running the program that there appear to be 8 solutions. However, for each true solution, there will be 8 solutions detected; one for each of the 4 horizontal rotations of the entire stack, times 2 for allowing all cubes to be "flipped" upsidedown (180 degrees vertically). So the 8 apparent unique solutions in the program actually correspond to a single, truly unique solution.
#!/usr/bin/perl w
#
# Solves the 4colored cube game "Insanity", where the four cubes
# must be aligned in a stack, such that no column contains more than
# one color.
#
# Created 060625 by liverpole
#
# Strict
use strict;
use warnings;
# Libraries
use File::Basename;
# Globals
$ = 1;
my $b_verbose = 0; # If true, displays an ascii picture of the so
+lution
my $iam = basename $0;
my $cube1 = 'pgpygr';
my $cube2 = 'rprrgy';
my $cube3 = 'ppryyg';
my $cube4 = 'rrygpy';
# Create new cubes from the @data array
my @cubes = (
new_cube($cube1), new_cube($cube2), new_cube($cube3), new_cube($cu
+be4),
);
show_cubes("Starting cubes", @cubes);
# Solve cubes using brute force.
# Each cube is put into one of its possible 24 configurations, for a
# total of 24 ^ 4 configurations (331,776 total configurations).
#
my $total = 0;
my $nwins = 0;
my $pwins = { };
for (my $index0 = 0; $index0 < 24; $index0++) {
for (my $index1 = 0; $index1 < 24; $index1++) {
for (my $index2 = 0; $index2 < 24; $index2++) {
for (my $index3 = 0; $index3 < 24; $index3++) {
++$total;
if (won_game(\@cubes, $index0, $index1, $index2, $inde
+x3)) {
++$nwins;
}
}
}
}
}
# Display the number of unique solutions found
my $nuniq = (0 + (keys %$pwins)) / 8;
printf "Found $nwins of $total, $nuniq unique win(s)\n";
# Subroutines
#
# new_cube: creates a hash for the given string of color symbols
# ('g' = green, 'p' = purple, 'r' = red, 'y' = yellow)
#
sub new_cube {
my ($string) = @_;
my $c = '[gpry]';
if ($string !~ /($c)($c)($c)($c)($c)($c)/i) {
die "$iam: invalid format: '$string'\n";
}
my $pcube = {
'1' => lc $1, '2' => lc $2, '3' => lc $3,
'4' => lc $4, 'T' => lc $5, 'B' => lc $6,
};
return $pcube;
}
#
# flip_vertically: spins the cube pointed to by $1, so that the fron
+t
# square moves to the top, the bottom to the front,
# the top to the back, etc. Only the left and righ
+t
# squares remain unchanged. The cube is flipped th
+e
# number of times given by the count $2.
#
# Pictorially:
#
# Before: After:
# ++ ++
#    
#  E   B 
#    
# +++++ +++++
#          
#  A  B  C  D   A  F  C  E 
#          
# +++++ +++++
#    
#  F   D 
#    
# ++ ++
#
sub flip_vertically {
my ($p, $count) = @_;
for (my $i = 0; $i < $count; $i++) {
my ($cT, $c2, $cB, $c4) = ($p>{2}, $p>{B}, $p>{4}, $p>{T})
+;
($p>{2}, $p>{B}, $p>{4}, $p>{T}) = ($c2, $cB, $c4, $cT);
}
}
#
# rotate_horizontally: rotates the cube pointed to by $1 so that the
# left square moves to the front, the front to
+the
# right, the right to the back, etc. Only the
+top
# and bottom squares remain unchanged. The cub
+e is
# rotated the number of times given by the coun
+t $2.
#
# Pictorially:
#
# Before: After:
# ++ ++
#    
#  E   E 
#    
# +++++ +++++
#          
#  A  B  C  D   D  A  B  C 
#          
# +++++ +++++
#    
#  F   F 
#    
# ++ ++
#
sub rotate_horizontally {
my ($p, $count) = @_;
if ($count < 0) {
$count =  $count;
for (my $i = 0; $i < $count; $i++) {
my ($c4, $c1, $c2, $c3) = ($p>{1}, $p>{2}, $p>{3}, $p>
+{4});
($p>{1}, $p>{2}, $p>{3}, $p>{4}) = ($c1, $c2, $c3, $c4
+);
}
} elsif ($count > 0) {
for (my $i = 0; $i < $count; $i++) {
my ($c2, $c3, $c4, $c1) = ($p>{1}, $p>{2}, $p>{3}, $p>
+{4});
($p>{1}, $p>{2}, $p>{3}, $p>{4}) = ($c1, $c2, $c3, $c4
+);
}
}
}
#
# move_square_to_top: given a pointer to a cube hash $1, and a cube
# index $2 (in the range 0 ... 5), moves the giv
+en
# square into the top position.
#
sub move_square_to_top {
my ($p, $loc) = @_;
(0 == $loc) and rotate_horizontally($p, 1);
(2 == $loc) and rotate_horizontally($p, 1);
(3 == $loc) and rotate_horizontally($p, 2);
if (4 != $loc) {
flip_vertically($p, 1);
(5 == $loc) and flip_vertically($p, 1);
}
}
#
# change_position: given a pointer to a cube $1, and a position $2 (i
+n
# the range 0 ... 23), creates and returns a new cub
+e
# representing the original cube transformed to the
# new position.
#
sub change_position {
my ($pold, $pos) = @_;
# Copy a new cube, as a copy of the old one
my $pnew = { };
map { $pnew>{$_} = $pold>{$_} } (keys %$pold);
# Move one of 6 squares to the top
move_square_to_top($pnew, int($pos / 4));
# Rotate the cube horizontally from 0 to 3 squares
rotate_horizontally($pnew, $pos % 4);
return $pnew;
}
#
# same_color_in_column: returns nonzero if any of the cubes pointed
+to
# by $1, $2, $3 and $4 contain the same color
+in
# any of their 4 columns; zero otherwise.
#
sub same_color_in_column {
my ($p1, $p2, $p3, $p4) = @_;
for (my $i = 1; $i <= 4; $i++) {
my ($c1, $c2, $c3, $c4) = ($p1>{$i}, $p2>{$i}, $p3>{$i}, $p
+4>{$i});
if ($c1 eq $c2  $c1 eq $c3  $c1 eq $c4 
$c2 eq $c3  $c2 eq $c4  $c3 eq $c4) {
return 1;
}
}
return 0;
}
#
# won_game: returns nonzero if the game is won, for the array of
# cubes $1, and using the cube positions given respectivel
+y
# by $2, $3, $4 and $5. If the game is not won, zero is
# returned.
#
sub won_game {
my ($pcubes, $index0, $index1, $index2, $index3) = @_;
my $new1 = change_position($pcubes>[0], $index0);
my $new2 = change_position($pcubes>[1], $index1);
my $new3 = change_position($pcubes>[2], $index2);
my $new4 = change_position($pcubes>[3], $index3);
if (same_color_in_column($new1, $new2, $new3, $new4)) {
return 0;
}
my $winstr = show_cubes("Solution Found!", $new1, $new2, $new3, $n
+ew4);
print "\n";
++$pwins>{$winstr};
return 1;
}
#
# show_cubes: displays the given configuration of cubes, either as
# 4 strings of 6 faces each (left, front, right, back,
# top, bottom), or using an ascii "picture" of the cubes
# (if $b_verbose is nonzero).
#
sub show_cubes {
my ($msg, @cubes) = @_;
print "=== $msg ===\n";
my $winstr = "";
for (my $i = 0; $i < @cubes; $i++) {
my $idx = $i + 1;
my $cube = $cubes[$i];
$winstr .= show_cube($cube);
}
print "\n";
return $winstr;
}
#
# show_cube: displays an individual cube, either as a string of the
# 6 faces (left, front, right, back, top, bottom), or usi
+ng
# an ascii "picture" of the cube (if $b_verbose is nonzer
+o).
#
sub show_cube {
my ($p) = @_;
my ($c1, $c2, $c3, $c4) = ($p>{'1'}, $p>{'2'}, $p>{'3'}, $p>{'
+4'});
my ($cT, $cB) = ($p>{'T'}, $p>{'B'});
my $winstr = sprintf "%s %s %s %s %s %s", $c1, $c2, $c3, $c4, $cT,
+ $cB;
print "$winstr\n";
if ($b_verbose) {
print " ++\n";
printf "  \n";
printf "  $cT \n";
printf "  \n";
print " +++++\n";
printf "     \n";
printf "  $c1  $c2  $c3  $c4 \n";
printf "     \n";
print " +++++\n";
printf "  \n";
printf "  $cB \n";
printf "  \n";
print " ++\n";
print "\n";
}
return $winstr;
}
s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/
Re: Challenge: "Insanity" Cube Puzzle by bobf (Monsignor) on Jul 05, 2006 at 03:52 UTC 
Interesting puzzle, and a nice challenge. Thanks for the diversion. :)
I don't know if my solution is any more elegant, readable, or speedy*, but here it is:
Since the number of possible configurations for each of the 4 cubes is small (24), I generated them all up front and limited the data to only the 4 faces that would actually show (not the top or bottom faces). I then used a brute force method to search all possible combinations of configurations, but I didn't permute the order of the blocks (which would add another factor of 24 to the total number of solutions found). I also used extensive shortcircuiting to avoid checking combinations that were already known to be failures.
I printed all of the solutions to STDOUT as well as the total number found at the end. The format for each solution is as follows:
ggry
ypgr
rypp
pryg
Each cube is represented by a row, and the columns of text correspond to the columns created by each of the 4 faces of the cube stack. For example, one face of the stack is 'gyrp' (reading from the top to the bottom).
As you noted, 8 solutions are reported for each unique solution.
use strict;
use warnings;
# cube strings are the colors for the left, front, right, back, top
# and bottom faces, respectively
my @cubes = ( 'pgpygr', 'rprrgy', 'ppryyg', 'rrygpy' );
my ( $num_solutions, @opts );
foreach my $cube ( @cubes )
{
push( @opts, get_all_opts( $cube ) );
}
foreach my $cube0str ( @{ $opts[0] } )
{
foreach my $cube1str ( @{ $opts[1] } )
{
next if has_duplicate_faces( $cube0str, $cube1str );
foreach my $cube2str ( @{ $opts[2] } )
{
next if has_duplicate_faces( $cube0str, $cube2str );
next if has_duplicate_faces( $cube1str, $cube2str );
foreach my $cube3str ( @{ $opts[3] } )
{
next if has_duplicate_faces( $cube0str, $cube3str );
next if has_duplicate_faces( $cube1str, $cube3str );
next if has_duplicate_faces( $cube2str, $cube3str );
# we have a winner
print "**********\n";
print join( "\n", $cube0str, $cube1str,
$cube2str, $cube3str ), "\n";
$num_solutions++;
}
}
}
}
printf "\n\nFound $num_solutions %s (%d unique %s),\n",
$num_solutions == 1 ? 'solution' : 'solutions',
$num_solutions / 8,
$num_solutions / 8 == 1 ? 'solution' : 'solutions';
print "but by permuting the block order this total can be ",
"increased by a factor of 24\n";
sub get_all_opts
{
my ( $cubestr ) = @_;
my @opts;
# generate all 8 options for the rings around the
# X, Y, and Z axes of the cube
my @faces = split( //, $cubestr );
push( @opts, permute_ring( @faces[ 0,1,2,3 ] ) );
push( @opts, permute_ring( @faces[ 4,1,5,3 ] ) );
push( @opts, permute_ring( @faces[ 0,4,2,5 ] ) );
return( \@opts );
}
sub permute_ring
{
my ( @faces ) = @_;
# rotate and reverse the 4 faces
my @opts;
for ( 1 .. 4 )
{
push( @opts, join( '', @faces ) );
push( @opts, scalar reverse join( '', @faces ) );
push( @faces, shift( @faces ) );
}
return( @opts );
}
sub has_duplicate_faces
{
my ( $cube1, $cube2 ) = @_;
for( 0 .. 3 )
{
if( substr( $cube1, $_, 1 ) eq substr( $cube2, $_, 1 ) )
{
return 1;
}
}
return 0;
}
*Update: After downloading and running your code, my solution appears to be a bit faster. The shortcircuiting that I used meant that I only checked 12,480 4block combinations for the given input data, whereas your solution checks 331,776 combinations. I didn't run extensive benchmarks (which might be more interesting once other solutions are posted), but on my box your code took about 50 sec to run and mine took less than 1 sec. Your code has more error checking and output capability, though, so speed isn't everything. :)
 [reply] [d/l] [select] 
Re: Challenge: "Insanity" Cube Puzzle (tye's) by tye (Cardinal) on Jul 05, 2006 at 08:02 UTC 
The following runs in a fraction of second. I haven't looked at the other
code contributions so I won't try to compare code complexity. (:
You can't change which color is opposite which color on the cubes. So
each cube boils down to the 3 pairs of colors that are opposite each other on
that cube. If we label the stack of cubes to be built with X, Y, and Z axes,
then you can position each cube such that any of the three pairs shows on the
X axis in either order and either of the remaining pairs shows on the Y axis in
either order. It doesn't do any good to change the order in which the cubes
are stacked. For the first cube, the only positions that matter are 3 of them,
each cooresponding to a different pair of faces being hidden on the Z axis (the
other positions would just boil down to duplicates where the stack is rotated
or all 4 cubes on the stack are flipped along the same axis).
@cubes contains the four cubes, each as an array of color abbreviations grouped
in the array as pairs of colors that are on opposite faces of the cube.
So we let the first cubes assume 3 different positions. We let each subsequent
cube assume all 24 possible positions. For simplicity and speed, I precalculate
arrays that show which face goes on which side. @base holds three positions
that matter for the first cube. @full contains the mappings for all 24
orientations for subsequent cubes.
@side contains the colors showing on the sides of the stack as it is built, the
first two colors showing on opposite sides of the X axis, the last two on the
Y axis. setSides() adds the next 4 faces, adding one color to each side. If a
duplicate color is found, then 0 is returned immediately. Otherwise, 1 is
returned after all of the sides have been updated.
#!/usr/bin/perl w
use strict;
my @cubes= map [/./g], 'ppgygr', 'rrprgy', 'prpyyg', 'ryrgpy';
my @sides= ( '', '', '', '' );
my @base= map [/./g], '0123', '0145', '2345';
my @full;
# Populate @full:
for my $base ( @base ) {
my @perm= @$base;
for( 0..1 ) {
for( 0..1 ) {
for( 0..1 ) {
push @full, [ @perm ];
@perm[0,1,2,3]= @perm[2,3,0,1]; # Rotate 90deg; swap X
+/Y
}
@perm[2,3]= @perm[3,2]; # Flip to reverse faces on Y axis
}
@perm[0,1]= @perm[1,0]; # Flip to reverse faces on X axis
}
die if "@perm" ne "@$base";
}
# Try to explain format of the solution output:
print "For cubes 1, 2, 3, and 4. The colors showing:\n";
print "frnt back left right\n";
print "1234 1234 1234 1234\n";
# Build the stack one cube atatime:
for my $perm ( @base ) {
next if ! setSides( 0, $perm );
for my $perm ( @full ) {
next if ! setSides( 1, $perm );
for my $perm ( @full ) {
next if ! setSides( 2, $perm );
for my $perm ( @full ) {
if( setSides( 3, $perm ) ) {
print "@sides\n";
}
}
}
}
}
sub setSides {
my( $pos, $perm )= @_;
for my $cube ( $cubes[$pos] ) {
for my $idx ( 0..3 ) {
for my $side ( $sides[$idx] ) {
for my $face ( $cube>[ $perm>[$idx] ] ) {
substr( $side, $pos )= $face;
return 0 if index( $side, $face ) < $pos;
}
}
}
}
return 1;
}
 [reply] [d/l] 
Re: Challenge: "Insanity" Cube Puzzle by Ieronim (Friar) on Jul 05, 2006 at 13:27 UTC 
Regexpbased solution (finds only unique solutions for the puzzle and is very fast :))
The solution posted 5 days ago wasn't a solution at all :) I just realised that it solved a bit another puzzle :)
The updated pure rexepbased version is here:</p
#!/usr/bin/perl
use warnings;
use strict;
print ieronim_pure();
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;
}
 [reply] [d/l] 
Re: Challenge: "Insanity" Cube Puzzle by Limbic~Region (Chancellor) on Jul 05, 2006 at 15:53 UTC 
liverpole,
The following is also a bruteforce attack. I am only posting per our conversation in the CB.
#!/usr/bin/perl
use strict;
use warnings;
for (qw/pgpy ggyr gprp ypgp rygg prpg/) {
my @rotate = rotations($_);
for my $cube1 (@rotate) {
for (qw/rprr pgry gryr rrpr yrgp ryrg/) {
my @rotate = rotations($_);
for my $cube2 (@rotate) {
for (qw/ppry pyyg yrgp yrpp gyyp pgry/) {
my @rotate = rotations($_);
for my $cube3 (@rotate) {
for (qw/rryg rpgy pyyr gyrr ygpr ryyp/) {
my @rotate = rotations($_);
for my $cube4 (@rotate) {
my $sol = solution($cube1, $cube2, $cu
+be3, $cube4);
print "$sol\n\n" if $sol;
}
}
}
}
}
}
}
}
sub rotations {
my @rotate = shift @_;
my @color = split //, $rotate[0];
(push @color, shift @color) && (push @rotate, join '', @color) for
+ 1 .. 3;
return @rotate;
}
sub solution {
my ($cube1, $cube2, $cube3, $cube4) = @_;
for my $pos (0 .. 3) {
my %uniq = map { substr($_, $pos, 1) => undef } $cube1, $cube2
+, $cube3, $cube4;
return 0 if keys %uniq != 4;
}
return join "\n", $cube1, $cube2, $cube3, $cube4;
}
Update (20060706):
Here is a smarter bruteforce approach. It reduces the number of loops from 331,776 to 65,536:
#!/usr/bin/perl
use strict;
use warnings;
my @cube = map rotations($_), qw/pgpygr rprrgy ppryyg rrygpy/;
for my $c1 (@{$cube[0]}) {
for my $c2 (@{$cube[1]}) {
for my $c3 (@{$cube[2]}) {
for my $c4 (@{$cube[3]}) {
my $sol = solution($c1, $c2, $c3, $c4);
print "$sol\n\n" if $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 solution {
my ($cube1, $cube2, $cube3, $cube4) = @_;
for my $i (0 .. 3) {
my %uniq = map { $_>[$i] => undef } $cube1, $cube2, $cube3, $
+cube4;
return 0 if keys %uniq != 4;
}
return "@$cube1\n@$cube2\n@$cube3\n@$cube4";
}
Final Update (20060706):
This is an even smarter bruteforce approach. The number of total loops is less than 8,048 and It is quite fast.
#!/usr/bin/perl
use strict;
use warnings;
my @cube = map rotations($_), qw/pgpygr rprrgy ppryyg 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;
$used[$_]{$c3>[$_]} = 1 for 0 .. 3;
CUBE4:
for my $c4 (@{$cube[3]}) {
$used[$_]{$c4>[$_]} && next CUBE4 for 0 .. 3;
print "@$c1\n@$c2\n@$c3\n@$c4\n\n";
}
$used[$_]{$c3>[$_]} = 0 for 0 .. 3;
}
$used[$_]{$c2>[$_]} = 0 for 0 .. 3;
}
}
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;
}
 [reply] [d/l] [select] 

The total number of iterations needed to find all unique solutions is ((3*4)^4)/8 == 2592, as the unique solution does not depend on the cubes' order :) And all 8 solutions can be built using simple permutation of an array representing the unique one.
My regexp solution really uses the smallest possible number of loops, i think. Be stricter, it does not use loops at all to find the solution — only during the preprocessing :)))
It's difficult to make a good benchmark, as all presented scripts print their output directly to STDOUT and need to be a bit modified to become comparable by cmpthese(). But i'll try to do it today, if i have enough time.
 [reply] [d/l] [select] 

Ieronim,
I told liverpole in the CB that I didn't really have time to play with this but since he indicated I was the reason he posted it as a Challenge (see some of my previous posts), I felt obligated to do so. Without thinking about it too much, I decided just to bruteforce it and then see if there were any obvious optimizations on that. I do not expect it to be the fastest but it is fast enough.
With regards to benchmarking, it is almost never a good idea to include IO. Basically, the routines should be verified to produce essentially the same results first and then the output should be omitted. In other words, doing any preparation IO work before the bench, run the bench, and omit any IO output.
Update: Depending on how you count, the following only loops 1,152 times and still finds duplicates.
#!/usr/bin/perl
use strict;
use warnings;
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);
print "@$c1\n@$c2\n@$c3\n$sol\n\n" if $cube4{$sol};
}
}
}
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;
}
And the following performs even fewer (< 500):
#!/usr/bin/perl
use strict;
use warnings;
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);
print "@$c1\n@$c2\n@$c3\n$sol\n\n" if $cube4{$sol};
}
$used[$_]{$c2>[$_]} = 0 for 0 .. 3;
}
}
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;
}
 [reply] [d/l] [select] 

Re: Challenge: "Insanity" Cube Puzzle by reasonablekeith (Deacon) on Jul 06, 2006 at 15:39 UTC 
Not much more to see here, mainly posted because it worked :). Generates the solutions as in the OPs original post.
#!/perl w
use strict;
$=1;
my @cubes = ('pgpygr', 'rprrgy', 'ppryyg', 'rrygpy');
foreach my $c1perm (permuate_colours($cubes[0])) {
foreach my $c2perm (permuate_colours($cubes[1])) {
foreach my $c3perm (permuate_colours($cubes[2])) {
foreach my $c4perm (permuate_colours($cubes[3])) {
if ( validate($c1perm, $c2perm, $c3perm, $c4perm) ) {
print "Solution: $c1perm, $c2perm, $c3perm, $c4per
+m\n";
}
}
}
}
}
sub validate {
my (@colours) = @_;
my %seen;
foreach my $row (0..3) {
foreach my $cube (0..3) {
my $side_colour = substr($colours[$cube], $row, 1);
if (exists $seen{$row}{$side_colour}) {
return 0;
}
$seen{$row}{$side_colour}++;
}
}
return 1;
}
sub permuate_colours {
my ($colours) = @_;
my @perms;
for (1..4) {
for (1..4) {
push(@perms, $colours);
$colours =~ s/(.)(.)(.)(.)(.)(.)/$2$3$4$1$5$6/; # spin
}
$colours =~ s/(.)(.)(.)(.)(.)(.)/$1$6$3$5$2$4/; # roll
}
$colours =~ s/(.)(.)(.)(.)(.)(.)/$2$3$4$1$5$6/; # spin
$colours =~ s/(.)(.)(.)(.)(.)(.)/$1$6$3$5$2$4/; # roll
for (1..4) {
push(@perms, $colours);
$colours =~ s/(.)(.)(.)(.)(.)(.)/$2$3$4$1$5$6/; # spin
}
$colours =~ s/(.)(.)(.)(.)(.)(.)/$1$6$3$5$2$4/; # roll
$colours =~ s/(.)(.)(.)(.)(.)(.)/$1$6$3$5$2$4/; # roll
for (1..4) {
push(@perms, $colours);
$colours =~ s/(.)(.)(.)(.)(.)(.)/$2$3$4$1$5$6/; # spin
}
return @perms;
}

my name's not Keith, and I'm not reasonable.
 [reply] [d/l] 
Re: Challenge: "Insanity" Cube Puzzle by herby1620 (Monk) on Jul 11, 2006 at 00:53 UTC 
While I have not solved this problem, I remember a friend who worked on it back in the 60's/70's (I don't recall which). He had worked out a program for the IBM 1130 (in the language of the day: Fortran!) that went thru and found combinations of the cubes that would NOT work. It seems as though if you put the faces on correctly you can make it an insane puzzle. Now, I don't know the result of this musing, but given a set of cubes, and their available colors, making an "impossible" set might be a more difficult task. As I remember it they pryed apart the cubes and snapped them back to give the set to the math teacher or something like that.
Good luck!  [reply] 
Re: Challenge: "Insanity" Cube Puzzle by ambrus (Abbot) on Aug 06, 2008 at 18:39 UTC 
Here's my solution in the J programming language. The cubes in the example are defined near the beginning, but you can use any other cube colorings you wish. My solution uses brute force and is unoptimized, but on a modern machine it still runs within a few seconds so I don't care.
NB. Very inefficent wrt memory and somewhat inefficent wrt speed,
NB. but no need to optimize on a modern machine.
NB. a cube is a list of 6 sides (each atoms):
NB. left front right back top bottom.
NB. the first four of these sides are visible on the sides in a tower.
NB. a towers is a list of 4 cubes.
NB. colorings.
input =: >;: 'pgpygr rprrgy ppryyg rrygpy'
NB. all 24 rotations of a cube.
gens =: (i.6),'NSKTFL'i.'FSLTKN',:'SKTNFL'
rots =: ([:~.[:/:~[:,/{"1/)^:_~ gens
NB. all 24 rotations of each 4 cube.
posn =: rots {"_ 1 input
NB. stack a list of 4 lists of 24 cubes to a tower of 4 cubes in each
+24^4 way,
NB. order of 4 cubes doesn't matter.
stack =: [:>[:>[:,[:{[:<"1<"1
towers =: stack posn
NB. check if a cube is good or bad  rank 2, gives bool atom.
good =: [: (*./"1) 4 ({."1) 4 = [: (#@:~."1) :"2
solns =: (good # ]) towers
NB. each solution gives 8 trivially equivalent solutions because you c
+an
NB. rotate all cubes simultanously around the vertical axis or twice a
+round
NB. the horizontal axis. (this may be less than 8 for degenerate cube
+s.)
NB. rota y gives all 8 rotations of a tower y
rott =: (2{gens)&({"_ 1)
rotu =: ({~1{gens)&({"_ 1)
rota =: ([: ,/ [: rott^:(<4) rotu^:(<2))"2
NB. verify that each rotation of each solution is indeed among the sol
+utions.
assert =: 3 :'assert. y'
assert *./ solns e.~ ,/ rota solns
NB. now normalize the solutions by changing a tower to the
NB. lexicographically first out of these eight variants,
NB. and weed out repetitions.
norml =: ([:{.[:/:~rota)"2
solns1 =: ~./:~ norml solns
NB. output the solutions. there's just one if you use the sample
NB. cube colorings in the post.
echo solns1
echo #solns1
NB. end
The output lists all the solutions and then gives the number of solutions just in case there are so many they scrolled out of the screen. Each solution is the list of four rotated cubes each given as six colors like in the input.
The output is in spoiler tags.
ggrypp
ypgrrr
ryppyg
prygyr
1
Update:
Let's compare the output with that of some of the other solutions posted in this thread.
Most of the solutions just output the solution in a format similar to ours, except sometimes only the four visible sides are shown, so I visually compared one of their outputs to mine directly, and guessed the rest of the solutions they find would match as well. This table form is handy.
<"2 solns
+++++++++
ggyrppgrygppyggrppyrggppggryppgyrgpprggyppryggpp
pyrgrrpgryrrrypgrrrgpyrrypgrrryrgprrgpyrrrgryprr
yrppgyypprygprypygppyrgyryppygrppygypyrpgyppryyg
rpgyryrygpyrgpryyrgyrpryprygyrpgyrryyrpgryygpryr
+++++++++
To compare with the output of tye's script, we convert each solution to the format of his output. We can't use just the normalized solution because tye's script normalizes in a different way.
,/"2,"1&' ' :"2 (1 3 0 2){"1 solns
gyrp rgpy gpyr yrpg
rgpy gyrp gpyr yrpg
gyrp rgpy yrpg gpyr
rgpy gyrp yrpg gpyr
gpyr yrpg gyrp rgpy
yrpg gpyr gyrp rgpy
gpyr yrpg rgpy gyrp
yrpg gpyr rgpy gyrp
Indeed, output for index 4 is equal to tye's output.
I've checked the output of most solutions in this thread, and each seems to give at least one correct solution, or at most sneaked in so typos so smartly that I didn't notice them in my not too rigorous comparision. I don't yet understand the output of solutions in L~R's second order reply.
Update: I crossposted a description of the puzzle and my solution to the J wiki: Essays/InsanityCube.
Update 20101129: has anyone linked to the description of this puzzle (called Instant Insanity there) on Jaap's puzzle page?
 [reply] [d/l] [select] 
Re: Challenge: "Insanity" Cube Puzzle by ambrus (Abbot) on Apr 13, 2009 at 11:10 UTC 
 [reply] 

