sudoku Puzzling in Perl #32

implementation

Solving was harder, and I actually still haven't found a great way to do it.

# returns undef   if the puzzle is complete
#         0       if no pruning took place
#         n       if N nodes were pruned
# 
# If nodes are pruned, patience is reset
#
sub naked_ntuple
{
  my ( $sobj, $curblock, %guesses ) = @_;
  my $pruned_nodes = 0;

  TUPLE:
  for my $tupleness ( 2, 3, 4 )
  {
     next TUPLE unless keys %guesses == $tupleness; 

     DIMENSION: 
     for my $dim ( 
                 $sobj->{col}->[ $curblock->{col} ],
                 $sobj->{row}->[ $curblock->{row} ],
                 $sobj->{block}->[ $curblock->{block} ],
                 )
     {
        my @candidates = grep { ! $_->{known} } @$dim;

        my @tuples = grep { contain_only( $_, \%guesses ) } 
                     @candidates;

        next DIMENSION unless $tupleness == @tuples;

        ## just keep the name of the tuples
        @tuples = map { $_->{square} } @tuples;
        my @tupvals = sort keys %guesses;

        ## if we've seen this tuple, disregard
        ## a given tuple is only prunable once
        if ( $curblock->{tuple} )
        {
           next DIMENSION 
              if grep  { array_eq( \@tuples, $_ ) } 
                       @{$curblock->{tuple}};
        }

        # we thus have a naked n-tuple
        # and can prune keys %guesses from items not our tuple
        my %retain; 
        @retain{@tuples} = @tuples;

        my @prunable = grep { 
                                !( $_->{known} || 
                                   defined $retain{$_->{square}} ) 
                                and array_contains( $_->{guess}, \@tupvals )
                            }
                       @$dim; 
        next DIMENSION unless @prunable;

        PRUNE:
        for my $pruney ( @prunable )
        {
           $pruney->{guess} = [ grep { ! $guesses{$_} } @{$pruney->{guess}} ];

           next PRUNE if @{$pruney->{guess}} > 1;

           ## shortcut, and mark any solved squares as such
           if ( @{$pruney->{guess}} == 1 )
           {
              return undef
                 unless mark_known( $sobj, $pruney, $pruney->{guess}->[0] );
           }
           else 
           {
              ## TODO croak
           }

        }

        ## we've seen this tuple, and pruned all we can as a result
        push @{$curblock->{tuple}}, [ @tuples ];
     }
  }

  return $pruned_nodes;

}
© fishbot