[SPOILER] Re: Perl 'Easy' Quiz of the Week #2005-03-04 (Sudoku)

On Fri, Mar 04, 2005 at 01:42:29PM +0000, Roger Burton West wrote:

>Sudoku (or Su Doku) is a Japanese puzzle game.

Colin Rafferty was right; this wasn't as easy as I thought it was. The
solver given here breaks down on some cases; it seems that the guessing
module does not rewind correctly.

I define three sorts of "box group" (rows, columns and blocks), each of
which has nine members and must contain one of each number for the
solution to be valid.

>(1) Write a program to check the correctness of a solution.

#! /usr/bin/perl -w

use strict;

my $game;

while (<>) {
  chomp;
  if (/^([-\d]\s*){9}$/) {
    push @{$game},[split ' ',$_];
  }
}

if (scalar @{$game} != 9) {
  die "invalid input\n";
}

my @coords;
foreach my $n (0..8) {
  push @coords,[map {[$_,$n]} (0..8)];
  push @coords,[map {[$n,$_]} (0..8)];
}
for (my $y=0;$y<=6;$y+=3) {
  for (my $x=0;$x<=6;$x+=3) {
    my @l;
    foreach my $r ($y..$y+2) {
      foreach my $c ($x..$x+2) {
        push @l,[$r,$c];
      }
    }
    push @coords,\@l;
  }
}

my $ok=&check($game);

if ($ok) {
  print "good\n";
} else {
  print "bad\n";
}

sub check {
  my ($game)=@_;
  foreach my $cs (@coords) {
    my %opt=map {$_=>1} (1..9);
    foreach my $cset (@{$cs}) {
      my ($r,$c)=@{$cset};
      unless (ref $game->[$r][$c]) {
        if (exists $opt{$game->[$r][$c]}) {
          delete $opt{$game->[$r][$c]};
        } else {
          return 0;
        }
      }
    }
  }
  return 1;
}

>(2) Write a solver. (There are several of these on-line already.)

Boxes can be "fixed" (have a set value) or "unfixed" (have a set of
possible values, stored as a hashref).

There are two logical moves, each of which is applied to each box group
in turn:

(1) Start with an empty list. Add to that list any number in the box
group that is already fixed. Then iterate over the box group again,
removing from the possibilities for un-fixed boxes every number that is
in the list.

(2) For each number 1..9, count the number of times it occurs in
unfixed members of the box group. (If it occurs in a fixed member, bail
out.) If that count is 1, fix that box.

A third logical move would be to track individual numbers, in effect
drawing lines of exclusion as was done in the sample web page I posted:
http://www.puzzle.jp/letsplay/sudokurule-e.html . I have not yet
attempted to implement this move.

If nothing can be done with these moves, a guess is made, and the old
game state is stacked. If a guess leads to an impossible position, the
old game state is destacked and that option is removed.

BUGS: sometimes an impossible position is not detected correctly. This
seems to happen particularly with deep guessing on blank starting
positions (see next program). If you start to get "Use of uninitialized
value in exists" warnings, kill the program and try again.

#! /usr/bin/perl -w

use strict;

use Storable qw(nfreeze thaw);

my $game;
my @guessstack;

while (<>) {
  chomp;
  if (/^([-\d]\s*){9}$/) {
    push @{$game},[split ' ',$_];
  }
}

foreach my $r (0..8) {
  foreach my $c (0..8) {
    if ($game->[$r][$c] eq '-') {
      $game->[$r][$c]={map {$_ => 1} (1..9)};
    }
  }
}

if (scalar @{$game} != 9) {
  die "invalid input\n";
}

my $solved=0;
my $delta=1;

my @coords;
foreach my $n (0..8) {
  push @coords,[map {[$_,$n]} (0..8)];
  push @coords,[map {[$n,$_]} (0..8)];
}
for (my $y=0;$y<=6;$y+=3) {
  for (my $x=0;$x<=6;$x+=3) {
    my @l;
    foreach my $r ($y..$y+2) {
      foreach my $c ($x..$x+2) {
        push @l,[$r,$c];
      }
    }
    push @coords,\@l;
  }
}

