File Coverage

blib/lib/Games/Sudoku/PatternSolver/Generator.pm

Criterion	Covered	Total	%
statement	135	146	92.4
branch	37	68	54.4
condition	15	35	42.8
subroutine	18	19	94.7
pod	2	8	25.0
total	207	276	75.0

package Games::Sudoku::PatternSolver::Generator;

use strict;
use warnings;

require 5.06.0;

use Games::Sudoku::PatternSolver::Patterns qw( init_patterns );
use Games::Sudoku::PatternSolver qw( solve print_grid );

use Bit::Vector;
use List::Util qw( shuffle );
use Time::HiRes ();

our @ISA = qw( Exporter );
our @EXPORT_OK = qw( get_sudoku_builder get_grid_builder print_grid );
our %EXPORT_TAGS = (
  'all' => \@EXPORT_OK,
);

our $VERBOSE     = 0;
our $LOOSE_MODE  = 0; # whether to allow puzzles to have < 8 different givens (still with an unique solution)

###########################################################

{
  my $grid_builder;

  # the grid at start doesn't matter for quality of the individual puzzle generated,
  # but all puzzles generated from a single static grid share the same solution
  sub get_sudoku_builder {
    my ($start_grid_string, $start_with, $shuffle_symbols) = @_;

    set_solver_config();

    if ($start_grid_string) {
      my $sudoku = solve($start_grid_string)
        or return 0;

      my $sc = $sudoku->{solutionCount};

      if ($sc != 1) {
          printf "No way to reduce: Start grid %s and is invalid!\n", ($sc > 1) ? 'already has more than one solutions' : 'has NO solution';
        return 0;
      }
    }

    my $check_reducibility = ($start_grid_string && $start_grid_string =~ /[^1-9]/) ? 1 : 0;

    $start_with      = 40 unless defined($start_with);
    $shuffle_symbols =  1 unless defined($shuffle_symbols);

    $grid_builder ||= get_grid_builder();
    my $next_grid_str = $start_grid_string || &$grid_builder($shuffle_symbols);

    return sub {
      # given a possible solution, reduce the given values in random order until a proper sudoku is found that cannot be further reduced
      # (searching for a rating > 0.65 may take a while)

      # my $old_handler = $SIG{INT};
      # local $SIG{INT} = set_exit_handler(sub {print "BOOO!\n", &$old_handler() if ref($old_handler);});
      #my $solve_tries = 0;

      while (1) {
        print ">>> '$next_grid_str'\n" if $VERBOSE;
        # the initially given grid may have been fleshed out already
        my $grid = [split //, $next_grid_str];
        my @start_positions = map { $grid->[$_] =~ /[1-9]/ ? $_ : () } (0..$#$grid);
        #@start_positions >= 17 or die "Trying to reduce ", scalar(@start_positions), " givens from '$next_grid_str' is pretty much senseless.\n";
        my $to_drop = @start_positions - $start_with;
        $to_drop = 0 if $to_drop < 0;

        my $fields_to_try = $check_reducibility ? [@start_positions] : [shuffle @start_positions];

        # to get going, start from a certain depth
        my $dropped_fields = [];
        ($to_drop && !$check_reducibility) and do {
          drop_values($grid, $to_drop, $fields_to_try, $dropped_fields)
            or die "Couldn't drop $to_drop givens from the grid (@$grid).\n"
        };

        my $to_be_reduced;
        my $solution_count = 0;

        while ($solution_count < 2) {
          unless (drop_values($grid, 1, $fields_to_try, $dropped_fields)) {
            # tried to drop any single field that was left so far (bar 17), all leading to > 1 solutions => not further reducible => start over
            if ($to_be_reduced) {
              $next_grid_str = $start_grid_string || &$grid_builder($shuffle_symbols);
              $check_reducibility = 0;

              # this returns always a multiple of 40 (40 - 320 .. ??) why ???
              #print $solve_tries, " tries to solve were needed.\n";

              return $to_be_reduced;

            } elsif ($check_reducibility && !$to_be_reduced) {
              print "$solution_count: Start grid is minimal (could not be reduced): '$next_grid_str'\n";
              return 0;
            }
            last;
          }

          my $sudoku = solve($grid)
            or last;
          #$solve_tries++;
          $solution_count = $sudoku->{solutionCount};
          print "sc=$solution_count\n" if $VERBOSE;

          if ($solution_count == 1) {
            if ((!$to_be_reduced) || ($to_be_reduced->{uniqueGivens} > $sudoku->{uniqueGivens}) || ($to_be_reduced->{givensCount} >= $sudoku->{givensCount})) {
              # most interesting (reduced) puzzle found in the given start grid so far,
              # still a subject to possible minimization
              $to_be_reduced = $sudoku;
            }
            next;
          }

          unless ($solution_count == 2) {
            warn "The current grid seems unsolvable!\n"; # . Dumper($sudoku);
            return 0;
          }

          # return to the former state (solution count == 1)
          # and try to achieve further reduction by dropping another value instead
          reinsert_last_value($grid, $dropped_fields);
          $solution_count = 1;
        }

        if ($check_reducibility) {
          $check_reducibility = 0;
          print "Reducibility check finished.\n";
          return 0;
        }

        $next_grid_str = $start_grid_string || &$grid_builder($shuffle_symbols);
      }

      return 0
    };
  }
}

sub drop_values {
  my ($grid, $to_drop, $fields_to_try, $dropped) = @_;

  my $dropped_count = 0;
  while ( $dropped_count < $to_drop ) {
    my $field_index = shift @$fields_to_try;
    return $dropped_count unless defined($field_index);
    my $symbol = $grid->[$field_index];
    print "dropped $symbol from $field_index\n" if $VERBOSE;
    die "Unexpected symbol '$symbol' in position $field_index!" if (!$symbol || $symbol eq '.');
    $grid->[$field_index] = '.';
    push @$dropped, [$field_index, $symbol];
    $dropped_count++;
  }

  return $dropped_count;
}

sub reinsert_last_value {
  # only puts the value back into the grid, does not return the index into the queue of drop candidates
  my ($grid, $dropped) = @_;

  my ($field_index, $symbol) = @{pop @$dropped} or die "No more grid positions to restore!";
  $grid->[$field_index] = $symbol;
  print "restored $symbol at $field_index\n" if $VERBOSE;
}

sub set_solver_config {
  # fastest way to find out if a sudoku has 0, 1, or more solutions
  $Games::Sudoku::PatternSolver::VERBOSE = $VERBOSE;
  $Games::Sudoku::PatternSolver::MAX_SOLUTIONS = 2;
  $Games::Sudoku::PatternSolver::LOOSE_MODE = $LOOSE_MODE;
  $Games::Sudoku::PatternSolver::USE_LOGIC = 1;
}

###########################################################

{
  my $patterns_by_field;

  sub get_grid_builder {

    $patterns_by_field ||= (init_patterns())[0];

    shuffle_pattern_arrays($patterns_by_field);

    # creating 81 iterators; each one iterates over a circular list with 5184 vectors in random order, which all have the specified field bit in common
    my %pattern_iterators = ();
    foreach my $field_index (keys %$patterns_by_field) {
      my $list = $patterns_by_field->{$field_index};
      my $index = -1;
      $pattern_iterators{$field_index} = sub {
        $index++;
        $index = 0 if $index > $#$list;
        return $list->[ $index ];
      };
    }

    my $test_vector = Bit::Vector->new(81);

    return sub {
      my $shuffle_symbols = shift() || 0;

      local $SIG{'INT'} = set_exit_handler();

      while (1) {
        my @placed_vectors = ();
        my $coverage_vector = Bit::Vector->new(81);
        my $placed = 0;

        while ($placed < 9) {
          $test_vector->Not($coverage_vector);
          my $any_empty_field = $test_vector->Min();

          my $could_place = 0;
          for (my $i = 0; $i < 5184; $i++) {
            my $pattern_vector = $pattern_iterators{$any_empty_field}();
            $test_vector->And($coverage_vector, $pattern_vector);

            if ($test_vector->is_empty()) {
              $coverage_vector->Or($coverage_vector, $pattern_vector);
              push @placed_vectors, $pattern_vector;
              $placed++;
              $could_place = 1;
              last;
            }
          }
          $could_place or last;
        }

        ($placed == 9) and return join '', prepare_grid(\@placed_vectors, $shuffle_symbols);
      }
    };
  }

  sub prepare_grid {
    # an arrayref with 9 complementing bit vectors
    my ($pattern_stack, $do_shuffle) = @_;

    # having 1-9 assigned to the 1st row makes spotting eventual repetitions more easy
    my @symbols = $do_shuffle ? (shuffle 1..9) : 1..9;

    my @chars = ();
    foreach my $pattern_vector (@$pattern_stack) {
      my $symbol = shift @symbols;
      $chars[$_] = $symbol for $pattern_vector->Index_List_Read();
    }

    return @chars
  }

  sub shuffle_pattern_arrays {
    my ($HashOfArrays) = @_;

    my $t1 = Time::HiRes::time();
    foreach my $key (keys %$HashOfArrays) {
      @{$HashOfArrays->{$key}} = shuffle( @{$HashOfArrays->{$key}} );
    }
    printf("Shuffling patterns took %0.4f secs.\n", Time::HiRes::time() - $t1) if $VERBOSE;
  }
}

sub set_exit_handler {
  my ($sub_to_execute) = @_;

  return $Games::Sudoku::PatternSolver::exitHandler = sub {
    #print "Exit on user request.\n";
    &$sub_to_execute if $sub_to_execute;
    #Time::HiRes::sleep 0.2;
    #CORE::exit(0);
  };
}

1

__END__