Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked

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 ( =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 =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

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!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • 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?

    What's my password?
    Create A New User
    and all is quiet...

    How do I use this? | Other CB clients
    Other Users?
    Others wandering the Monastery: (7)
    As of 2018-03-22 00:45 GMT
    Find Nodes?
      Voting Booth?
      When I think of a mole I think of:

      Results (272 votes). Check out past polls.