Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl: the Markov chain saw
 
PerlMonks  

Re^3: decomposing binary matrices

by johngg (Canon)
on Feb 16, 2007 at 23:43 UTC ( #600550=note: print w/replies, xml ) Need Help??


in reply to Re^2: decomposing binary matrices
in thread decomposing binary matrices

From Limbic~Region's reply, it looks like you might have lost your bet. I too have a brute force solver that I wrote a couple of years ago. It would be interesting to compare our approaches so I'll dig my version out and post it as well. I actually wrote it before I had got into solving the puzzles by hand so I ought to have a go at refining it now that I have more strategies to hand.

Cheers,

JohnGG

Update: Here is my brute-force Sudoku solver. Although it has to resort to backtracking if it makes a wrong guess it is fairly efficient because it sorts the empty squares by the number of possible numbers for each square before making a guess. Thus, for a lot of the time, it will make the right choice and it also updates everything and re-sorts after each choice. It will also detect an unsolveable puzzle very quickly as there will be a square with no possible number.

It uses Term::ANSIColor to prettify the output but I'm not sure if that works in Windows terminals. Here's the code

#!/usr/local/bin/perl -w # # Copyright (c) 2005, John Gillman # All rights reserved # # This program is free software. It may be used, re-distributed # and/or modified under the same terms as Perl 5.8.0 (or later), # (see http://www.perl.com/perl/misc/Artistic.html). # # Force pre-declaration, import Term::ANSIColor to allow bold text # so as to make printed representations of the puzzle grid more # readable. # use strict; use Term::ANSIColor qw(:constants); # Check that we have a single argument which is the name of the # file containing the puzzle data, i.e which cells have numbers # and which don't. (And what the numbers are, obviously.) # die "usage: sudoku filename\a\n" unless scalar @ARGV == 1; die "sudoko: $ARGV[0] does not exist\a\n" unless -e $ARGV[0]; # Set up formatting components using the Term::ANSIColor constants # to embolden certain parts so as to replicate the puzzle grid as # it appears in the newspaper. # our $leftEdge = " " . BOLD . "|" . RESET; our $boldLight = BOLD . "~~~~~" . RESET . "|"; our $boldBold = BOLD . "~~~~~|" . RESET ; our $lightBold = "-----" . BOLD . "|" . RESET; our $lightLight = "-----|"; our $spaceBold = " " . BOLD . "|" . RESET; our $spaceLight = " |"; # Use the components to construct row and column separator lines. # our $boldRowSep = $leftEdge . ($boldLight x 2 . $boldBold) x 3 . "\n"; our $lightRowSep = $leftEdge . ($lightLight x 2 . $lightBold) x 3 . "\ +n"; our $colSep = $leftEdge . ($spaceLight x 2 . $spaceBold) x 3 . "\n"; # Initialise puzzle grid to 9 rows and 9 columns of spaces and # initialise count of solutions found. Puzzle grid is a list of # lists, columns within rows. # our $rlGrid = []; { my @row = (); push @row, ' ' for 0 .. 8; @{$rlGrid->[$_]} = @row for 0 .. 8; } our $solnCt = 0; # Set up a hash table with, initially, an entry for each cell, the # key being "row:column". When a cell is filled, it's corresponding # entry in the hash is deleted. # our $rhEmpties = {}; foreach my $row (0 .. 8) { foreach my $col (0 .. 8) { $rhEmpties->{"$row,$col"} = []; } } # Open the input file for reading. # our $inputFile = shift; open IN, "<$inputFile" or die "open: $inputFile: $!\n"; # Declare another grid to hold locations in the grid where numbers # were placed at the start, declare an anonymous hash that will hold # locations of empty cells and declare an anonymous hash that will # hold a list of keys of empty cells in each group of nine. Read # data lines at the end of the script one at a time. There should # be nine lines, one for each row, and each line should contain nine # characters, one for each column with the digits 1 through 9 and # dots representing blank cells. # our $rlInitialNos = []; our $rhEmptyCells = {}; our $rhAffected = {}; while(<IN>) { # Validate input; are there more than nine lines? Drop newline # and check we have exactly nine valid characters. # die "Only nine data lines required for puzzle grid\n" if $. > 9; chomp; die "Line $.: data -->$_<-- invalid\n" unless /^[1-9.]{9}$/; # Set row number from input data line number, split line into # individual characters then iterate over the characters. # my $row = $. - 1; my @chars = split //; foreach my $col (0 .. 8) { # If character is a dot, create an empty list in the hash # of empty cells. Otherwise, put the number found into the # correct cell of the puzzle grid and set same cell in the # grid of numbers set at initialisation. # if($chars[$col] eq '.') { my $rlGroupKeys = getKeys($row, $col); my $cellKey = "r${row}c${col}"; $rhEmptyCells->{$cellKey} = []; push @{$rhAffected->{$_}}, $cellKey for @$rlGroupKeys } else { $rlGrid->[$row]->[$col] = $chars[$col]; $rlInitialNos->[$row]->[$col] ++; } } } # Close input file. Validate puzzle grid and abort if it is a duffer. # close IN or die "close: $inputFile: $!\n"; if(my $gridError = validateGrid($rlGrid)) { print "\nERROR: $gridError\n\n"; printGrid($rlGrid); die "ABORTING\n"; } # Show puzzle grid as initialised. # print "\nPuzzle grid to solve\n"; printGrid($rlGrid); # Set up an anonymous hash to contain entries keyed by row, column # or block identifier (r0 thru r8, c0 thru c8 and b00 thru b66, the # two block digits signifying the row and column of the top-left cell # of a 3x3 block). The value for each group of nine is an anonymous # list of numbers that could occupy any empty cell in the group. # Do rows and columns first, calling groupPossibles() for each. # our $rhGroupsOf9 = {}; foreach my $rowOrCol (0 .. 8) { my $rowKey = "r$rowOrCol"; my $colKey = "c$rowOrCol"; $rhGroupsOf9->{$rowKey} = groupPossibles($rlGrid, $rowKey); $rhGroupsOf9->{$colKey} = groupPossibles($rlGrid, $colKey); } # Now do the 3x3 blocks. # foreach my $blockRow (0, 3, 6) { foreach my $blockCol (0, 3, 6) { my $blockKey = "b$blockRow$blockCol"; $rhGroupsOf9->{$blockKey} = groupPossibles($rlGrid, $blockKey) +; } } # Now that we know which numbers are possibilities for each group of # nine we can now populate the lists of possible numbers for each empt +y # cell. # foreach my $cell (keys %$rhEmptyCells) { my $row = substr $cell, 1, 1; my $col = substr $cell, 3, 1; my $rlGroupKeys = getKeys($row, $col); my %count = (); foreach my $group (@$rlGroupKeys) { $count{$_} ++ for @{$rhGroupsOf9->{$group}}; } foreach my $digit (keys %count) { delete $count{$digit} unless $count{$digit} == 3; } push @{$rhEmptyCells->{$cell}}, keys %count; } # Invoke the findSolutions() subroutine, passing it the puzzle # grid, the groups of nine, empty cells and cells affected hashes # and the key of the next cell to fill from the empty cells hash. # The nextCellKey() routine chooses the cell with the fewest possible # digits. Any solution found will be printed by the findSolutions() # routine. # findSolutions($rlGrid, $rhGroupsOf9, $rhEmptyCells, $rhAffected, nextCellKey($rhEmptyCells)); # Print message if no solution was found. Exit program. # print "\nNo solution found\n\n" unless $solnCt; exit; # # -:-:-:- End of main() -:-:-:- # # ------------- sub findSolutions # ------------- # Subroutine to populate the grid, a cell at a time, trying # a possible number then moving on to the next cell by calling # itself recursively until either a complete solution is # arrived at or there are no possible values for the cell # being examined, at which point the routine returns back to # a previous cell that has other possible numbers to examine. # If a complete solution is found, i.e. a call to nextCell() # returns undef because all empty cells have been filled, print # out the solution grid then return to look for more possible # solutions. # { # Get the puzzle grid, the hash of possible numbers for each # row, column or block, the hash of empty cells, the hash of # cells affected by group and the key of the current empty cell # that we are about to fill in. If the current cell key is undef # then there were no empty cells left when findSolutions() was # called this time so we have a solution. Print it then validate # it, die if bad, otherwise return. # my($rlGrid, $rhGroupsOf9, $rhEmptyCells, $rhAffected, $currentCellKey) = @_; unless($currentCellKey) { print "Solution no. ", ++ $solnCt, "\n"; printGrid($rlGrid); if(my $gridError = validateGrid($rlGrid)) { print "\nERROR: $gridError\n\n"; die "ABORTING\n"; } return; } # Extract row and column from key. Get keys of the groups of nine # affected by the current cell. # my $row = substr $currentCellKey, 1, 1; my $col = substr $currentCellKey, 3, 1; my $rlGroupKeys = getKeys($row, $col); # Iterate over the possible values for the current cell as held in # the $rhEmptyCells hash. # foreach my $try (@{$rhEmptyCells->{$currentCellKey}}) { # Construct a regular expression used to remove the number # from lists. # my $rxEliminate = qr{[^$try]}; # Replicate $rlGrid, $rhGroupsOf9, $rhEmptyCells and $rhAffect +ed # ready to fill in the current cell with it's possible values # and update the data structures. # my $rlNewGrid = replicateGrid($rlGrid); my $rhNewGroupsOf9 = replicateHoL($rhGroupsOf9); my $rhNewEmptyCells = replicateHoL($rhEmptyCells); my $rhNewAffected = replicateHoL($rhAffected); # Place the number we are trying this time in the replica puzz +le # grid. Remove the current cell from the replica empty cells # hash. # $rlNewGrid->[$row]->[$col] = $try; delete $rhNewEmptyCells->{$currentCellKey}; # Iterate over the groups of nine that are affected by the cur +rent # cell, modifying the replica anonymous hashes with the number +. # foreach my $group (@$rlGroupKeys) { # Update this group to remove the number from it's list of # possible numbers. # @{$rhNewGroupsOf9->{$group}} = grep /$rxEliminate/, @{$rhNewGroupsOf9->{$group}}; # Delete the current cell key from the list of affected ce +lls # for this group of nine. # @{$rhNewAffected->{$group}} = grep {$_ !~ /$currentCellKey/} @{$rhNewAffected->{$grou +p}}; # Now update the possible numbers for each remaining empty + cell # in this group of nine. # foreach my $cellKey (@{$rhNewAffected->{$group}}) { @{$rhNewEmptyCells->{$cellKey}} = grep /$rxEliminate/, @{$rhNewEmptyCells->{$cellKey} +}; } } # Now call findSolutions() recursively with the modified data # structures and the next cell to examine. # findSolutions($rlNewGrid, $rhNewGroupsOf9, $rhNewEmptyCells, $rhNewAffected, nextCellKey($rhNewEmptyCells)); } # Return now that we have tried all possibilities. # return; } # # -:-:-:- End of findSolutions() -:-:-:- # # ------- sub getKeys # ------- # Subroutine to generate the keys into the $rhGroupsOf9 anonymous # hash for a given cell row and column and return a list reference. # { my($row, $col) = @_; my $rowKey = "r$row"; my $colKey = "c$col"; my $blockKey = "b" . int($row / 3) * 3 . int($col / 3) * 3; return [$rowKey, $colKey, $blockKey]; } # # -:-:-:- End of getKeys() -:-:-:- # # -------------- sub groupPossibles # -------------- # Subroutine to return a reference to a list of possible numbers for # any empty cells in a given row, column or 3x3 block # { # Get puzzle grid and group of 9 key. Initialise a list of numbers # found for this group. Test whether we are dealing with a row, # column or block. # my($rlGrid, $key) = @_; my @found = (); if($key =~ /r(\d)/) { # It's a row, move along the row pushing any numbers found # onto the list. # my $row = $1; foreach my $col (0 .. 8) { next if $rlGrid->[$row]->[$col] eq ' '; push @found, $rlGrid->[$row]->[$col]; } } elsif($key =~ /c(\d)/) { # It's a column so move down this time. # my $col = $1; foreach my $row (0 .. 8) { next if $rlGrid->[$row]->[$col] eq ' '; push @found, $rlGrid->[$row]->[$col]; } } elsif($key =~ /b(\d)(\d)/) { # This one's a 3x3 block. Traverse block by columns within # rows # my $row = $1; my $col = $2; for ( my $blockRow = $row; $blockRow < $row + 3; $blockRow ++) { for ( my $blockCol = $col; $blockCol < $col + 3; $blockCol ++) { next if $rlGrid->[$blockRow]->[$blockCol] eq ' '; push @found, $rlGrid->[$blockRow]->[$blockCol]; } } } else { # If we get here then the row/column/block argument is duff. # die "groupPossibles(): key not recognised: $key\n"; } # Set up a hash with all digits from 1 to 9 as keys. Then delete # a hash slice of those numbers already found. The remaining keys # are the possible numbers so return them as a list reference. # my %possibles = (); $possibles{$_} ++ for (1 .. 9); delete @possibles{@found}; return [keys %possibles]; } # # -:-:-:- End of groupPossibles() -:-:-:- # # ----------- sub nextCellKey # ----------- # Subroutine to return the key into the empty cells hash of the next # cell to be examined, or undef if there are no empty cells left. Each # cell is examined to see how many numbers there are possible for it # and the results are sorted so that those with the fewest are chosen # next. # { # Get anonymous hash of empty cells, return undef if there are # no empty cells left, # my $rhEmptyCells = shift; return undef unless my @keys = keys %$rhEmptyCells; # Sort the empty cell into ascending count of possible numbers so # that cells with fewest possibilities are first, returning the # first element of the sorted list of keys. # return ( map {$_->[0]} sort {$a->[1] <=> $b->[1]} map {[$_, scalar @{$rhEmptyCells->{$_}}]} @keys )[0]; } # # -:-:-:- End of nextCell() -:-:-:- # # --------- sub printGrid # --------- # Subroutine to print the supplied grid to STDOUT with formatting to # improve readability. # { # Get grid to print. # my $rlGrid = shift; # Print top two lines of the grid that form just the top border an +d # the first of the column separators. Initialise row count. # print "\n", $boldRowSep, $colSep; my $rowNo = 0; # Iterate over the rows in the puzzle grid calling the printRow # routine to output the line with numbers in. # foreach my $rlRow (@$rlGrid) { printRow($rlRow, $rowNo); # Increment row number. Print a column separator then a light # or bold row separator depending whether we have just done a # block of three rows. Print another column separator ready # the next row of data unless we are at the end of the grid. # $rowNo ++; print $colSep, $rowNo % 3 ? $lightRowSep : $boldRowSep; print $colSep unless $rowNo == 9; } # Print a newline after the grid then return. # print "\n"; return; } # # -:-:-:- End of printGrid() -:-:-:- # # -------- sub printRow # -------- # Subroutine to print the grid rows that contain the actual numbers of # the puzzle. If the number to be printed in a particular cell is one # that was set at the beginning, it is printed in bold to stand out. # { # Get a reference to the row to be printed and it's number so that # the $rlInitialNos list of lists can be queried. Print the left # edge of the grid. Initialise column number. # my($rlRow, $rowNo) = @_; print " " . BOLD . "|" . RESET; my $colNo = 0; # Iterate along the row printing each number, bold or otherwise, i +n # the correct column with the relevant separator between. # foreach my $col (@$rlRow) { print " "; print $rlInitialNos->[$rowNo]->[$colNo] ? BOLD . $col . RESET : $col; $colNo ++; print $colNo % 3 ? " |" : " " . BOLD . "|" . RESET; } # Print newline to end the row and return. # print "\n"; return; } # # -:-:-:- End of printRow() -:-:-:- # # ------------ sub replicateHoL # ------------ # Subroutine to replicate a hash of lists structure as found in the # $rhGroupsOf9 and $rhEmptyCells anonymous hashes and return a referen +ce # to a new hash of lists containing the same data. # { # Get original grid, initialise the copy. # my $rhOriginal = shift; my $rhReplica = {}; # Iterate over the keys of the original, setting the values of # the replica to anonymous lists containing the de-referenced # contents of the original's lists. # foreach my $key (keys %$rhOriginal) { $rhReplica->{$key} = [@{$rhOriginal->{$key}}]; } # Return the replica hash of lists. # return $rhReplica; } # # -:-:-:- End of replicateHoL() -:-:-:- # # ------------- sub replicateGrid # ------------- # Subroutine to replicate the supplied grid and return a reference to +a # new list of lists containing the same data. # { # Get original grid, initialise the copy. # my $rlOriginal = shift; my $rlReplica = []; # Iterate over the rows in the original pushing a reference to a n +ew # list onto the replica list of lists containing the dereferenced # contents of the original row. # foreach my $row (@$rlOriginal) { push @$rlReplica, [@$row]; } # Return the completed grid replica. # return $rlReplica; } # # -:-:-:- End of replicateGrid() -:-:-:- # # ------------ sub validateGrid # ------------ # Subroutine to validate the puzzle grid just read from data file. # { # Get grid to validate. Initialise hash that will be used to # hold the numbers found in each row, column or block so that # duplicate numbers can be spotted. # my $rlGrid = shift; my($row, $col, %numbersSeen); # First, examine grid row by row for duplicates. # for $row (0 .. 8) { # Reset numbers seen hash for each row; move along, column # by column, incrementing hash entry for numbers seen. Ignore # blank cells. # %numbersSeen = (); for $col (0 .. 8) { next if $rlGrid->[$row]->[$col] eq " "; $numbersSeen{$rlGrid->[$row]->[$col]} ++; } # Now check each hash entry for multiple numbers. Return an # error string if a multiple is found. # for (keys %numbersSeen) { return "Row @{[$row + 1]} has more than one $_" if $numbersSeen{$_} > 1; } } # Do the same for columns. # for $col (0 .. 8) { # Reset hash for each column this time; move down column, row +by # row. # %numbersSeen = (); for $row (0 .. 8) { next if $rlGrid->[$row]->[$col] eq " "; $numbersSeen{$rlGrid->[$row]->[$col]} ++; } # Again, check for multiples, returning an error string if # appropriate. # for (keys %numbersSeen) { return "Column @{[$col + 1]} has more than one $_" if $numbersSeen{$_} > 1; } } # Now examine the 3x3 blocks. Check in the order top-left, top- # centre, top-right, middle-left, middle-centre, middle-right, # bottom-left, bottom-centre, bottom-right. # my @blockNames = qw( Top-left Top-centre Top-right Middle-left Middle-centre Middle-right Bottom-left Bottom-centre Bottom-right); # Take every third column within every third row as the top-left # cell in each of our 3x3 blocks. # for $row (0, 3, 6) { for $col (0, 3, 6) { # Reset hash, get current block name. # %numbersSeen = (); my $blockname = shift @blockNames; # For this block, move across the three columns within # the three rows recording which numbers we see. # for ( my $blockRow = int($row / 3) * 3; $blockRow < (int($row / 3) + 1) * 3; $blockRow ++) { for ( my $blockCol = int($col / 3) * 3; $blockCol < (int($col / 3) + 1) * 3; $blockCol ++) { next if $rlGrid->[$blockRow]->[$blockCol] eq " "; $numbersSeen{$rlGrid->[$blockRow]->[$blockCol]} ++ +; } } # Check, and return error string if multiple found. Only # detects first error, there may be more. # for (keys %numbersSeen) { return "$blockname block has more than one $_" if $numbersSeen{$_} > 1; } } } # If all tests have been passed, return 0 (false) so that no error # is flagged. # return 0; } # # -:-:-:- End of validateGrid() -:-:-:- #

It reads the puzzle to be solved from a file specified on the command line and here's an example using the same puzzle grid as Jenda used.

5...7.682 ...596... ......... ....8..49 .36...... ......... ..8..7..1 ..3..4..7 64.3...2.
It seems to be a bit quicker than Jenda's solver but, as I've said, the guessing is somewhat optimised and it wasn't anything like as fast when first written.

Cheers,

JohnGG

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://600550]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others studying the Monastery: (4)
As of 2021-10-20 08:07 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    My first memorable Perl project was:







    Results (79 votes). Check out past polls.

    Notices?