Misioneros y caníbales, en Perl

#!/usr/bin/perl

=begin
Tres misioneros y tres caníbales quieren cruzar un río. Solo hay una canoa
que puede ser usada por una o dos personas, ya sean misioneros o caníbales.
 
Hay que tener cuidado en que en ningún momento el número de caníbales supere
al de misioneros en ninguna de las dos orillas, o se los comerán.
 
Juan J. Martínez <reidrac*en*usebox.net>
=cut

use strict;
use warnings;

use Clone qw(clone);

# comprueba si un estado es válido con las reglas del juego
sub estadoValido
{
    my @estado = @_;

    # el número de personajes tiene que ser correcto en cada lado
    if($estado[0][0] gt 3 || $estado[1][0] gt 3 ||
        $estado[0][1] gt 3 || $estado[1][1] gt 3 ||
        $estado[0][0] lt 0 || $estado[1][0] lt 0 ||
        $estado[0][1] lt 0 || $estado[1][1] lt 0)
    {
        return 0;
    }

    # el numero de misioneros debe ser >= que el de caníbales
    return 0 if $estado[0][0] lt $estado[0][1] && $estado[0][0] gt 0;
    return 0 if $estado[1][0] lt $estado[1][1] && $estado[1][0] gt 0;

    return 1;
}

# aplica el viaje al estado
sub aplicaViaje
{
    my $viaje = shift;
    
    # tenemos que hacer un "deep copy", sino se usarán referencias en
    # los vectores internos, y no es lo que queremos
    my @estado = @{clone(shift)};
    
    $estado[$estado[2]][0] -= $viaje->[0];
    $estado[$estado[2]][1] -= $viaje->[1];

    # la canoa cambia de orilla siempre en cada viaje
    $estado[2] = $estado[2] ? 0 : 1;

    $estado[$estado[2]][0] += $viaje->[0];
    $estado[$estado[2]][1] += $viaje->[1];

    return @estado;
}

# muestra un viaje en pantalla de una forma elegante (!)
sub muestra
{
    my $estado = shift;
        
    print "M: $estado->[0][0] C: $estado->[0][1] |";

    print ($estado->[2] ? "~~~~~~~~~~ \\____/" : "\\____/ ~~~~~~~~~~");

    print "| M: $estado->[1][0] C: $estado->[1][1]\n";
}

# compara en profundidad una estructura con vectores
sub compara
{
    my ($a, $b) = @_;
    
    return 0 if scalar(@$a) ne scalar(@$b);
    
    for (my $i = 0 ; $i < scalar(@$a) ; $i++)
    {
        if(ref($a->[$i]) eq 'ARRAY')
        {
            return 0 if !compara($a->[$i], $b->[$i]);
        }
        elsif ($a->[$i] ne $b->[$i])
        {
            return 0;
        }
    }

    return 1;
}

# busca un viaje en un vector de viajes
sub usado
{
    my ($nuevo, @previos) = @_;

    foreach (@previos)
    {
        return 1 if compara($_, $nuevo);
    }
    
    return 0;
}

# estado inicial
my $inicio = [[3, 3], [0, 0], 0];
# estado final
my $fin    = [[0, 0], [3, 3], 1];
# viajes posibles
my @viajes = ([1, 0], [0, 1], [1, 1], [2, 0], [0, 2]);

# guardamos los estados válidos
my @recorrido;
# los viajes que nos quedan de entre los posibles en cada estado válido
my @restantes;
# los viajes válidos restantes en el estado actual
my @parcial = @viajes;

# hasta que no lleguemos a la solución
while (!compara($inicio, $fin))
{
    # si nos quedamos sin viajes válidos en un estado, será el estado 0
    # y no habrá solución para el problema (no pasará!)
    if (!scalar(@parcial))
    {
        print "D'oh! no hay solución!\n";
        exit 1;
    }

    # mientras nos quedan viajes válidos, vamos probando
    while (scalar(@parcial))
    {
        my $viaje = shift(@parcial);
        
        # creamos un nuevo estado
        my @nuevo = aplicaViaje($viaje, $inicio);

        # si el estado es válido y no lo hemos usado, es un candidato
        if (estadoValido(@nuevo) && !usado(\@nuevo, @recorrido))
        {
            # guardamos el estado anterior
            push(@recorrido, [@$inicio]);
            # guardamos los viajes válidos que nos quedan
            push(@restantes, [@parcial]);
            
            # el nuevo estado pasa a estado actual
            $inicio  = \@nuevo;
            @parcial = @viajes;
            last;
        }
    }

    # si nos queamos sin viajes válidos pero tenemos almacenados estados
    # anteriores, podemos volver atrás y probar con otra rama
    if (!scalar(@parcial) && scalar(@recorrido))
    {
        # recuperamos el estado anterior
        $inicio = pop(@recorrido);
        # recuperamos los viajes válidos que faltaban por probar
        my $p = pop(@restantes);
        @parcial = @$p;
    }
}

# si hemos resuelto el juego, mostramos el resultado
if (compara($inicio, $fin))
{
    print "Resultado: \n";
    
    # mostramos los estados anteriores
    foreach(@recorrido)
    {
        muestra($_);
    }
    
    # y el último estado válido
    muestra($inicio);
}

exit 0;

# EOF