#!/usr/bin/perl -w
#
#  Solves the 4-colored 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 solution
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($cube4),
);
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, $index3)) {
                    ++$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 front
#                    square moves to the top, the bottom to the front,
#                    the top to the back, etc.  Only the left and right
#                    squares remain unchanged.  The cube is flipped the
#                    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 cube is
#                        rotated the number of times given by the count $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 given
#                       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 (in
#                   the range 0 ... 23), creates and returns a new cube
#                   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}, $p4->{$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 respectively
#             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, $new4);
    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 using
#              an ascii "picture" of the cube (if $b_verbose is nonzero).
#
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;
}