#!/usr/bin/perl
#
# solve [-p 0|1|2] [-d 0|1] [-s [0|1] [-w #] [-l <seconds>] [-e <filename>]
#
# solves sudoku as best I know how.
#
# option -p 0  -- only print the puzzle at the end [default]
# option -p 1  -- print after each pass over the board
# option -p 2  -- print after each grouping is considered
# option -d 0  -- omit decision information to printout [default]
# option -d 1  -- add decision information to printout
# option -s 0  -- don't print summary text from each pass
# option -s 1  -- print summary text from each pass [default]
# option -w #  -- how wide to make each cell in the printout [3]
# option -l <sec> -- how long to wait between puzzle printouts [0.25]
# option -e <file> -- solve the given file, can be - to read from stdin
#
# input file read is fairly flexible.  a comma separated list is ideal.
#it will accept files in the initializer format used below for $tough
#and $diabolical [try cutting and pasteing].  for completness it also
#accepts puzzles in the ascii-art box format generated as output from
#this program.
#
# please let me know if there are valid sudoku that this fails to solve.
# v0.2   09/19/2005     works good enough for all the puzzles I have
# v1.6   10/09/2005     fast, thorough, works.
# v1.7   10/10/2005     added file-read
# v2.0   11/30/2005     deals with conflicts from implications not just
#                        in same group [row/colum/box] for values with only
#                        two options. [does not work for n-options.]
# v2.1   12/29/2005     fixed stupid return value bug that broke some puzzles
# v2.2   01/03/2005     actually fixed above bug. [oops]
#  esw@alum.mit.edu   from http://wile.org/sudoku/

$diabolical=[ 
[1,0,5,0,7,0,4,0,0], 
[0,0,0,0,0,1,9,5,0], 
[7,0,8,5,0,0,0,0,0],
[2,0,0,0,3,7,0,9,0],
[0,0,0,0,2,0,0,0,0],
[0,3,0,9,4,0,0,0,5],
[0,0,0,0,0,4,5,0,2],
[0,7,3,6,0,0,0,0,0],
[0,0,9,0,1,0,3,0,4],
];

$tough=[
[0,0,6,0,1,0,9,0,0],
[0,0,0,0,0,8,7,4,0],
[0,0,0,0,2,0,3,1,0],
[4,0,0,0,0,9,0,8,0],
[0,0,5,2,0,6,4,0,0],
[0,8,0,3,0,0,0,0,2],
[0,1,7,0,6,0,0,0,0],
[0,3,4,5,0,0,0,0,0],
[0,0,9,0,3,0,1,0,0],
];

require 'getopts.pl';

Getopts('p:s:d:w:l:e:'); 

#actual puzzle solving is done on $usepuzzle
$usepuzzle=$tough;  if ("$opt_e" ne "") { $usepuzzle=readpuzzlefile($opt_e); }

$progress=1;        if ("$opt_s" ne "") { $progress=$opt_s; }
$printing=0;
$pausing=0;         if ("$opt_p" ne "") { $printing=$pausing=$opt_p; }
$pause=0.25;        if ("$opt_l" ne "") { $pause=$opt_l; }

$printwidth=3;      if ("$opt_d" ne "") { $printwidth=5 }
                    if ("$opt_w" ne "") { $printwidth=$opt_w; }
$printopts=0;       if ("$opt_d" ne "") { $printopts=$opt_d; }

sub readpuzzlefile($) {
    my($enterfile)=@_;
    if ("$enterfile" eq "-") {
	$fh=STDIN;
    } else {
	open($fh, "$enterfile") || die "can't open $enterfile\n";
    }
    my($linecount, @mypuz)=(0,());
    while(<$fh>) {
	chomp;
	my(@line)=split /[\[\],|]/;
	@line=map {  (/^$/)?():$_; } @line;
	if ($#line == 8) {
	    my(@row) = map {  (/^(\W)+$/)?0:$_; } @line;
	    @row=map {  (s/(\W)+//g); $_; } @row;
	    $mypuz[$linecount]=\@row;
	    $linecount++;
	}
    }
    if ($linecount == 9) {
	print "using given puzzle with $#mypuz+1 rows\n" if $progress;
	return \@mypuz;
    } else {
	die "only read $linecount reasonable lines from $enterfile";
    }
}

sub boxidx($$) { my($outer,$inner)=@_;
		 return int($outer/3)*3+int($inner/3),($outer%3)*3+$inner%3; }
sub rowidx($$) { return $_[1],$_[0]; }
sub colidx($$) { return $_[0],$_[1]; }

sub anythingspossible($) {
    my($solved)=@_;
    my($opts, $countopts);
    for( $i=0; $i<9; $i++) {
	for( $j=0; $j<9; $j++) {
	    $opts->[$i][$j]{'solved'}=0;
	    $opts->[$i][$j]{'i'}=1+$i;
	    $opts->[$i][$j]{'j'}=1+$j;
	    if ($solved->[$i][$j] ne 0) {
		$opts->[$i][$j]{'freeopt'}=1<<($solved->[$i][$j]-1);
		$opts->[$i][$j]{'decided'}=$opts->[$i][$j]{'freeopt'};
		$countopts++;
	    } else {
		$opts->[$i][$j]{'freeopt'}=(2**9)-1; # bits 1-9 all set
		$opts->[$i][$j]{'decided'}=0;
		$countopts+=9;
	    }
	}
    }
    return ($opts, $countopts);
}

sub bitset($$) { 
    my($opt, $bit)=@_;
    return $opt & (1<<($bit));
}

sub unset($$) { 
    my($opt, $bit)=@_;
    return $opt & (~(1<<($bit)));
}

sub optshash($) {
    my($opt)=@_;
    return join('', map { bitset($opt,$_)?$_+1:'' } (0..8));
}

sub printpuz($$@) {
    my($opts,$showopts,$width)=@_;
    if ($width < 2) { $width=3; }
    my($hpad)=join("", map { "-" } (1..$width));
    my($hsep)=join("*", map { $hpad } (1..9) );
    print "*$hsep*\n";
    foreach my $optrow (@$opts) {
	my(@vals)=map {	optshash($_->{'freeopt'} | $_->{'solved'} ) } @$optrow;
	my(@solved)=map { if (length($_) eq 1) { $_ } else { ' ' } } @vals;
	my(@wideval)=map { sprintf "%-*s", 1+$width/2,$_ } @solved;
	my($line)=join("|", map { sprintf "%*s", $width, $_ } @wideval);
	if ($showopts) {
	    $hsep=join("*", map { sprintf "%.*s", $width,$_.$hpad } @vals);
	}
	print "|$line|\n";
	print "*$hsep*\n";
    }
    select(undef,undef,undef,$pause) if $pausing;
}

sub numbits($) {
    my($optcp)=@_;
    my($optcount)=0;
    foreach (1..9) {
	if ($optcp&1) {
	    $optcount++;
	}
	$optcp=$optcp>>1;
    }
    return $optcount;
}

sub combine($@) {
    my($lastcombinationsref, @newcombinations)=@_;
    my(@combinations);

    foreach my $outercombination (@$lastcombinationsref) {
	my($outervalue,@alreadyusedentries)=@$outercombination;

	foreach my $newcombination (@newcombinations) {
	    my($newvalue,$curentry)=@$newcombination;
	    my($disqualified)=0;
	    foreach my $testentry (@alreadyusedentries) {
		#only have to check each combination, not permutation
		if ($testentry le $curentry) {
		    $disqualified=1;
		}
	    }
	    if (! $disqualified) {
		my(@usedinentry)=@alreadyusedentries;
		push @usedinentry, $curentry;
		push @combinations, [ $outervalue|$newvalue, @usedinentry];
	    }
	}
    }
    return @combinations;
}

@checkdecision=[ \&valuefordecisionlist, \&nullvectorinentriesnotinlist, 1 ];
# width==1  is the basic sudoku rules for rows/columns/boxes:
#           if an entry "claims" exclusively a value [eg it is a
#           or it can be none other than that value] then disallow
#           that value for the others in the group
#
# width==n  if amongst n entries, n values are "claimed" exclusively,
#           then disallow those n values for others in the group.

@checkforced=[ \&valueforforcedlist, \&entriestosetforforced, 0 ];
# width==1  if any entry is the only one that could possibly be 
#           a certain value, eliminate the other possible values
#           that entry might have been
#
# width==n  if amongst n values, n entries the only ones which
#           could possibly satisfy that value, eliminate other
#           possible values for each of the n entries.

sub check($$$$@) {
    my($opts, $idxfn, $x, $width, $functions)=@_;
    ($valueforinit, $entriestoset, $commit)=@$functions;

    my(@groupoptions)=map { ($i,$j)=&$idxfn($x,$_);
			    \$opts->[$i][$j]{'freeopt'}} (0..8);

    my(@basecombinations)=map { &$valueforinit($_,\@groupoptions) } (0..8);

    my(@combinations)=@basecombinations;
    foreach (2..$width) { # generates all $width-combinations of entries 
	@combinations=combine(\@combinations,@basecombinations);
    } 

    foreach my $combination (@combinations) {
	($entry,@usedinentry)=@$combination;

	if (numbits($entry) eq $width) {
	    my($newlimit, @entriestoset)=&$entriestoset($entry, @usedinentry);
	    foreach my $optionsref (@groupoptions[@entriestoset]) {
		$$optionsref &= $newlimit;
	    }
	}
    }

    return (($width eq 1) && $commit);
}


sub checkinfer($$$$) {
    my($opts, $idxfn, $x, $ruleref)=@_;

    foreach $val (0..8) {
	my(@vallist)=();
	foreach $y (0..8) {
	    ($i,$j)=&$idxfn($x,$y);
	    $thisopt=\$opts->[$i][$j]{'freeopt'};
	    if (bitset($$thisopt, $val)) {
		my(@tuple)=($val, $i, $j, $$thisopt);
		push(@vallist, \@tuple);
	    }
	}
	foreach $tupleidx (0..$#vallist) {
	    my(@tuple)=@{$vallist[$tupleidx]};
	    foreach $tuplecompareidx (0..$#vallist) {
		my(@impliedtuple)=@{$vallist[$tuplecompareidx]};
		if ($tupleidx != $tuplecompareidx) {
#	  	    if this ($val, $i, $j) were true, then what's implied?
#  i think I have to say "i would be $val if $i,$j was $otherval
		    my($val)=$tuple[0];

		    my($choicehash)=optshash($tuple[3]);
		    my($remainval)=unset($impliedtuple[3],$val);

		    #only deal with single choice left options...
		    if (numbits($remainval)==1) {
			my($remainhash)=optshash($remainval);
                        # only one option in remainhash
			$impliedtuple[0]=$remainhash-1;
			addtuple($ruleref, \@tuple, \@impliedtuple);
			
#			print "we have ", keys %rules, "ref: ", \%rules, " \n";
		    }
		}
	    }
	}

    }
}

sub displayrules($) {
    my($rulesref)=@_;
    foreach $id ( sort keys %$rulesref ) {
	my($ourhashref)=$rulesref->{$id};
	print "$id -- ", join(", ",map {"$_=$ourhashref->{$_}"} sort keys %$ourhashref), "\n";
    }
}

sub rulesstats($) {
    my($rulesref)=@_;
    my($numrules)=0;
    foreach $id ( sort keys %$rulesref ) {
	my($ourhashref)=$rulesref->{$id};
	my(@thiskeys)=keys %$ourhashref;
	$numrules+=$#thiskeys;
    }
    return $numrules;
}

#two ways... either self-inconsistencies, or
#things that must be true for both (x,y)=b & (x,y)=c where b&c are

sub checkrules($$) {
    my($opts,$rulesref)=@_;
    my(%newrules);
    my($numremoved)=0;
    foreach $id ( sort keys %$rulesref ) {
	my($ourhashref)=$rulesref->{$id};
	%{$newrules{$id}}=%$ourhashref;
    }
    foreach $id ( sort keys %$rulesref ) {
	my($ourhashref)=$rulesref->{$id};
	foreach $implcoord ( keys %$ourhashref ) {
	    my($implication)="$implcoord==$ourhashref->{$implcoord}";
	    my($impliedhashref)=$rulesref->{$implication};
	    foreach $secondimplcoord ( keys %$impliedhashref) {
		my($implvalfororig)=$newrules{$id}->{$secondimplcoord};
		my($secondimplval)=$impliedhashref->{$secondimplcoord};
		my($res)=addid(\%newrules, $id, 
			       $secondimplcoord, 
			       $secondimplval);
		if ($res == 1) {
		    $id =~ /\((\d+),(\d+)\)==(\d+)/;
		    my($i,$j,$val)=($1,$2,$3);
		    my($optref)=\$opts->[$i][$j]{'freeopt'};
		    if (bitset($$optref, $val)) {
			print "$i,$j can't be $val because $secondimplcoord has to be $secondimplval and $implvalfororig\n" if ($printing == 3);
			#remove $val as an option in $opts[$i][$j]
			$$optref=unset($$optref, $val);
			$numremoved++;
		    } # else it's already been removed.
		}
#		print "adding $secondimplication to $id\n";
	    }
	}
    }
    foreach $id ( sort keys %newrules ) {
	my($ourhashref)=$newrules{$id};
	%{$rulesref->{$id}}=%$ourhashref;
    }
    return $numremoved;
}


sub addtuple($$$) {
    my($rulesref, $tupleref, $tuple2ref)=@_;
    my($id)="($tupleref->[1],$tupleref->[2])==$tupleref->[0]";
    my($impliedidx)="($tuple2ref->[1],$tuple2ref->[2])";
    my($impliedval)=$tuple2ref->[0];
    return addid($rulesref, $id, $impliedidx, $impliedval);
}

sub addid($$$$) {
    my($rulesref, $id, $impliedidx, $impliedval)=@_;

    my($implied)="$impliedidx==$impliedval";

    return 0 if ("$implied" eq "$id");
    my($hashref)=$rulesref->{$id};
    foreach $idx (keys %$hashref) {
	return 0 if ("$implied" eq "$idx==$hashref->{$idx}");
    }
    #contradiction!
    return 1 if ( "$rulesref->{$id}->{$impliedidx}" ne "" );
    $rulesref->{$id}->{$impliedidx}=$impliedval;
    return 0
}


#these next two functions are for the checkalreadydecided type of 
#checking: if the entry or entries claim a value, then disallow for
#the rest of the group.
sub valuefordecisionlist($$) {
    my($value,$entries)=@_;
    my($entryref)=$entries->[$value];
    if (! $$entryref) { return (); }
    return [$$entryref, $value] ;
}

sub setvectorinentriesnotinlist($@) {
    my($valuevector, @entriesused)=@_;
    my($val,@other)=nullvectorinentriesnotinlist($valuevector, @entriesused);
    return (~$val,@other);
}
#make sure those bits are unset in all the other entries!
sub nullvectorinentriesnotinlist($@) {
    my($valuevector, @entriesused)=@_;
    my(@omit)=sort { $b <=> $a } @entriesused; 
        #should be already sorted, but just checking to be safe.
    my(@otherentries);
    my($topomit)=pop(@omit);

    foreach my $val (0..8) {
	if ( ($#omit > -1) &&
	     ( $val > $topomit)) {
	    $topomit=pop(@omit);
	}
	if ( $val != $topomit) {
	    push @otherentries, $val;
	} 
    }
    return (~$valuevector, @otherentries);
}


#these next two funcitions are for the checkforced type of checking:
#iterating over each value in a group and checking if one [or more]
#entries are the only ones to possibly satisfy the requirement.
#values are stored packed in the bits of each entry, grab a slice
sub valueforforcedlist($$) {
    my($value,$entries)=@_;
    my($accum)=0;
    foreach my $entry (@$entries) {
	$accum = ($accum<<1) | ($$entry>>$value & 1);
    }
    if (! $accum ) { return (); }
    return [$accum, $value];
}

#the values in @usedvalues are turned into a bit-vector mask. this mask
#is applied to the options for each entry used in the winning combination,
#in order to force that entry to take on this value. [or n-entries,n-values]
sub entriestosetforforced($@) {
    my($entryvector, @usedvalues)=@_;
    my($newlimit)=0;
    foreach my $value (@usedvalues) {
	$newlimit |= 1<<$value;
    }
    my(@forcelist)=();
    foreach my $idx (0..8) {
	if (($entryvector>>(8-$idx))&1) { 
	    push @forcelist, $idx;
	}
    }
    return ( $newlimit, @forcelist );
}

#mostly just an optimization -- the transition from an undecided cell
#which is a bit-vector in 'freeopt' to a 'decided' cell happens asap,
#once it has gone through a checkdecision-type checking round
#to propagate its implications, then its bit vector is retired [set
#to zero] and it is 'solved'.  zero'd bit vectors speed things up
#because they get excluded from all combinations.
sub markdecided($$) {
    my($opts,$commitsolved)=@_;
    my($solvedcount, $decidedcount, $countopts )=(0,0,0);
    foreach my $optrow (@$opts) {
	foreach my $opt (@$optrow) {
	    my($numbits)=numbits($opt->{'freeopt'}|$opt->{'solved'});
	    $countopts+=$numbits;
	    if ($numbits eq 0) {
		printpuz($opts,1,$printwidth);
		die "puzzle error: square $opt->{'i'},$opt->{'j'} with no options available!!!";
	    }
	    if ( $opt->{'decided'} && $commitsolved)
	    {
		$opt->{'solved'}=$opt->{'decided'};
		$opt->{'decided'}=0;
		$opt->{'freeopt'}=0;
		$solvedcount++;
            }
	    if ( !$opt->{'solved'} && !$opt->{'decided'} && ($numbits eq 1))
	    {
		$opt->{'decided'}=$opt->{'freeopt'};
		$decidedcount++;
	    }
	}
    }
    return ( $solvedcount, $decidedcount, $countopts );
}

sub solve($) {
    my($solved)=@_;
    my($lastopts,$commitflag,$committed,$decided);
    my(%rulebase);

    my($opts, $numopts)=anythingspossible($solved);
    print "initially have $numopts options\n" if $progress;

    my($width)=1;
    printpuz($opts,$printopts,$printwidth) if $printing;

    @idxfns= ( \&rowidx, \&colidx, \&boxidx );
    @checkfnrefs= ( \@checkdecision, \@checkforced );

    while(($width < 9) && ($numopts > 81)) {
	$lastopts=$numopts;
	
	if ($width == 3) {
	    %rulebase={};
	    foreach my $idxfn (@idxfns) {
		foreach my $x (0..8) {
		    checkinfer($opts,$idxfn,$x, \%rulebase);
		}
	    }
	    my($numremoved,$lastnumrules)=0;
	    my($numrules)=rulesstats(\%rulebase);
	    my($depth)=0;
	    while (($numremoved == 0) && ($numrules != $lastnumrules)) {
		$lastnumrules=$numrules;
		$numremoved=checkrules($opts, \%rulebase);
		$numrules=rulesstats(\%rulebase);
		$depth++;
	    }
	    ($committed,$decided,$numopts)=markdecided($opts,0);
	    print "now have $numopts options at $width/2 $decided decided, $committed committed, $numrules numrules, $depth depth\n" if $progress;

	    if ($numremoved != 0) {
		$width=1;
		printpuz($opts,$printopts,$printwidth) if $printing;
	    }
	}

	foreach my $checktype (@checkfnrefs) {
	    foreach my $idxfn (@idxfns) {
		foreach my $x (0..8) {
		    $commitflag=check($opts,$idxfn,$x,$width,@{$checktype});
		    printpuz($opts,$printopts,$printwidth) if ($printing==2);
		}
	    }
	    ($committed,$decided,$numopts)=markdecided($opts,$commitflag);
	    print "now have $numopts options at $width/${$checktype}[0][2] $decided decided, $committed committed\n" if $progress;

	}
	if ($numopts == $lastopts) {
	    $width++;  # no luck? -- try looking for 2 or 3 at-a-time, etc.
	} else {
	    $width=1;  # stay at one-at-a-time while that works ok.
	}
	printpuz($opts,$printopts,$printwidth) if $printing;
    }
    printpuz($opts,$printopts,$printwidth) if !$printing;
    if ($numopts != 81) {
	print "unsolveable by this program. [no unique solution?]\n";
    }
}

solve($usepuzzle);