Perl Weekly Challenge 86, Part 2

This challenge is stated as:

You are given Sudoku puzzle (9×9).

Write a script to complete the puzzle and must respect the following rules:

  1. Each row must have the numbers 1-9 occuring just once.
  2. Each column must have the numbers 1-9 occuring just once.
  3. The numbers 1-9 must occur just once in each of the 9 sub-boxes (3×3) of the grid.

We can of course make use of a CPAN module which solves Sudokus, but if we would do that, we might as well not participate.

Instead, we’ll up the ante! Our solution will solve any N x N sized Sudoku, even if N isn’t a square. And we will be able to solve a so called X-Sudoku (also called Sudoku X), which are Sudokus with the additional constraint that the numbers on the main and anti-diagonals are different. If N is not equal to 9, we of course have more or less numbers (or other symbols) to fill in.

But what about the boxes? Clearly, if N is a square, say N = m², the box size will be m x m. Otherwise, we’re using boxes which are as square as possible, that is, for all pairs (p ﹥ q), where N = p * q, we pick the pair which minimizes p - q. We then stack the boxes in a brick like pattern, so we have q x p boxes, each of size p x q.

Here is an example of a 6 x 6 sudoku with 3 x 2 boxes:

6 x 6 Sudoku from https://sudoku.cool
Courtesy https://sudoku.cool

Some terminology

  • Cell: one of the entries in the Sudoku.
  • Value: symbol (typically a number or letter) which appears in a cell.
  • Clue: a given in the puzzle.
  • Element: a symbol (usually a number and/or letter) in the Sudoku. The set of different clues is either the same as the set of different elements, or it is one less.
  • House: A set of cells whose values are all different. In a traditional Sudoku, the houses are the rows, columns and boxes. In an X Sudoku, the diagonals are houses as well.

Program overview

We will solve the Sudoku using a recursive algorithm. For that, we split the the Sudoku into two sets: a set with solved cells, and a set with unsolved cells. Cells are indexed by their coordinates, starting with (0, 0) in the top left corner. A cell with coordinates (x, y) is on the xth row from the top, and in the yth column from the left. So, in the image above, the 2 is in cell with coordinates (2, 1), and the 4s are in the cells with coordinates (3, 3) and (4, 5).

The set of solved cells just maps the coordinates to the value in the cell. The set of unsolved cells maps the coordinates to a set of values which are still possible. That is, starting with a set of all possibilities, we remove any values which are on the same row, same column, or in the same box.

For instance, in the image above, the cell with coordinates (0, 1) (the second cell on the top row) is unsolved, and its set of possibilities is {4, 5}. 1 and 2 are excluded because they appear in the same column, 3 is excluded because it is in the same box, and 6 is excluded because it’s in the same row.

Given a set of solved cells, and a set of unsolved cells, we solve the Sudoku recursively:

  • If there are no unsolved cells, we’re done, and the set of solved cells is the solution.
  • If there is an unsolved cell, which has no possibility left, there is no solution.
  • While there are naked single cells (that is, cells which have only one possibility left), resolve those cells, cascading the effects to any unsolved cells in the same row, column and box.
  • Pick an unsolved cell. For each of the possibilities p:
    • We remove the cell from the set of unsolved cells.
    • We add the cell to the set of solved cells, with p as value.
    • For each of the other unsolved cells which are in the same house, we delete p from their set of possibilities.
  • And we then recurse.

But we need to do some work before we get there.

Parsing options

We need an option to signal we’re solving an X Sudoku, so that is the first thing we do. Luckily, Perl makes parsing command line options easy, we will use the module Getopt::Long. So we start out program with:

#!/opt/perl/bin/perl

use 5.032;
  
use strict;
use warnings;
no  warnings 'syntax';
  
use experimental 'signatures';
use experimental 'lexical_subs';

use Getopt::Long;
GetOptions "X"   =>  \my $has_x_constraint;

This means, our program can use the option --X to solve an X Sudoku.

Reading in the Sudoku

