Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl-Sensitive Sunglasses
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??
#! /usr/local/bin/perl our $VERSION = '2.0.0'; use strict; use warnings; use Quantum::Superpositions; use Getopt::Compact; use Pod::Usage; my $opt = new Getopt::Compact (struct => [[[qw(v verbose)], qq(verbose mode, print grid after each i +teration)], [[qw(q quiet)], qq(quiet mode, just print result)], [[qw(s summary)], qq(print summary at end)], [[qw(m man)], qq(Print Pod doc as man page)], ])->opts; pod2usage(-verbose => 3) if $opt->{man}; my $init = any(1..9); my $grid = # Setup - we know nothing ! [ [$init,$init,$init, $init,$init,$init, $init,$init,$init], [$init,$init,$init, $init,$init,$init, $init,$init,$init], [$init,$init,$init, $init,$init,$init, $init,$init,$init], [$init,$init,$init, $init,$init,$init, $init,$init,$init], [$init,$init,$init, $init,$init,$init, $init,$init,$init], [$init,$init,$init, $init,$init,$init, $init,$init,$init], [$init,$init,$init, $init,$init,$init, $init,$init,$init], [$init,$init,$init, $init,$init,$init, $init,$init,$init], [$init,$init,$init, $init,$init,$init, $init,$init,$init], ]; my $known = 0; # How many cells do we know the value of ? readpuzzle(); my $start = $known; my $timer = time(); my $loops = 0; #Keep looping round till there's no changes. printgrid() while (elimrows() + elimcols() + elimsquares() and $known +< 81); $known == 81 ? finalgrid() : printgrid(1); if ($opt->{summary}) { my $elapsed = time() - $timer; print "Solved in $elapsed secs. with $loops iterations over the gri +d.\n"; print "Initial grid $start, finished $known\n"; } exit; # That's the end of the main code, rest are supporting subroutines. # For each row, collect the known values and eliminate those values fr +om the # states of the other cells sub elimrows { my $changed = 0; $loops++; for my $row (0..8) { my ($known,$seen) = gather($row,0,'row'); for my $col (0..8) { my $cell = $grid->[$row][$col]; # Eliminate all known values from this cell's state my $to = $cell != all(@$known); next if eigenstates($cell) == 1; if (eigenstates($cell) > 1 and eigenstates($cell) > eigenstat +es($to)) { # We have reduced the eigenstates of a cell, so record thi +s. $changed++; record($row,$col,$to,'Row elimination'); # If there's now only one possible state for this cell, we + have a new known value. } elsif (eigenstates($cell) > 1) { for (eigenstates($cell)) { record($row,$col,$_,'Row only option') if ($seen->{$_} +== 1); # This is the only cell that can have this value, so se +t it. } } } } return $changed; } # For each column, collect the known values and eliminate those values + from the # states of the other cells sub elimcols { my $changed = 0; for my $col (0..8) { my ($known,$seen) = gather(0,$col,'column'); for my $row (0..8) { my $cell = $grid->[$row][$col]; next if eigenstates($cell) == 1; my $to = $cell != all(@$known); if (eigenstates($cell) > 1 and eigenstates($cell) > eigenstat +es($to)) { $changed++; record($row,$col,$to,'Column elimination'); } elsif (eigenstates($cell) > 1) { for (eigenstates($cell)) { record($row,$col,$_,'Column only option') if ($seen->{$ +_} == 1); # This is the only cell that can have this value, so se +t it. } } } } return $changed; } # As above but for 3*3 square sub elimsquares { my $changed = 0; for my $row (0..8) { for my $col (0..8) { my ($known,$seen) = gather($row,$col,'square'); my $cell = $grid->[$row][$col]; next if eigenstates($cell) == 1; my $to = $cell != all(@$known); if (eigenstates($cell) > 1 and eigenstates($cell) > eigenstat +es($to)) { $changed++; record($row,$col,$to,'Square elimination'); } elsif (eigenstates($cell) > 1) { for (eigenstates($cell)) { record($row,$col,$_,'Square only option') if ($seen->{ +$_} == 1); } } } } return $changed; } sub readpuzzle { for my $row (0..8) { my $line = <>; chomp($line); my @row = split //, $line; for my $col (0..8) { my $cell = shift(@row); next if $cell eq '.'; $grid->[$row][$col] = $cell; $known++; } } } sub printgrid { return unless shift or $opt->{verbose}; print "\n "; printf "%-9s " ,$_ for (qw(A B C D E F G H I)); print"\n"; my $rc = 1; foreach my $row (@$grid) { print $rc++, ") "; map {printf "%-9s " , join('',sort(eigenstates($_)))} @$row; print "\n"; } print "\n"; } sub finalgrid { print "\nCompleted : \n\n"; print join('',@$_), "\n" for (@$grid); print "\n"; } sub record { my ($row,$col,$to,$type) = @_; my $state = state($row,$col); $grid->[$row][$col] = $to; # We have recorded the reduced eigenstates, but only report if new +known value. return unless eigenstates($to) == 1; printf("%-14s => %d by %s\n",$state,$to,$type) unless $opt->{quiet} +; $known++; } # User friendly Column/Row indication. sub loc { my ($row,$col) = @_; return sprintf('%s%d',chr(ord('A')+$col),$row+1); } # User friendly Column/Row indication and state sub state { my ($row,$col) = @_; return sprintf('%s=any(%s)',loc($row,$col),join('',sort(eigenstates +($grid->[$row][$col])))); } # Returns (\@known,\%seen) # @known is an array of the known values in the row/column/square (cel +ls with only one possible state) # %seen is a hash of times that each number occurs in the states of ot +her cells in the row/column/square, # but NOT counting the known states. sub gather { my ($row,$col,$type) = @_; my @known = (); my %seen = (); $seen{$_} = 0 for (1..9); if ($type eq 'square') { #print "Gather Square " . loc($row,$col) . " => ..."; for my $r (0..2) { for my $c (0..2) { #printf '%s, ',state(3*int($row / 3)+$r,3*int($col / 3)+$c +); my $cell = $grid->[3*int($row / 3)+$r][3*int($col / 3)+$c] +; eigenstates($cell) == 1 ? push (@known,$cell) : $seen{$_} +++ for (eigenstates($cell)); } } #print "\n"; } elsif ($type eq 'row') { for my $col (0..8) { my $cell = $grid->[$row][$col]; eigenstates($cell) == 1 ? push (@known,$cell) : $seen{$_}++ +for (eigenstates($cell)); } } elsif ($type eq 'column') { for my $row (0..8) { my $cell = $grid->[$row][$col]; eigenstates($cell) == 1 ? push (@known,$cell) : $seen{$_}++ +for (eigenstates($cell)); } } # Don't count states where we already have a known value (These mul +tiple occurances are about to # be eliminated in the calling function) $seen{$_} = 0 for @known; return (\@known,\%seen); } __END__ =head1 NAME SuDoKu Solver =head1 VERSION This document describes the version released 28-Dec-04 =head1 SYNOPSIS sudoku h3.sud -h, --help This help message -v, --verbose Verbose mode, print grid after each iteration -q, --quiet Quiet mode, just print result -s, --summary Print summary at end -m, --man Print Pod doc as man page =head1 BACKGROUND This is a solver for SuDoKu puzzles. SuDoKu puzzles are a 9*9 grid of numbers. At the start, some are provided for you. Your challenge is to find the initially unknown values. =head2 Puzzle File input format ..21.64.. ..93875.. 7...2...8 ..1...7.. .9..3..6. ..5...8.. 8...6...5 ..34786.. ..49.13.. =head2 Rules Each column, row and 3*3 square contains the numbers 1..9 once each. =head1 How to solve a SuDoKu puzzle Iterate over each cell in the grid =head2 Elimination =over =item Pick a cell. =item Check the same Column, Row and 3*3 Square (CRS). None of the known values in the same CRW can be in this cell. =item If that only leaves us one possible value, we have a new known v +alue. =back =head2 the "Only" option =over =item For a given CRS, look at the possible values for each cell witho +ut a known state. =item If one of the possibilities occurs only once in the CRS (and is not an existing known value, ) then the cell where it is a possibilit +y must have that value, giving us a new known value. =back Finding a new known cell value will reduce the possbilities for other unknown states in the same CRS as the newly discovered cell. Iterate, checking each cell until solved. =head1 AUTHOR Richard Nuttall (richard-code@nuttall.uk.net) =head1 COPYRIGHT Copyright (c) 2004, Richard Nuttall ll Rights Reserved. This module is free software. It may be used, redistributed and/or modified under the stame terms as Perl-5.8.0 (or later) (see http://www.perl.com/perl/misc/Artistic.html). =head1 BUGS This solver only works for puzzles that can be determined by logic alo +ne. If it is given a puzzle with insufficient, or inconsistent clues, or o +ne that requires backtracking, it will fail. =cut

In reply to SuDoKu solver by Brovnik

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others imbibing at the Monastery: (13)
    As of 2015-07-28 09:52 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









      Results (254 votes), past polls