diff options
| -rw-r--r-- | challenge-086/abigail/perl/ch-2.pl | 43 |
1 files changed, 28 insertions, 15 deletions
diff --git a/challenge-086/abigail/perl/ch-2.pl b/challenge-086/abigail/perl/ch-2.pl index 2fb2e79a50..4b5c3146f7 100644 --- a/challenge-086/abigail/perl/ch-2.pl +++ b/challenge-086/abigail/perl/ch-2.pl @@ -70,6 +70,14 @@ die "Too many different clues!" if $clue_count > $SIZE; die "Not enough different clues" if $clue_count < $SIZE - 1; # +# Can't have a size which exceeds the number of bits in an integer. +# Typically, bit size will be 32, 64 or 128. +# This isn't much of a restriction, as a typical 32x32 sudoku will take +# a very, very long time to calculate. +# +die "Sudoku is too big\n" if $SIZE > length sprintf "%b", ~0; + +# # We may have to come with a missing clue name. This could be # a number, or a letter. # - If there are numbers, but 1 is missing, use 1. @@ -170,16 +178,17 @@ foreach my $x (@INDICES) { # Not solved. Out of the elements, record the numbers # which cannot be seen from this square. # - my %set = map {$_ => 1} @ELEMENTS; + my $set = (1 << ($clue_count)) - 1; foreach my $can_see (sees ($x, $y)) { - delete $set {$sudoku [$$can_see [0]] [$$can_see [1]]}; + $set &= ~(1 << ($sudoku [$$can_see [0]] [$$can_see [1]] - 1)); } - $$unsolved {$x, $y} = [keys %set]; + $$unsolved {$x, $y} = $set; } } + no warnings 'recursion'; sub solve ($solved, $unsolved) { # @@ -188,16 +197,23 @@ sub solve ($solved, $unsolved) { return $solved unless keys %$unsolved; # - # Find the (a) square which the least possibilities + # Find the (a) square which the least possibilities; this + # means finding the set with the least amount of bits set. # - my ($key) = sort {@{$$unsolved {$a}} <=> @{$$unsolved {$b}} || - $a cmp $b} keys %$unsolved; + my ($key) = map {$$_ [0]} + sort {$$a [1] <=> $$b [1]} + map {[$_, sprintf ("%b", $$unsolved {$_}) =~ y/1/1/]} + keys %$unsolved; my ($x, $y) = split $; => $key; + my $possibilities = $$unsolved {$key}; # - # Try each possibility + # Guess each possibility for this key. # - foreach my $guess (@{$$unsolved {$key}}) { + foreach my $guess (@ELEMENTS) { + my $mask = 1 << ($guess - 1); + next unless $possibilities & $mask; + # # Create new solved and unsolved structures # @@ -207,10 +223,7 @@ sub solve ($solved, $unsolved) { # # Copy unsolved # - my $new_unsolved; - foreach my $key (keys %$unsolved) { - $$new_unsolved {$key} = [@{$$unsolved {$key}}]; - } + my $new_unsolved = {%$unsolved}; # # Delete our guess @@ -223,9 +236,9 @@ sub solve ($solved, $unsolved) { # foreach my $can_see (sees ($x, $y)) { my ($x, $y) = @$can_see; - $$new_unsolved {$x, $y} = [grep {$_ != $guess} - @{$$new_unsolved {$x, $y}}] - if $$new_unsolved {$x, $y}; + if ($$new_unsolved {$x, $y}) { + $$new_unsolved {$x, $y} &= ~ $mask; + } } # |