Next step is reading in the Sudoku, and that is where it gets tricky. If we are limiting ourselves to 9 x 9 Sudokus, the clues would just be single digit numbers. But when Sudokus get larger, different clues are used. Sometimes, all clues are numeric, using 10, 11, etc as clues. Sometimes (capital) letters are used instead of 10, 11, etc, and sometimes only letters are used.

But internally, we only want numeric values as possibilities. Our solution is that we allow either numbers or (single) capital letters as clues, and map clues to consecutive numbers, starting from 1. Before printing a solution, we map the internal numbers back to the original clues.

Any cell which is not a clue is marked with an underscore (or rather, a sequence of underscores).

Furthermore, we skip any character which isn’t an underscore, digit or capital letter, and we skip any lines which don’t contain any underscores, digits or capital letters. This makes that the input may contain blank lines, dashes and/or vertical bars to indicate boxes.

Here we read in the Sudoku, and set some needed variables:

my $clue_count = 0;
my %clues;     # Maps clues from the puzzle to internal values
my @sudoku;
while (<>) {
    next unless /[_1-9A-Z]/;  # Ignore lines without clues.
    my @row;
    foreach my $clue (/\b(?:_+|[1-9][0-9]*|[A-Z])\b/g) {
        my $value;
        if ($clue =~ /_/) {
            $value = 0;
        }
        else {
            #
            # Map the clue to a number.
            #
            $value = $clues {$clue} ||= ++ $clue_count;
        }
        push @row => $value;
    }
    push @sudoku => \@row;
} 

my $SIZE     = @sudoku;
my @INDICES  = (0 .. $SIZE - 1);
my @ELEMENTS = (1 .. $SIZE);

# 
# Calculate the box size. For regular shaped sudokus, this
# is sqrt ($SIZE) x sqrt ($SIZE). For other sized shaped sudokus,
# we find the the nearest values; the boxes will then be wider than
# they are high.
#      
my ($box_x, $box_y) = do {
    my $s = int sqrt $SIZE;
    $s -- while $SIZE % $s;
   ($s, $SIZE / $s);
};

We now have @sudoku containing the puzzle, where cells without a clue are 0, and cells with clues have a number; different clues have different numbers. We also calculate the size of the boxes — they’ll be square if one dimensional size ($SIZE) of the Sudoku is a square. Now, if $SIZE is huge prime, calculating $box_x and $boy_y will be slow, but it will pale in comparison with solving the puzzle.

Sanity checks

Before we proceed, we want to check whether the input is good. That is, each row in the Sudoku should have as many cells as the Sudoku has rows. We cannot have more different clues than we have rows; that is, an N x N sized Sudoku should not have more than N different clues. And we cannot have too few different clues, we must have at least N - 1 different clues, else there cannot be a unique solution.

We also put a restriction on the size of the Sudoku; since we will using integer bit fields in the set of unsolved cells, we cannot have a size which exceeds the number of bits in an integer. For most platforms and builds, that means the limit is a 32 x 32, 64 x 64 or a 128 x 128 Sudoku.

die "All rows should be the same length as the columns"
                                 if grep {@$_ != $SIZE} @sudoku;
die "Too many different clues!"  if $clue_count > $SIZE;
die "Not enough different clues" if $clue_count < $SIZE - 1;
die "Sudoku is too big\n"        if $SIZE > length sprintf "%b", ~0;

Note the use of sprintf "%b", ~0 in the last line. ~0 flips all the bits of the number 0, resulting in an integer whose binary representation gives the maximum number of 1s. sprintf "%b" gives that binary representation as a string.

Filling in a missing clue

N x N Sudokus could have only N - 1 different clues in the puzzle. If this is the case, we need to find out what the missing clue is, so we can properly print the solution. Remember we’re accepting Sudokus using numbers as clue, using letters, or having both letters.

