Challenge: Setting Sun Puzzle

Limbic~Region has asked for the wisdom of the Perl Monks concerning the following question:

Replies are listed 'Best First'.

Re: Challenge: Setting Sun Puzzle
by thospel (Hermit) on Oct 04, 2004 at 17:53 UTC

Winning ways for your mathematical plays, volume 4

But to keep the subject more to perl, here is a quick and dirty program I made to solve it. If I didn't make mistakes (unlikely), the solution is 90 moves.

Read more... (4 kB)

_{janitored by ybiC: Balanced <readmore> tags around codeblock to 'hide' solution.}

[reply]
[d/l]

Re^2: Challenge: Setting Sun Puzzle

by Limbic~Region (Chancellor) on Oct 04, 2004 at 18:04 UTC

thospel

Cheers - L~R

[reply]

Re: Challenge: Setting Sun Puzzle
by tye (Sage) on Oct 04, 2004 at 19:02 UTC

Here is my solution.

#!/usr/bin/perl -w
use strict;
# A board is a string of 35 characters showing current positions
# and last move or two (so we don't just undo the last move):
# ,----. ,----. ,----. ,----. ,----. ,----. ,----. ,----.
# |AXXB| |AXXB| |AXXB| |AXXB| |AXXB| |AXXB| |AXXB| |AXXB|
# |AXXB| |AXXB| |AXXB| |AXXB| |AXXB| |AXXB| |AXXB| |AXXB|
# | HH | |HH< | |HH2 | |HH2 | |HH>2| |HH42| |HH42| |HH4v|
# |C12D| |C12D| |C1^D| |C14D| |C14D| |C1^D| |C1D<| |C1D2|
# |C34D| |C34D| |C34D| |C3^D| |C3 D| |C3 D| |C3D<| |C3D |
# `----' `----' `----' `----' `----' `----' `----' `----'
#        H<     H<2^   H<2^4^ ...
# On the end of the board we keep all the moves needed.
# We start with just one board and build the list of boards
# we can get with one more move.

$|= 1;
my $start= "#####AXXB#AXXB# HH #C12D#C34D######";
my @boards= $start;
my %double;
@double{ qw( A< A> B< B> C< C> D< D> H^ Hv X< X> X^ Xv ) }
    = (1) x 14;
my %offset= qw( < -1 > +1 ^ -5 v +5 );
my %size= qw( 1 1 2 1 3 1 4 1 A 2 B 2 C 2 D 2 H 2 X 4 );
my %back= qw( < > > < ^ v v ^ );
$back{' '}= ' ';
my @MovedX;
my $moves= 0;
my $dupCount= 1;
my %uniq;

while(  1  ) {
    @MovedX= ();
    print "Considering ", 0+@boards,
        " of $dupCount boards after $moves moves...\n";
    Dump( @boards )   if  @ARGV;
    @boards= map MoveAny($_), @boards;
    $dupCount= @boards;
    @boards= grep {
        my $board= substr( $_, 0, 35 );
        $board =~ tr[<>^v1234ABCDH]
                    [    OOOO||||=];
        ! $uniq{$board}++;
    } @boards;
    $moves++;
    # Dump( @MovedX );
}

sub MoveAny
{
    my( $board )= @_;
    my @boards;
    $board =~ /[<>v^ ]/g or die $board;  my @gap= pos($board)-1;
    $board =~ /[<>v^ ]/g or die $board;  push @gap, pos($board)-1;
    my %can;
    for my $gap (  @gap  ) {
        my $skip= $back{substr($board,$gap,1,' ')};
        for my $dir (  keys %offset  ) {
            next   if  $skip eq $dir;
            my $off= $offset{$dir};
            my $block= substr($board,$gap-$off,1);
            next   if  ! $size{$block};
            if(     ! $double{$block.$dir}
                ||  2 <= ++$can{$block.$dir}
            ) {
                push @boards, MoveThis( $board, $block, $dir, $off );
            }
        }
    }
    return @boards;
}

sub MoveThis
{
    my( $board, $block, $dir, $off )= @_;
    my @pos;
    while(  $board =~ /$block/g  ) {
        last   if  30 < pos($board);
        push @pos, pos($board)-1;
    }
    substr( $board, $_, 1, $dir )   for  @pos;
    substr( $board, $_+$off, 1, $block )   for  @pos;
    $board .= $block . $dir;
    Win($board)   if  $board =~ /XX[^#]##/;
    if(  "X" eq $block  ) {
        push @MovedX, $board;
    }
    return $board;
}

sub Dump
{
    my( @all )= @_;
    while(  @all  ) {
        my @boards= splice( @all, 0, 8 );
        for my $line (  0 .. 6  ) {
            for my $board (  @boards  ) {
                print " #", substr($board,5*$line,5);
            }
            print $/;
        }
        if(  1 == @boards  ) {
            print " ", substr($boards[0],35);
        } else {
            for my $board (  @boards  ) {
                printf " %-6s", substr(substr($board,35),-6);
            }
        }
        print $/;
    }
}

my $won;
sub Win
{
    return   if  $won++;
    my( $board )= @_;
    my @moves= substr($board,35) =~ /(..)/g;
    print "\n @moves\n\n";
    $board= $start;
    my @boards= $board;
    for my $move (  @moves  ) {
        my( $block, $dir )= $move =~ /(.)(.)/;
        substr( $board, 35 )= '';
        $board =~ tr/<>^v/    /;
        $board= MoveThis( $board, $block, $dir, $offset{$dir} );
        push @boards, $board;
    }
    Dump( @boards );
    exit 0;
}
[download]

And the output: