use strict; use warnings; open( OUTFILE, ">results.txt" ) or die "error opening output file"; # grid dimensions (max coord allowed) (used as globals so don't have to pass around) # note: this is not the number of cells in the grid, but the max coord (array index, starts at 0) my $GRID_X_MAX = 3; my $GRID_Y_MAX = 4; # set up starting grid, winning condition, and block definitions # each block has a unique letter, holes are 0 my @start_grid = qw( ABBC ABBC 0DD0 EFGH EIJH ); my %win = ( block => 'B', x => 1, y => 3 ); # upper left corner of block in winning position my %blocks = ( A => 'b', B => 'd', C => 'b', D => 'c', E => 'b', F => 'a', G => 'a', H => 'b', I => 'a', J => 'a', ); my %blocktypes = ( a => { xsize => 1, ysize => 1 }, b => { xsize => 1, ysize => 2 }, c => { xsize => 2, ysize => 1 }, d => { xsize => 2, ysize => 2 }, ); # xmove and ymove are used to adjust the coords # directions: up = u, down = d, left = l, right = r my %movemts = ( u => { undo => 'd', xmove => 0, ymove => -1 }, d => { undo => 'u', xmove => 0, ymove => 1 }, l => { undo => 'r', xmove => -1, ymove => 0 }, r => { undo => 'l', xmove => 1, ymove => 0 } ); my @current_options = ( [ 'start', @start_grid ] ); my ( %seen_grid, @winners ); while( scalar @winners == 0 ) { print "testing ", scalar @current_options, " options, "; my @next_options; foreach my $option ( @current_options ) { my ( $path, @grid ) = @{ $option }; my @next_moves = find_next_moves( \@winners, $path, @grid ); foreach my $move ( @next_moves ) { my $dir = shift @{ $move }; my $gridkey = join( '', @{ $move } ); # genericize the block pattern for uniqueness $gridkey =~ tr/ABCDEFGHIJ/bdbcbaabaa/; # this could be built from %blocks if( not exists $seen_grid{$gridkey} ) { push( @next_options, [ join( '-', $path, $dir ), @{ $move } ] ); $seen_grid{$gridkey}++; } } } print "found ", scalar @next_options, " options\n"; @current_options = @next_options; } foreach my $option ( @winners ) { my $path = shift @{ $option }; print OUTFILE "$path\n"; print OUTFILE ' ', join( "\n ", @{ $option } ), "\n"; } close OUTFILE; sub find_next_moves { my ( $ref2winners, $path, @grid ) = @_; my $last = substr( $path, -2 ); # create @orig_grid: $orig_grid[$y][$x] = $block # identify holes: [ $x, $y ], [...], ... # %blockpos: find the upper left corner of each block my ( @orig_grid, @holes, %blockpos ); process_grid( \@orig_grid, \@holes, \%blockpos, @grid ); # find blocks next to holes, store the dir they can move to fill the hole my %possible_blocks = find_blocks_to_move( \@orig_grid, \@holes ); # make sure the possible moves are valid (they don't overlap with another block) my @new_opts = (); my ( $lastblock, $lastdir ) = split( '', $last ); foreach my $block ( keys %possible_blocks ) { my @moves = split( '', $possible_blocks{$block} ); MOVE: foreach my $move ( @moves ) { if( $block eq $lastblock and $movemts{$move}{undo} eq $lastdir ) { next MOVE; # skip if undos last move } my ( $ref2newgrid, @new_grid_string ) = calc_new_grid( $block, $move, \@orig_grid ); if( not defined $ref2newgrid ) { next MOVE; } my $blockmove = join( '', $block, $move ); push( @new_opts, [ $blockmove, @new_grid_string ] ); if( grid_is_winner( $ref2newgrid ) ) { push( @{ $ref2winners }, [ join( '-', $path, $blockmove ), @new_grid_string ] ); } } } return ( @new_opts ); } sub process_grid { my ( $ref2grid, $ref2holes, $ref2blockpos, @grid ) = @_; for( my $y = 0; $y <= $GRID_Y_MAX; $y++ ) { @{ ${ $ref2grid }[$y] } = split( '', $grid[$y] ); for( my $x = 0; $x <= $GRID_X_MAX; $x++ ) { if( ${ $ref2grid }[$y][$x] eq 0 ) { push( @{ $ref2holes }, [ $x, $y ] ); } elsif( not defined ${ $ref2blockpos }{ ${ $ref2grid }[$y][$x] } ) { ${ $ref2blockpos }{ ${ $ref2grid }[$y][$x] }{x} = $x; ${ $ref2blockpos }{ ${ $ref2grid }[$y][$x] }{y} = $y; } } } } sub find_blocks_to_move { my ( $ref2orig_grid, $ref2holes ) = @_; my %blocks; foreach my $hole ( @{ $ref2holes } ) { my ( $hole_x, $hole_y ) = @{ $hole }; if( $hole_x > 0 and ${ $ref2orig_grid }[ $hole_y ][ $hole_x - 1 ] ne 0 ) { $blocks{ ${ $ref2orig_grid }[ $hole_y ][ $hole_x - 1 ] } = ( $blocks{ ${ $ref2orig_grid }[ $hole_y ][ $hole_x - 1 ] } || '' ) . 'r'; } if( $hole_x < $GRID_X_MAX and ${ $ref2orig_grid }[ $hole_y ][ $hole_x + 1 ] ne 0 ) { $blocks{ ${ $ref2orig_grid }[ $hole_y ][ $hole_x + 1 ] } = ( $blocks{ ${ $ref2orig_grid }[ $hole_y ][ $hole_x + 1 ] } || '' ) . 'l'; } if( $hole_y > 0 and ${ $ref2orig_grid }[ $hole_y - 1 ][ $hole_x ] ne 0 ) { $blocks{ ${ $ref2orig_grid }[ $hole_y - 1 ][ $hole_x ] } = ( $blocks{ ${ $ref2orig_grid }[ $hole_y - 1 ][ $hole_x ] } || '' ) . 'd'; } if( $hole_y < $GRID_Y_MAX and ${ $ref2orig_grid }[ $hole_y + 1 ][ $hole_x ] ne 0 ) { $blocks{ ${ $ref2orig_grid }[ $hole_y + 1 ][ $hole_x ] } = ( $blocks{ ${ $ref2orig_grid }[ $hole_y + 1 ][ $hole_x ] } || '' ) . 'u'; } } return( %blocks ); } sub calc_new_grid { my ( $block, $move, $ref2orig_grid ) = @_; my @new_grid = map { [ @{ $_ } ] } @{ $ref2orig_grid }; # find the position of $block my ( $orig_x, $orig_y ); for( my $y = 0; $y <= $GRID_Y_MAX; $y++ ) { for( my $x = 0; $x <= $GRID_X_MAX; $x++ ) { if( ${ $ref2orig_grid }[$y][$x] eq $block ) { ( $orig_x, $orig_y ) = ( $x, $y ); ( $x, $y ) = ( $GRID_X_MAX + 1, $GRID_Y_MAX + 1 ); # quit the loop } } } my $new_x = $orig_x + $movemts{$move}{xmove}; my $new_y = $orig_y + $movemts{$move}{ymove}; # delete the old positions for this block for( my $x = 1; $x <= $blocktypes{ $blocks{$block} }{xsize}; $x++ ) { for( my $y = 1; $y <= $blocktypes{ $blocks{$block} }{ysize}; $y++ ) { $new_grid[ $orig_y + $y - 1 ][ $orig_x + $x - 1 ] = 0; } } for( my $x = 1; $x <= $blocktypes{ $blocks{$block} }{xsize}; $x++ ) { for( my $y = 1; $y <= $blocktypes{ $blocks{$block} }{ysize}; $y++ ) { if( $new_grid[ $new_y + $y - 1 ][ $new_x + $x - 1 ] ne 0 ) { return; # skip if moving this block would overlap another block } else { $new_grid[ $new_y + $y - 1 ][ $new_x + $x - 1 ] = $block; } } } my @new_grid_string = map { join( '', @{ $_ } ) } @new_grid; return( \@new_grid, @new_grid_string ); } sub grid_is_winner { my ( $ref2grid ) = @_; my ( $check_x, $check_y ); for( my $y = $GRID_Y_MAX; $y >= 0; $y-- ) { for( my $x = $GRID_X_MAX; $x >= 0; $x-- ) { if( ${ $ref2grid }[$y][$x] eq $win{block} ) { ( $check_x, $check_y ) = ( $x, $y ); } } } return ( $check_x == $win{x} and $check_y == $win{y} ) ? 1 : 0; } #### Starting grid: ABBC ABBC 0DD0 EFGH EIJH Solutions are concatenated strings of 'block' . 'direction', where direction is r (right), l (left), u (up), d (down) start-Dl-Gu-Gr-Dr-Eu-Il-Jl-Hl-Gd-Gd-Dr-Fu-Ju-Ir-Ed-Fl-Dl-Cd-Cd-Br-Ar-Fu-Fu-Eu-Il-Eu-Jl-Hl-Gl-Gu-Cd-Dr-Hu-Ir-Ir-Hd-Ad-Fr-Eu-Ju-Hl-Ad-Ad-Jr-Ju-Dl-Cu-Ir-Gd-Dl-Cl-Iu-Gr-Cd-Dr-Dr-Au-Ed-Fl-Ju-Au-Cl-Gl-Id-Dd-Bd-Jr-Fr-Eu-Hu-Jr-Fr-Au-Cu-Gl-Gl-Il-Il-Dd-Bd-Fd-Fr-Ar-Cu-Cu-Bl-Fd-Fd-Jd-Jd-Ar-Cr-Er-Hu-Hu-Bl-Fl-Fu-Du-Ir-Gr-Ir-Gr-Bd-Fl-Fl-Jl-Jl-Du-Gu-Gr-Br final grid arrangement: HECA HECA FJDD 0BBG 0BBI start-Dr-Fu-Fl-Dl-Hu-Jr-Ir-Er-Fd-Fd-Dl-Gu-Iu-Jl-Hd-Gr-Dr-Ad-Ad-Bl-Cl-Gu-Gu-Hu-Hu-Ir-Jr-Er-Fr-Fu-Ad-Dl-Eu-Jl-Jl-Ed-Cd-Gl-Hu-Iu-Er-Cd-Cd-Il-Iu-Dr-Au-Jl-Fd-Dr-Ar-Ju-Fl-Ad-Dl-Dl-Cu-Hd-Gr-Iu-Cu-Ar-Fr-Jd-Dd-Bd-Il-Gl-Hu-Eu-Il-Gl-Cu-Au-Fr-Fr-Jr-Jr-Dd-Bd-Gd-Gl-Cl-Au-Au-Br-Gd-Gd-Id-Id-Cl-Al-Hl-Eu-Eu-Br-Gr-Gu-Du-Jl-Fl-Jl-Fl-Bd-Gr-Gr-Ir-Ir-Du-Fu-Fl-Bl final grid arrangement: CAHE CAHE DDIG FBB0 JBB0