If we are missing clue, we use the following to determine the missing clue:

  • If the Sudoku uses numbers as clues (and possibly letters as well):
    • If 1 isn’t used, we use 1 as the missing clue.
    • Else, if there is a "hole" in the ordered sequence of numbers, use the hole as the missing clue. For instance, if the puzzle uses {1, 2, 4, 5, 6} as clues, we use 3 as the missing clue.
    • Else, if no letters are used, and the numbers range from 1 to $SIZE - 1, the missing clue is $SIZE.
  • Else, if letters are used as clues:
    • If A is not used, use A as the missing clue.
    • Else, if there is a "hole" in the ordered sequence of letters, use the hole as the missing clue.
    • Else, if Z is a clue, use * as the missing clue.
    • Otherwise, use the letter following the last clued letter.
  • If none of the cases above matched, use one more than the highest numbered clue.
if ($clue_count < $SIZE) {
    my $clue;
    my @numbers = sort {$a <=> $b} grep {/[0-9]/} keys %clues;
    my @letters = sort {$a cmp $b} grep {/[A-Z]/} keys %clues;

    if (@numbers) {
        if ($numbers [0] != 1) {
            $clue = 1;
        }
        else {
            for (my $i = 0; $i < @numbers - 2; $i ++) {
                if ($numbers [$i] + 1 != $numbers [$i + 1]) {
                    $clue = $numbers [$i] + 1;
                    last;
                }  
            }
            if (!$clue && @numbers == $SIZE - 1 &&
                          $numbers [-1] == $SIZE - 1) {
                $clue = $SIZE;
            }
        }
    }
    if (!$clue && @letters) {
        if ($letters [0] ne 'A') {
            $clue = 'A';
        }
        else {
            for (my $i = 0; $i < @letters - 2; $i ++) {
                if (ord ($letters [$i]) + 1 != ord ($letters [$i + 1])) {
                    $clue = chr (ord ($letters [$i]) + 1);
                    last;
                }
            }
            if (!$clue) {
                $clue = $letters [-1] eq 'Z' ? "*"
                      : chr (ord ($letters [-1]) + 1);
            }
        }
    }
    $clue //= $numbers [-1] + 1;

    $clues {$clue} = ++ $clue_count;
}

What can we see?

Given a cell, we often need to find out which other cells this cell can "see"; that is, what are the cells whose value must be different from the given cell. In other words, all the cells which are on the same row as the given cell, which are in the same column as the given cell, or which are in the same box as the given cell. And for X Sudokus, if the given cell is on a diagonal (main or anti), the cells which are on the same diagonal.

So we create a subroutine sees, which, given the x and y coordinates of a cell, returns a list of x and y coordinates of cells it can see. And we’re memoizing the results, so for each cell, we do the computation not more than once.

sub sees ($x, $y) {
    state $cache;
    $$cache {$x, $y} //= do {
        my $out;
        foreach my $i (@INDICES) {
            foreach my $j (@INDICES) {
                next if $i == $x && $j == $y;
                push @$out => [$i, $j] if
                      $i == $x ||                                # Same row
                      $j == $y ||                                # Same col
                      int ($i / $box_x) == int ($x / $box_x) &&  # Same box
                      int ($j / $box_y) == int ($y / $box_y) ||
                      $has_x_constraint &&         # Same diagonal?
                         (($i == $j && $x == $y) ||      # Main diagonal
                          ($i + $j == $SIZE - 1 &&       # Anti diagonal
                           $x + $y == $SIZE - 1));
            } 
        }
        $out;
    };
    @{$$cache {$x, $y}}; 
}

For a given cell ($x, $y) we iterate over all the other cells ($i, $j) in the Sudoku, and check whether we can see this cell. Cells are in the same row if they share the first coordinate ($i == $x). Cells are in the same column if they share the second coordinate ($j == $y). To check cells are in the same box, we need to divide the coordinates by the width and height of the box, and round down the result. If they are the same, the cells are in the same box:

int ($i / $box_x) == int ($x / $box_x) &&
int ($j / $box_y) == int ($y / $box_y)

If we are solving an X Sudoku, we need to check whether both cells are on the main diagonal, or both cells are on the anti diagonal. A cell is on the main diagonal if both coordinates are the same. And a cell is on the anti diagonal if the sum of its coordinates sum to $SIZE - 1. Which gives us the final clause:

$has_x_constraint &&      # X Sudoku
    (($i == $j && $x == $y) ||   # Both cells on main diagonal
     ($i + $j == $SIZE - 1 &&    # Both cells on anti diagonal
      $x + $y == $SIZE - 1))

Create solved and unsolved sets

Creating the initial solved and unsolved sets is pretty straight forward:

my $solved;
my $unsolved;
foreach my $x (@INDICES) {
    foreach my $y (@INDICES) {
        if ($sudoku [$x] [$y]) {  # Clue, hence solved
            $$solved {$x, $y} = $sudoku [$x] [$y];
            next;
        }
        #
        # Not solved. Calculate what possibities this cell can have.
        # That is, anything which isn't somewhere in the same row,
        # column, or box.
        #
        my $set = (1 << $clue_count) - 1;  # All 1's.
        foreach my $can_see (sees ($x, $y)) {
            my ($see_x, $see_y) = @$can_see;
            $set &= ~(1 << ($sudoku [$see_x] [$see_y] - 1));
        }

        $$unsolved {$x, $y} = $set;
    }
}

We are using multi dimensional hashes for the solved and unsolved sets. If a hash has multiple keys, Perl will concatenate the keys, using $; as the separator.

For the unsolved cells, the values are bit fields. Each bit in the field represents an element; if the bit is 1 the corresponding element is still a possibility for the cell, if it 0, the corresponding element has been ruled out (because another cell on the same row, column or box uses that). The i-th least significant bit corresponds to element i + 1 (since our internal values start counting from 1).

Two handy helper functions

my sub nr_of_elements ($bitfield) {
    sprintf ("%b", $bitfield) =~ y/1/1/;
}
 
my sub elements ($bitfield) {
    grep {$bitfield & (1 << ($_ - 1))} @ELEMENTS;
}

These two helper functions both take a bitfield, and either return the number of possible elements it represents, or the list of elements themselves. Note that we can find the number "on" bits in a bitfield by looking at the binary representation (which sprintf "%b" gives use), and then counting the number of 1s, which we can do with the y/// operator.

Recursive solve

Below is the recursive subroutine which solves the Sudoku. It gets two arguments, a set of solved cells ($solved), and a set of unsolved cells ($unsolved).

  • If $unsolved is empty, the Sudoku is solved, and $solved is returned.
  • Else, $unsolved contains a cell with no possibilities left, the Sudoku is unsolvable, and we just return.
  • Else, if there are any unsolved cells which have exactly one possibility left, we resolve them. We create a todo list, consisting all all unsolved cells having exactly one possibility left. Then for each cell C in the todo list:
    • Let p be the remaining possibility for C
    • For each unsolved cell C' which shares a house with C, remove p from the list of possibilities of C'.
      • If afterwards, C' does not have any possibilities left, there is no solution, and we return.
      • If afterwards, C' has exactly one possibility left, add C' to the todo list.
    • Add C to $solved with value p.
    • Remove C from $unsolved and the todo list.
    • Recurse when the todo list is empty.
  • Otherwise, pick an unsolved cell C with the least number of possibilities (this has to be at least two possibilities).
    • For each possibility p of C:
      • For each unsolved cell C' which shares a house with C, remove p from the possibilities of C'.
      • Remove C from $unsolved.
      • Add C to $solved, with value p.
      • Recurse:
        • If the recursion returns a solution, we return the solution.
        • If the recursion does not find a solution, try the next possibility.
    • If none of the possibilities lead to a solution, no solution can be found, and we return.

Note that for large Sudokus, we can reach the recursion limit, hence we disable the recursion warning.