while (!$solved && $delta) {
  $delta=0;
  COORDSET:
  foreach my $cs (@coords) {
    my %opt;
    foreach my $cset (@{$cs}) {
      my ($r,$c)=@{$cset};
      unless (ref $game->[$r][$c]) {
        $opt{$game->[$r][$c]}=1;
      }
    }
    foreach my $cset (@{$cs}) {
      my ($r,$c)=@{$cset};
      if (ref $game->[$r][$c]) {
        foreach my $k (keys %opt) {
         if (exists $game->[$r][$c]{$k}) {
            delete $game->[$r][$c]{$k};
            $delta=1;
            last COORDSET;
          }
        }
      }
    }
    NUMBER:
    foreach my $number (1..9) {
      my $slots=0;
      my ($kr,$kc)=(-1,-1);
      foreach my $cset (@{$cs}) {
        my ($r,$c)=@{$cset};
        if (ref $game->[$r][$c]) {
          if (exists $game->[$r][$c]{$number}) {
            $slots++;
            ($kr,$kc)=($r,$c);
            if ($slots>1) {
              next NUMBER;
            }
          }
        } else {
          if ($game->[$r][$c] == $number) {
            next NUMBER;
          }
        }
      }
      if ($slots==1) {
        $game->[$kr][$kc] = $number;
        $delta=1;
        last COORDSET;
      }
    }
  }
  unless ($delta) {
    # run out of logic, try guessing something
    my ($kr,$kc);
    RC:
    foreach my $r (0..8) {
      foreach my $c (0..8) {
        if (ref $game->[$r][$c]) {
          ($kr,$kc)=($r,$c);
          last RC;
        }
      }
    }
    my @n=keys %{$game->[$kr][$kc]};
    my $n=$n[int(rand()*scalar @n)];
    push @guessstack,[thaw(nfreeze($game)),$kr,$kc,$n];
    $game->[$kr][$kc]=$n;
    $delta=1;
  }
  $solved=1;
  foreach my $r (0..8) {
    foreach my $c (0..8) {
      if (ref $game->[$r][$c]) {
        my @k=keys %{$game->[$r][$c]};
        if (scalar @k == 1) {
          $game->[$r][$c]=$k[0];
          $delta=1;
        } elsif (scalar @k ==0) {
          $delta=-1;
          $solved=0;
        } else {
          $solved=0;
        }
      }
    }
  }
  if ((!$solved && !$delta) ||
       !&check($game)) {
    if (@guessstack) {
      ($game,my $r,my $c,my $n)=@{pop @guessstack};
      delete $game->[$r][$c]{$n};
      $delta=1;
    } else {
      die "Dead end, no more guesses.\n";
    }
  }
}

if ($solved) {
  &dump_game($game);
}

sub dump_game {
  my ($game)=@_;
  foreach my $r (0..8) {
    my @r;
    foreach my $c (0..8) {
      my $k=$game->[$r][$c];
      if (ref $k) {
        $k='-';
      }
      push @r,$k;
    }
    print join(' ',@r),"\n";
  }
}

sub check {
  my ($game)=@_;
  foreach my $cs (@coords) {
    my %opt=map {$_=>1} (1..9);
    foreach my $cset (@{$cs}) {
      my ($r,$c)=@{$cset};
      unless (ref $game->[$r][$c]) {
        if (exists $opt{$game->[$r][$c]}) {
          delete $opt{$game->[$r][$c]};
        } else {
          return 0;
        }
      }
    }
  }
  return 1;
}

>(3) Write a random puzzle generator.

Feeding an empty grid to the solver will generate a random puzzle. This
will strip out some of the numbers:

(cat blank | ./solve | ./generate)

BUGS: some of these puzzles have more than one valid solution.

#! /usr/bin/perl -w

use strict;

my $game;

while (<STDIN>) {
  chomp;
  if (/^([\d]\s*){9}$/) {
    push @{$game},[split ' ',$_];
  }
}

if (scalar @{$game} != 9) {
  die "invalid input\n";
}

my $remainder=81-($ARGV[0] || 53);
while ($remainder) {
  my @c;
  if ($remainder % 2) {
    @c=([4,4]);
  } else {
    my $ok=0;
    my ($x,$y);
    while (!$ok) {
      $ok=0;
      ($x,$y)=(int(rand()*9),int(rand()*9));
      if ($x !=4 || $y != 4) {
        if (!ref $game->[$x][$y]) {
          $ok=1;
        }
      }
    }
    @c=([$x,$y],[8-$x,8-$y]);
  }
  foreach my $cp (@c) {
    $remainder--;
    $game->[$cp->[0]][$cp->[1]]={};
  }
}
&dump_game($game);

sub dump_game {
  my ($game)=@_;
  foreach my $r (0..8) {
    my @r;
    foreach my $c (0..8) {
      my $k=$game->[$r][$c];
      if (ref $k) {
        $k='-';
      }
      push @r,$k;
    }
    print join(' ',@r),"\n";
  }
}

Roger