#!/usr/bin/perl -w use strict; use warnings; use List::Util qw( first ); # 1 # . . # . 8 . # . . . . # . . . . . # 0 # 1 2 # 3 4 5 # 6 7 8 9 # A B C D E my @adj = ( [ 1, 2 ], # 0 [ 0, 2, 3 ], # 1 [ 0, 1, 5 ], # 2 [ 1, 7, 6 ], # 3 [ ], # 4 [ 2, 8, 9 ], # 5 [ 3, 7, 10, 11 ], # 6 [ 3, 6, 11, 12, 8 ], # 7 [ 5, 7, 9, 12, 13 ], # 8 [ 5, 8, 13, 14 ], # 9 [ 6, 11 ], # A 10 [ 6, 7, 10, 12 ], # B 11 [ 7, 8, 11, 13 ], # C 12 [ 8, 9, 12, 14 ], # D 13 [ 9, 13 ], # E 14 ); my @color = qw( n c c c c c c c n s s s s s s s ); my @init_rack = qw( c 0 0 0 n 0 0 0 0 0 0 0 0 0 0 ); my $rack_ref = rack_em( \@init_rack, 6, 7 ); my $rack_out = q{ 0 1 2 3 4 5 6 7 8 9 A B C D E }; $rack_out =~ s/(\S)/$rack_ref->[hex $1]/g; print $rack_out; $rack_out =~ s/n/8/; my @colors = map { sprintf '%x', $_ } grep { $color[$_] eq 'c' } 1 .. 15; my @stripes = map { sprintf '%x', $_ } grep { $color[$_] eq 's' } 1 .. 15; $rack_out =~ s/c/shift @colors/ge; $rack_out =~ s/s/shift @stripes/ge; print $rack_out; sub rack_em { my ( $rack_ref, $sol_left, $str_left ) = @_; if ( ! $sol_left && ! $str_left ) { return $rack_ref; } my $missing_ball = first { $rack_ref->[$_] eq '0' } 0 .. 14; if ( ! defined $missing_ball ) { die "oops"; } if ( $sol_left > 0 && $str_left > 0 ) { my @rack_color = @{ $rack_ref }; my @rack_stripe = @{ $rack_ref }; $rack_color[$missing_ball] = 'c'; $rack_stripe[$missing_ball] = 's'; my $c_ref = rack_em( \@rack_color, $sol_left-1, $str_left ); my $s_ref = rack_em( \@rack_stripe, $sol_left, $str_left-1 ); return ( rack_assess( $c_ref ) < rack_assess( $s_ref ) ) ? $c_ref : $s_ref; } elsif ( $sol_left > 0 ) { $rack_ref->[$missing_ball] = 'c'; return rack_em( $rack_ref, --$sol_left, $str_left ); } elsif ( $str_left > 0 ) { $rack_ref->[$missing_ball] = 's'; return rack_em( $rack_ref, $sol_left, --$str_left ); } die 'unreachable code reached'; } sub rack_assess { my ( $rack_ref ) = @_; my $out = 0; foreach my $ball_index ( 0 .. 14 ) { my $ball_color = $rack_ref->[ $ball_index ]; my @adjacents = @{ $rack_ref }[ @{ $adj[$ball_index] } ]; my $matches = scalar grep { $_ eq $ball_color } @adjacents; $out += $matches; } return $out; } #### c s s c n c s s c s s c s c c 1 9 a 2 8 3 b c 4 d e 5 f 6 7