no warnings 'recursion';
sub solve ($solved, $unsolved) {
    #
    # If there are no unsolved squares, we return $solved.
    #
    return $solved unless keys %$unsolved;

    #
    # Bucketize the set of unsolved cells, by the number
    # of possibilities left.
    #
    my @buckets;
    while (my ($key, $value) = each %$unsolved) {
        push @{$buckets [nr_of_elements $value]} => $key;
    }

    #
    # No solution possible.
    #
    return if $buckets [0];

    if (@{$buckets [1] || []}) {
        #
        # We have unsolved cells with just one possibility left.
        #
        my %todo = map {$_ => 1} @{$buckets [1]};  

        #
        # Make copies of the solved and unsolved structures.
        #
        my $new_solved   = {%$solved};
        my $new_unsolved = {%$unsolved};

        while (keys %todo) {
            my ($cell) = sort keys %todo;
            my $mask = $$new_unsolved {$cell};
            my ($x, $y) = split $; => $cell;

            #
            # For all unsolved cells which can be seen by this cell
            # eliminate the value of this cell from its possibilities.
            # If no possibilities are left, return undef. If one
            # possibilities is left, push onto @todo.
            #
            # In any case, move this cell from the set of unsolved cells
            # to the set of solved cells.
            #
            foreach my $can_see (sees ($x, $y)) {
                my ($x1, $y1) = @$can_see;
                if ($$new_unsolved {$x1, $y1} &&
                    $$new_unsolved {$x1, $y1} & $mask) {
                    $$new_unsolved {$x1, $y1} &= ~ $mask;
                    my $nr_of_elements =
                        nr_of_elements $$new_unsolved {$x1, $y1};
                    return               if $nr_of_elements == 0;
                    $todo {$x1, $y1} = 1 if $nr_of_elements == 1;
                }
            }
     
            #
            # Move cell to solved structure, and remove it from %todo.
            #
            $$new_solved {$cell} = (elements $mask) [0];
            delete $$new_unsolved {$cell};
            delete $todo {$cell};
        }
         
        # 
        # Recurse with the new sets
        #
        return solve ($new_solved, $new_unsolved);
    }
        
    #
    # Now, find a cell with the least number of possibilities left.
    # That will be a cell in the first non-empty bucket.
    #
    my ($bucket) = grep {$_} @buckets;
    my  $cell    = $$bucket [0];
    my ($x, $y)  = split $; => $cell;
            
    #
    # Guess each possibility for this cell.
    #
    foreach my $guess (elements $$unsolved {$cell}) {
        my $mask = 1 << ($guess - 1);
            
        #
        # Create new solved unsolved structures, 
        # as copies from the given ones.
        #
        my $new_solved   = {%$solved};
        my $new_unsolved = {%$unsolved};
                
        #
        # Set the guess as solved.
        #
        $$new_solved {$x, $y} = $guess; 
                        
        #
        # Remove the guess from the set of unsolved cells.
        #
        delete $$new_unsolved {$cell};
     
        #
        # Delete our guess as possibility for each cell
        # which can be seen.
        #
        foreach my $can_see (sees ($x, $y)) {
            my ($x1, $y1) = @$can_see;
            if ($$new_unsolved {$x1, $y1}) {
                $$new_unsolved {$x1, $y1} &= ~ $mask;
            }
        }
         
        #
        # Recurse. Return on success.
        #
        if (my $solution = solve ($new_solved, $new_unsolved)) {
            return $solution;
        }
    }
    
    #
    # No guess worked. Return false. 
    #       
    return;
}

Print the solution

Now all what needs to be done is to print the solution. For that, we need to map the internal values back to the original clues.

if (my $r = solve ($solved, $unsolved)) {
    use List::Util qw [max];
    my $w = max map {length} values %clues;  # To line up things
    my %value2clue = reverse %clues;
    foreach my $x (@INDICES) {  
        foreach my $y (keys @INDICES) {
            print " " if $y;
            printf "%${w}s" => $value2clue {$$r {$x, $y}};
        }   
        print "\n";
    }
}
else {
    say "No solution found\n";
}

The complete program can be found on GitHub.

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out /  Change )

Google photo

You are commenting using your Google account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s