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

On Mon, Mar 07, 2005 at 11:29:32AM +0000, Roger Burton West wrote:

>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: if there exists a set of N boxes within a box
group, each of which can be any one of the same N numbers, then no other
box within that group can be any of those N numbers.

(I.e. if I have two boxes each of which might be 3 or 4, then between
them they must contain both 3 and 4, so I can cross those numbers out
of the other boxes.)

This is substantially slower than the version I posted earlier, but in
the example problems I've been using it has reduced the guess depth by
between zero and two levels. (It would make sense to refactor the
program to run the simple, and therefore faster, tests against the full
coordinate set first.)

--- old.solve	Mon Mar  7 11:20:42 2005
+++ new.solve	Mon Mar  7 19:48:43 2005
@@ -97,6 +97,38 @@
         last COORDSET;
       }
     }
+    foreach my $depth (2..8) {
+      my %j;
+      foreach my $cc (0..8) {
+        my ($r,$c)=@{$cs->[$cc]};
+        if (ref $game->[$r][$c] &&
+            scalar keys %{$game->[$r][$c]} == $depth) {
+          my $k=nfreeze([sort keys %{$game->[$r][$c]}]);
+          push @{$j{$k}},$cc;
+        }
+      }
+      foreach my $k (keys %j) {
+        if (scalar @{$j{$k}} == $depth) {
+          my %ot=map {$_=>1} (0..8);
+          map {delete $ot{$_}} @{$j{$k}};
+          my @dl=@{thaw($k)};
+          foreach my $cn (keys %ot) {
+            my ($r,$c)=@{$cs->[$cn]};
+            if (ref $game->[$r][$c]) {
+              foreach (@dl) {
+                if (exists $game->[$r][$c]{$_}) {
+                  delete $game->[$r][$c]{$_};
+                  $delta=1;
+                }
+              }
+            }
+          }
+        }
+      }
+      if ($delta) {
+        last COORDSET;
+      }
+    }
   }
   unless ($delta) {
     # run out of logic, try guessing something