#!/usr/bin/perl -w
use strict;
#
# Start with a file containing an incomplete sudoku, and construct
# a complete one from it.
# Reads the file, writes it to a scratch file, and runs the solver;
# if there are two solutions, it picks a difference and "resolves" it,
# then does it again from the top.
# When there is just one solution it writes it to a new file.
#
my $board_size = 81;
my $row_length = 9;

my $seed_fname;
my $scratch_fname = "/tmp/temp.build_sudoku.$$.scratch";
my $fill_pattern_file;

my @board;
my @solution_1;
my @solution_2;
my @diffs_1;			# Difference map, changed cells from soln 1
my @diffs_2;			# Difference map, changed cells from soln 2
my @diff_to_apply;
my $do_opt = 1;
my $opt_to_level = 0;	       # Optimize to this level, but no higher
my $min_level = 0;	       # Keep retrying the optimization until we produce a board of at least this level
my $level_max_retries = 10;
my $do_sort = 1;
my $remove_like_add = 0;
my $remove_reverse_add = 0;
my $remove_from_board_top = 0;
my $remove_from_board_bottom = 0;
my $remove_random = 1;
my $remove_high = 0;
my $do_shuffle = 0;
my $do_scramble = 0;
my $do_build_board = 1;
my $do_rand_build = 1;
my $force_pattern = 0;		# Try to force it into the pattern by retrying until we get it right
my $build_in_pattern = 0;	# Try to build it in the pattern to start with, using backtracking
my $build_to_level = 0;		# Try to arrive at a particular level when the pattern's filled
my $pattern_length = 0;
my $pattern_max_retries = 120;
my $max_build_time = 60;
my $max_optimize_time = 120;
my $sparse = 0;

my $sort_arg = "";
my $natural_arg = "";
##my $build_arg = "-for_build";
my $build_arg = "";
my $hybrid_arg = "";

my $solver_level = 0;
my $stars_rating = 0;
my $raw_rating = 0;

my $start_time = time();

# ****************************************************************

my $debug = 0;
sub dbprint ($) {
    my ($arg) = @_;
    if ($debug) { print $arg; }
}

# ****************************************************************
# Return a shuffled set of integers, from 0 to N-1
#
# There seem to be issues with the random number generator.
# Letting it produce values between 0 and 1 seems to help; asking for
# a range of values up to an integer and then truncating seems to
# produce really gruesome results.

sub shuffled_set_N ($) {
    my ($n) = @_;
    my @set = (0..$n-1);
    foreach my $t (0..2) { # Run the algorithm 3 times, since it seems to stink.
	foreach my $from (1..$n-1) {
	    my $ra_v = rand();
	    my $rv = int($ra_v * ($from+1));
	    ##print "Rand value: $ra_v, $rv\n";
	    my $to = int($rv);
	    my $swap = $set[$to];
	    $set[$to] = $set[$from];
	    $set[$from] = $swap;
	}
    }

    ##print "Shuffled set of $n items: ";
    ##foreach my $j (0..$n-1) { print "$set[$j] "; }
    ##print "\n";
    return (@set);
}

# ****************************************************************
# Shuffle a list, using shuffled_set_N to generate the permutation

sub shuffle_list (@) {
    my (@in_array) = @_;
    my @permutation = shuffled_set_N (scalar(@in_array));
    my @out_array;
    foreach my $i (@permutation) {
	push @out_array, $in_array[$i];
    }
    return (@out_array);
}

# ****************************************************************
# Read a board from a list of lines, and return the result

sub read_board_list (@) {
    my (@lines) = @_;
    my $row_base = 0;
    my $row_count = 0;
    my @new_board;
    foreach my $line (@lines) {
	if ($line =~ /^\s*\#/) { # Skip comment lines
	    next;
	}
	if ($line =~ /^\s*$/) {	# Skip blank lines
	    next;
	}
	if ($line =~ /\s*(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)/) {
	    my @row = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
	    dbprint ("read_board_list: Read row: $1, $2, $3, $4, $5, $6, $7, $8, $9\n");
	    dbprint ("read_board_list: Row: @row\n");
	    foreach my $i (0..8) {
		if ($row[$i] =~ /^(?:-+)|0$/) {
		    $new_board[$row_base + $i] = 0;
		} elsif ($row[$i] =~ /^[1-9]$/) {
		    $new_board[$row_base + $i] = $row[$i];
		} else {
		    die "Index $i, entry $row[$i]: Line in file not understood: '$line'\n";
		}
	    }
	    $row_base += $row_length;
	    $row_count ++;
	    if ($row_count >= 9) { last; }
	}
    }
    if ($row_count != 9) { die "Wrong number of rows in file: $row_count"; }
    return (@new_board);
}

# ****************************************************************
# Print a board

sub print_board ($@) {
    ##dbprint "entering print_board\n";
    my ($header,@bd) = @_;

    if (defined($header) && $header ne "") { print "$header\n"; }
    foreach my $i (0..$row_length-1) {
	if ($i > 0) {
	    print "\n";
	    if (! ($i % 3)) { print "\n"; }
	}
	foreach my $j (0..$row_length-1) {
	    if ($j > 0) {
		print " ";
		if (! ($j % 3)) { print " "; }
	    }
	    my $square = $bd[($i*$row_length)+$j];
	    if (! $square) { $square = "-"; }
	    print "$square";
	}    
    }
    print "\n";
}

# ****************************************************************
# Read the seed file and initialize the board

sub read_seed_file () {
    foreach my $i (0 .. $board_size-1) {
	$board[$i] = 0;
    }
    open FL, "<$seed_fname" or die "Can't open input file $seed_fname\n";
    my @board_list;
    while (<FL>) {
	push @board_list, $_;
    }
    close FL or die "Error closing input file $seed_fname\n";

    @board = read_board_list (@board_list);

    print "Starting board:\n\n";
    print_board ("", @board);
    print "\n";

}

# ****************************************************************
# Write the board to a scratch file

sub write_scratch_board (;$) {
    my ($suffix) = @_;
    if (! defined($suffix)) { $suffix = ""; }

    open SBOARD, ">${scratch_fname}${suffix}" or die "Can't open scratch board for output";
    
    foreach my $i (0..$row_length-1) {
	if ($i > 0) { print SBOARD "\n"; }
	foreach my $j (0..$row_length-1) {
	    if ($j > 0) { print SBOARD " "; }
	    print SBOARD "$board[($i*$row_length)+$j]";
	}    
    }
    close SBOARD or die "Error closing scratch board";
}

# ****************************************************************
# Run the solver and read the two solution boards.
# Returns the count of solutions found.

sub read_solutions (;$) {
    my ($quick_check) = @_;
    write_scratch_board();

    my $quick_args = "";
    if ($quick_check) {
	$quick_args = "-all_at_once -level 5";
    }
    my $soln_text = `solve_sudoku $sort_arg $scratch_fname $build_arg $natural_arg $hybrid_arg -silent $quick_args`;

    dbprint "Raw solution text:\n";
    dbprint $soln_text;
    dbprint "\n";

    my $solution_count = 0;
    my @split_text = split /\n/, $soln_text;
    my $lnno = 0;

    my $bad = 0;
    foreach my $ln (@split_text) {
	$lnno++;
	if ($ln =~ /^\s*Solver level:\s*([0-9]+)/) {
	    $solver_level = $1;
	} elsif ($ln =~ /\s*Raw rating:\s*([\-0-9\.]+)/) {
	    $raw_rating = $1;
	} elsif ($ln =~ /^Stars:\s*([0-9\.]+)/) {
	    $stars_rating = $1;
	}
	# Don't scan the part after the second solution looking for solutions.
	if ($solution_count < 2) {
	    if ($ln =~ /No solution\!/) {
		dbprint "Found 'No solution' line -- board is no good\n";
		$bad = 1;
		last;
	    } elsif ($quick_check && !$solution_count && $ln =~ /Botch/) {
		dbprint "Found 'Botch' line -- board is no good\n";
		$bad = 1;
		last;
	    } elsif ($quick_check && !$solution_count && $ln =~ /Jammed/) {
		dbprint "Found 'Jammed' line -- board is probably no good\n";
		$bad = 1;
		# Keep going in case the guess solver found a solution someplace
	    } elsif ($ln =~ /^Solution:/) {
		$bad = 0;
		$solution_count++;
		dbprint "Located first solution at line $lnno\n";
		my @soln_board;
		my $lines_found = 0;
		for (my $j = $lnno; 1; $j++) { # The board may have blank lines embedded in it
		    my $board_line = $split_text[$j];
		    if ($board_line =~ /^\s*$/) { next; }
		    push @soln_board, $board_line;
		    $lines_found++;
		    if ($lines_found >= $row_length) {last;}
		}
##	    foreach my $j ($lnno..$lnno+$row_length) {
##		push @soln_board, $split_text[$j];
##	    }

		@solution_1 = read_board_list (@soln_board);
		if ($debug) {
		    print "First soln split out:\n***\n";
		    print_board ("", @solution_1);
		    print "***\n";
		}
	    } elsif ($ln =~ /SECOND.*solution:/) {
		$solution_count++;
		dbprint "Located second solution at line $lnno\n";
		my @soln_board;
		my $lines_found = 0;
		for (my $j = $lnno; 1; $j++) { # The board may have blank lines embedded in it
		    my $board_line = $split_text[$j];
		    if ($board_line =~ /^\s*$/) { next; }
		    push @soln_board, $board_line;
		    $lines_found++;
		    if ($lines_found >= $row_length) {last;}
		}
##	    foreach my $j ($lnno..$lnno+$row_length) {
##		push @soln_board, $split_text[$j];
##	    }
		@solution_2 = read_board_list (@soln_board);
		if ($debug) {
		    print "Second soln split out:\n***\n";
		    print_board ("", @solution_2);
		    print "***\n";
		}
	    }
	}
    }
    dbprint "read_solutions:  Found $solution_count solutions\n";

    # If we're running a quick check we probably won't find a solution.
    # In that case we just want to know there were no contradictions detected.
    #
    if (! $solution_count && $quick_check && ! $bad) {
	dbprint "  ... But it was just a quick check so we're claiming 2 solutions\n";
	return 2;
    }

    return $solution_count;
}

# ****************************************************************
# Run the solver to get the possibility list.

sub get_possibilities () {
    write_scratch_board();
    my $poss_text = `solve_sudoku $scratch_fname -silent -possibilities`;
    my @poss_list;
    my $ev_str = "\@poss_list = $poss_text";
    ##if ($debug) { print "ev_str:\n"; print $ev_str; print "\n"; }
    eval $ev_str;
    if ($debug) {
	printf "Size of poss_list: %d\n", scalar(@poss_list);
    }

    if ($debug) {
	##print "get_possibilities: Raw possibility text:\n";
	##print $poss_text;
	##print "\n";
	print "get_possibilities:  Possibility list:\n";
	foreach my $poss (@poss_list) {
	    print "  ";
	    foreach my $v (@$poss) {
		print "$v ";
	    }
	    print "\n";
	}
    }

    return (@poss_list);
}

# ****************************************************************
# Diff the two solutions

sub diff_solutions () {
    my $diff_count = 0;
    for my $i (0..$board_size-1) {
	if ($solution_1[$i] == $solution_2[$i]) {
	    $diffs_1[$i] = 0;
	    $diffs_2[$i] = 0;
	} else {
	    $diffs_1[$i] = $solution_1[$i];
	    $diffs_2[$i] = $solution_2[$i];
	    $diff_count++;
	}
    }
    if ($debug) {
	print_board ("First diff board", @diffs_1);
	print_board ("Second diff board", @diffs_2);
	print "Found $diff_count differences\n";
    }
    my $pick = int(rand() * $diff_count); # Pick the change to use
    my $odd_even = int(rand() * 2);
    dbprint "diff_solutions: pick=$pick, odd_even=$odd_even\n";
    my $at_diff = 0;
    for my $i (0..$board_size-1) { # Find the appropriate difference
	if (! $diffs_1[$i]) {
	    $diff_to_apply[$i] = 0;
	} else {
	    my $val = 0;
	    if ($at_diff == $pick) {
		if ($odd_even) {
		    $val = $diffs_2[$i];
		} else {
		    $val = $diffs_1[$i];
		}
		dbprint "Applying diff $at_diff, val $val\n";
	    }
	    $diff_to_apply[$i] = $val;
	    $at_diff++;		# And count this up for the diff we're looking at
	}
    }
    if ($debug) {
	print_board ("Applicable diff", @diff_to_apply);
    }
}

# ****************************************************************
# Apply the diffs to the board

sub apply_diffs () {
    foreach my $i (0..$board_size-1) {
	my $val = $diff_to_apply[$i];
	if ($val) {
	    dbprint "apply_diffs:  Applying $val at square $i\n";
	    $board[$i] = $val;
	}
    }
}

# ****************************************************************
# Build a spiral sequence for the whole board

sub make_spiral () {
    my $row_first = 0;
    my $row_last = $row_length-1;
    my $col_first = 0;
    my $col_last = $row_length-1;

    my @seq;

    while ($row_last > $row_first) {
	foreach my $c ($col_first .. $col_last) {
	    push @seq, row_col_to_entry ($row_first, $c);
	}
	foreach my $r (($row_first+1) .. $row_last) {
	    push @seq, row_col_to_entry ($r, $col_last);
	}
	foreach my $c (reverse($col_first .. ($col_last-1))) {
	    push @seq, row_col_to_entry ($row_last, $c);
	}
	foreach my $r (reverse(($row_first+1) .. $row_last-1)) {
	    push @seq, row_col_to_entry ($r, $col_first);
	}
	$row_first++;
	$row_last--;
	$col_first++;
	$col_last--;
    }
    if ($row_last == $row_first) { # Did we end up with a cell in the middle?
	push @seq, row_col_to_entry ($row_first,$col_first);
    }
    return (@seq);
}

# ****************************************************************
# Fill by "partial" squares.  We fill the upper left of each square
# first.  This results in leaving 3 rows and 3 columns for last.

sub make_partial_square_sequence () {
    my @seq;

    foreach my $pass (0..2) {

	foreach my $s_row (0..2) {
	    foreach my $s_col (0..2) {
		my $s_number = ($s_row * 3) + $s_col;
		my $row_base = $s_row * 3;
		my $col_base = $s_col * 3;

		if (!$pass) {	# First time through?  Do lower right of each square
		    foreach my $r_in_square (1..2) {
			foreach my $c_in_square (1..2) {
			    my $r = $r_in_square + $row_base;
			    my $c = $c_in_square + $col_base;
			    my $entry = row_col_to_entry ($r, $c);
			    push @seq, $entry;
			}
		    }
		} elsif ($pass == 1) { # Second pass, do top two cells of each square
		    foreach my $r_in_square (0..0) {
			foreach my $c_in_square (1..2) {
			    my $r = $r_in_square + $row_base;
			    my $c = $c_in_square + $col_base;
			    my $entry = row_col_to_entry ($r, $c);
			    push @seq, $entry;
			}
		    }
		} else {	# Third pass, do left 3 cells of each square
		    foreach my $r_in_square (0..2) {
			foreach my $c_in_square (0..0) {
			    my $r = $r_in_square + $row_base;
			    my $c = $c_in_square + $col_base;
			    my $entry = row_col_to_entry ($r, $c);
			    push @seq, $entry;
			}
		    }
		}
	    }
	}
    }
    return (@seq);
}

# ****************************************************************
# Fill by whole squares.

sub make_whole_square_sequence () {
    my @seq;

    my @s_row_seq = (0,0,1,1,2,2,0,1,2);
    my @s_col_seq = (1,2,0,2,0,1,0,1,2);

    foreach my $i (0..8) {
	my $s_row = $s_row_seq[$i];
	my $s_col = $s_col_seq[$i];

	my $s_number = ($s_row * 3) + $s_col;
	my $row_base = $s_row * 3;
	my $col_base = $s_col * 3;

	foreach my $r_in_square (0..2) {
	    foreach my $c_in_square (0..2) {
		my $r = $r_in_square + $row_base;
		my $c = $c_in_square + $col_base;
		my $entry = row_col_to_entry ($r, $c);
		push @seq, $entry;
	    }
	}
    }
    return (@seq);
}

# ****************************************************************
# Try to remove as many squares as possible from the board

my @seq_used_to_fill;

sub optimize () {
    my $et = time() - $start_time;
    print "optimize:  Entered at time $et\n";
    my @removals = (0 .. $board_size-1);
    ##my @removals = (make_spiral());
    my $opt_count = 0;
    if ($remove_random) {
	@removals = shuffle_list (@removals);
    } elsif ($remove_like_add) {
	@removals = @seq_used_to_fill;
    } elsif ($remove_reverse_add) {
	@removals = (reverse @seq_used_to_fill);
    } elsif ($remove_from_board_top) {
	# It's already sequenced from-the-top
    } elsif ($remove_from_board_bottom) {
	@removals = reverse @removals;
    } elsif ($remove_high) {			# Remove high => try to zap high values preferentially
	@removals = sort { (($board[$b] != $board[$a]) ?
			    ($board[$b] <=> $board[$a]) :
			    ($b <=> $a)) } @removals;
    } else {
	die "No optimization style was set";
    }
    my $count_to_test = 0;
    foreach my $i (0..$board_size-1) { if ($board[$i]) {$count_to_test++;} }
    print "optimize:  Checking $count_to_test entries...\n";
    if ($opt_to_level) {
	print " ... Optimizing up to solver level $opt_to_level but no higher.\n";
    }
    my $enum = 0;
    foreach my $entry (@removals) {
	if ($board[$entry]) {
	    $enum++;
	    my $val = $board[$entry]; # Zap this out
	    print "Test-removing entry [$enum] $entry = $val...\n";
	    $board[$entry] = 0;
	    my $scount = read_solutions();
	    if ($scount < 2 && (!$opt_to_level || $solver_level <= $opt_to_level)) {
		my $say_level = !$solver_level ? "" : "(board at level $solver_level) ";
		print "  Entry $entry was not necessary ${say_level}-- zapping\n";
		$opt_count++;
	    } else {
		if ($scount < 2) {
		    print "  *** Eliminating entry put level up to $solver_level ***\n";
		    my $et = time() - $start_time;
		    print "    ... at time $et\n";
		}
		$board[$entry] = $val; # Put it back -- we need it.
	    }
	}
    }
    my $ft = time() - $start_time;
    print "optimize:  Done at time $ft\n";
    return $opt_count;
}

# ****************************************************************
# Turn a row,col pair into an entry number

sub row_col_to_entry ($$) {
    my ($r,$c) = @_;
    return $c + ($r * $row_length);
}

# ****************************************************************
# Fill from one corner to the other, on diagonal paths

sub make_corner_to_corner_sequence () {
    my @seq;
    # Fill in upper left triangle
    foreach my $start_row (0..8) {
	my $c = 0;
	foreach my $r (reverse (0..$start_row)) {
	    push @seq, row_col_to_entry ($r,$c);
	    $c++;
	}
    }
    # Now fill in the rest
    foreach my $start_col (1..8) {
	my $r = 8;
	foreach my $c ($start_col..8) {
	    push @seq, row_col_to_entry ($r,$c);
	    $r--;
	}
    }
    return (@seq);
}

# ****************************************************************
# Read a pattern board, and make a fill sequence from it

sub make_pattern_sequence () {
    my @pattern;
    foreach my $i (0 .. $board_size-1) {
	$pattern[$i] = 0;
    }
    open FL, "<$fill_pattern_file" or die "Can't open pattern file $fill_pattern_file";
    my @pattern_list;
    while (<FL>) {
	push @pattern_list, $_;
    }
    close FL or die "Error closing pattern file $fill_pattern_file";

    @pattern = read_board_list (@pattern_list);

    print "Fill pattern:\n\n";
    print_board ("", @pattern);
    print "\n";

    my @fill_first;
    my @fill_later;
    foreach my $i (0 .. $board_size-1) {
	if ($pattern[$i]) {
	    push @fill_first, $i;
	} else {
	    push @fill_later, $i;
	}
    }
    $pattern_length = scalar(@fill_first);

    # Now let's shuffle the fill-first and fill-later sequences
    @fill_first = shuffle_list (@fill_first);
    @fill_later = shuffle_list (@fill_later);

    my @fill_sequence;
    push @fill_sequence, @fill_first;
    push @fill_sequence, @fill_later;
    return (@fill_sequence);
}

# ****************************************************************
# Obtain the fill sequence.

##my $fill_how = "plain";
my $fill_how = "random";
##my $fill_how = "spiral";
##my $fill_how = "reverse_spiral";
##my $fill_how = "partial_squares";
##my $fill_how = "whole_squares";
##my $fill_how = "corner_to_corner";

sub get_fill_sequence_worker () {
    if ($fill_how eq "plain") {
	return (0..$board_size-1);
    } elsif ($fill_how eq "random") {
	return shuffled_set_N ($board_size);
    } elsif ($fill_how eq "spiral") {
	return (make_spiral());
    } elsif ($fill_how eq "reverse_spiral") {
	return (reverse make_spiral());
    } elsif ($fill_how eq "partial_squares") {
	return (make_partial_square_sequence());
    } elsif ($fill_how eq "whole_squares") {
	return (make_whole_square_sequence());
    } elsif ($fill_how eq "corner_to_corner") {
	return (make_corner_to_corner_sequence());
    } elsif ($fill_how eq "pattern") {
	return (make_pattern_sequence());
    } else {
	print "-fill_how options:  plain random spiral reverse_spiral partial_squares whole_squares corner_to_corner pattern\n";
	die "Fill sequence $fill_how is not known\n";
    }
}

sub get_fill_sequence () {
    @seq_used_to_fill = (get_fill_sequence_worker());
    return (@seq_used_to_fill);
}

# ****************************************************************
# Check for a build timeout or too many backtrack steps

sub check_build_timeout ($) {
    my ($entry_time) = @_;
    if ($pattern_max_retries) { # If a max value is specified only go that far.
	$pattern_max_retries--;
	if (!$pattern_max_retries) {
	    print "check_build_timeout:  Ran out of retries!\n";
	    return 1;
	}
    }
    my $now = (time() - $start_time) - $entry_time;
    if ($now > $max_build_time) {
	print "check_build_timeout:  Ran out of time!\n";
	return 1;
    }
    return 0;
}

# ****************************************************************
# Build a board at random, constraining it by the possibilities.

sub build_random_board () {
    my $entry_time = time() - $start_time;
    print "build_random_board: Entered at time $entry_time\n";
    my $filled_in = 0;
    foreach my $c (@board) { if ($c) { $filled_in++; }} # Count the filled squares before we start

    my $done = 0;
    my @entries = get_fill_sequence();
    
    my $i = read_solutions(1);
    if ($i < 2) {
	print "build_random_board:  Starting board has $i solution -- doing nothing.\n";
	return 1;
    }
    my $mentioned_read_solutions_time = 0;
    my $won = 1;
    my $entries_checked = 0;	# We'll need this if we're forcing the pattern
    my $timed_out = 0;

    # Now here's all the stuff we need to backtrack if we run off the end of a pattern
    my $backtracked = 0;	# Set to 1 if we're backtracking, because then we reuse the old list
    my @saved_start_indices = ();
    my @saved_boards = ();
    my @saved_poss_lists = ();
    my @saved_val_lists = ();
    my @saved_filled_in = ();

    my $first_time = 1;
    while ($first_time || $backtracked) {
	$first_time = 0;

	my @poss_list;
	my @val_list;
	my $start_index = 0;

	if ($backtracked) {
	    $start_index = pop @saved_start_indices;
	    print " .. Backtracked to index $start_index\n";

	    my $sb = pop @saved_boards;
	    @board = @$sb;
	    my $pl = pop @saved_poss_lists;
	    @poss_list = @$pl;
	    my $vl = pop @saved_val_lists;
	    @val_list = @$vl;
	    $filled_in = pop @saved_filled_in;
	    # Leave backtracked set; it's used in the loop to decide whether to set things up for this pass.
	}

	foreach my $i ($start_index .. $#entries) {
	    my $entry = $entries[$i];
	    $entries_checked = $i+1;

	    if (($force_pattern || $build_in_pattern) && $entries_checked > $pattern_length) { # Did we run out of pattern values?
		if (scalar(@saved_start_indices) > 0) { # Have we got some backtrack info?
		    $backtracked = 1;
		    $timed_out = check_build_timeout($entry_time);
		    if ($timed_out) {
			$backtracked = 0;
			$build_in_pattern = 0;
			$pattern_max_retries = 0;
			print "Gave up, just filling in as needed -- build_in_pattern LEAKED\n";
		    }
		    if ($backtracked) {
			print "Ran off the end building in a pattern -- BACKTRACKING\n";
			last;
		    }
		} elsif ($build_in_pattern) { # Uh, oh -- noplace to backtrack to!
		    die "Ran out of backtrack info without finding a valid board";
		} else {
		    last;
		}
	    }

	    if ($board[$entry]) { next; }
	    print " .. Working on entry ${entry}";
	    if ($debug) {
		print "\n"; # For debug output we want a newline here.
	    } else {
		print ": ";
	    }

	    if ($debug) { print_board "Board before entry changed:", @board; }

	    if ($backtracked) {
		$backtracked = 0; # Use this record once
	    } else {
		$filled_in++;
		@poss_list = get_possibilities();

		my $vl = $poss_list[$entry];
		if (! defined($vl)) {
		    print "Whoops!  Possibility list botch!\n";
		    print_board "Botched board:", @board;
		}

		@val_list = shuffle_list (@$vl);

		if ($sparse && scalar(@val_list) == 1) {
		    print " Just one possibility -- skipped\n";
		    next;
		}
	    }

	    my $found_ok_val = 0;
	    while (scalar(@val_list) > 0) { # Loop over all possibilities until we find a good one
		my $val = shift @val_list;
		if ($debug) {
		    dbprint " .. Set it to value $val\n";
		} else {
		    print " $val";
		}

		# If we have additional values, set up a backtrack record
		my (@bd, @pl, @vl);
		if ($build_in_pattern && scalar(@val_list) > 0) {
		    @bd = @board;
		    @pl = @poss_list;
		    @vl = @val_list;
		    # Don't save the record yet; the current entry may be NG.
		}

		$board[$entry] = $val;
		##my $how_many_freebies = 18;
		##my $how_many_freebies = 9;
		##my $how_many_freebies = 20;
		##my $how_many_freebies = 16;
		my $how_many_freebies = 1;
		if ($filled_in < $how_many_freebies) {
		    dbprint "Less than $how_many_freebies entries; ASSUMING this is OK\n";
		    $found_ok_val = 1;
		    last;
		}
		if (! $mentioned_read_solutions_time) {
		    $mentioned_read_solutions_time = 1;
		    my $et = time() - $start_time;
		    print "\nbuild_random_board: First call to read_solutions at time $et\n";
		}
		my $sol_count = read_solutions(1);
		dbprint "Sol count: $sol_count\n";

		if ($sol_count < 1) {
		    dbprint " .. This value doesn't work -- no solution.\n";
		} else {
		    dbprint " .. This value is OK\n";
		    $found_ok_val = 1;
		    # Now that we know this entry is OK, so save the backtrack record for it
		    if ($build_in_pattern && scalar(@val_list) > 0) {
			push @saved_start_indices, $i;
			push @saved_boards, \@bd;
			push @saved_poss_lists, \@pl;
			push @saved_val_lists, \@vl;
			push @saved_filled_in, $filled_in;
		    }
		    
		    if ($sol_count == 1 && (!$build_in_pattern || $entries_checked >= $pattern_length)) {
			dbprint "This value is OK *and* the board has a unique solution\n";
			if ($build_to_level && !$timed_out) { # Do we need to check the level?
			    read_solutions(0);  # Do a full read_solutions to get the board level
			    if ($solver_level < $min_level) {
				$timed_out = check_build_timeout($entry_time);
				if (!$timed_out) {
				    print "\nRejecting board -- too low level: $solver_level\n";
				    next;
				}
			    }
			}
			$done = 1;
		    }
		    last;	# This value is OK, so break out of the possibility loop
		}
	    }
	    if (!$debug) { print "\n"; } # End the line of values we printed
	    if (! $found_ok_val) {
		print "Inconsistency building the board -- retrying.\n";
		if (scalar(@saved_filled_in) > 0) { # If we can, just backtrack
		    $backtracked = 1;
		    last;
		}
		##print "Whoops!  No legal value found for entry $entry!\n";
		##print "Possibilities: ";
		##foreach my $v (@$val_list) { print "$v "; }
		##print "\n";
		##print_board "Board at this point:", @board;
		##exit;
		$won = 0;
		$done = 1;
	    }
	    if ($done) {
		last;
	    }
	}
    }
    if ($force_pattern && $entries_checked > $pattern_length) { # Did we run out of pattern values?
	print "Ran off the end of the pattern -- retrying.\n";
	$won = 0;
    }

    my $et = time() - $start_time;
    print "build_random_board: Done: time = $et\n";
    return $won;
}

# ****************************************************************
# Shuffle the board

sub shuffle_board () {
    my @trans_array = shuffled_set_N (9);
    print "Shuffled array: ";
    foreach my $s (@trans_array) { print "$s "; }
    print "\n";
    foreach my $i (0..$board_size-1) {
	if ($board[$i]) {
	    $board[$i] = 1 + $trans_array[$board[$i] - 1];
	}
    }
}

# ****************************************************************
# Scramble the board by shuffling rows and columns within each 3x3 block
# and then shuffling blocks of 3 rows and colums

sub scramble_board () {
    my @shuffle_array;

    foreach my $row_block (0..2) {
	@shuffle_array = shuffled_set_N (3);
	foreach my $from (0..2) {
	    my $to = $shuffle_array[$from];
	    my $block_base = $row_block * 3; # three rows per block
	    my $row_from = $from + $block_base;
	    my $row_to = $to + $block_base;
	    foreach my $col (0..8) {
		my $from_entry = row_col_to_entry ($row_from, $col);
		my $to_entry = row_col_to_entry ($row_to, $col);
		my $swap = $board[$to_entry];
		$board[$to_entry] = $board[$from_entry];
		$board[$from_entry] = $swap;
	    }
	}
    }

    foreach my $col_block (0..2) {
	@shuffle_array = shuffled_set_N (3);
	foreach my $from (0..2) {
	    my $to = $shuffle_array[$from];
	    my $block_base = $col_block * 3; # three rows per block
	    my $col_from = $from + $block_base;
	    my $col_to = $to + $block_base;
	    foreach my $row (0..8) {
		my $from_entry = row_col_to_entry ($row, $col_from);
		my $to_entry = row_col_to_entry ($row, $col_to);
		my $swap = $board[$to_entry];
		$board[$to_entry] = $board[$from_entry];
		$board[$from_entry] = $swap;
	    }
	}
    }

    foreach my $row_triple (0..2) {
	@shuffle_array = shuffled_set_N (3);
	foreach my $from_triple (0..2) {
	    my $to_triple = $shuffle_array[$from_triple];
	    my $from_base = $from_triple * 3;
	    my $to_base = $to_triple * 3;
	    foreach my $row_index (0..2) {
		my $from_row = $from_base + $row_index;
		my $to_row = $to_base + $row_index;
		foreach my $col (0..8) {
		    my $from_entry = row_col_to_entry ($from_row, $col);
		    my $to_entry = row_col_to_entry ($to_row, $col);
		    my $swap = $board[$to_entry];
		    $board[$to_entry] = $board[$from_entry];
		    $board[$from_entry] = $swap;
		}
	    }
	}
    }

    foreach my $col_triple (0..2) {
	@shuffle_array = shuffled_set_N (3);
	foreach my $from_triple (0..2) {
	    my $to_triple = $shuffle_array[$from_triple];
	    my $from_base = $from_triple * 3;
	    my $to_base = $to_triple * 3;
	    foreach my $col_index (0..2) {
		my $from_col = $from_base + $col_index;
		my $to_col = $to_base + $col_index;
		foreach my $row (0..8) {
		    my $from_entry = row_col_to_entry ($row, $from_col);
		    my $to_entry = row_col_to_entry ($row, $to_col);
		    my $swap = $board[$to_entry];
		    $board[$to_entry] = $board[$from_entry];
		    $board[$from_entry] = $swap;
		}
	    }
	}
    }
}

# ****************************************************************
# Process arguments

while ($_ = shift) {
    my $arg = $_;
    if ($arg =~ /^-debug/) {
	$debug = 1;
    } elsif ($arg eq "-opt_to") { # Optimize to this level, but no higher
	$do_opt = 1;
	$opt_to_level = shift;
    } elsif ($arg eq "-no_opt") {
	$do_opt = 0;
    } elsif ($arg eq "-opt") {
	$do_opt = 1;
    } elsif ($arg eq "-min_level") {
	$min_level = shift;
    } elsif ($arg =~ /^-no_sort/) {
	$do_sort = 0;
	$sort_arg = "-no_sort";
    } elsif ($arg =~ /^-do_sort/) {
	$do_sort = 1;
	$sort_arg = "-do_sort";
    } elsif ($arg =~ /^-just_scramble/) {
	$do_build_board = 0;
	$do_opt = 0;
	$do_shuffle = 0;
	$do_scramble = 1;
    } elsif ($arg =~ /^-just_shuffle/) {
	$do_build_board = 0;
	$do_opt = 0;
	$do_shuffle = 1;
	$do_scramble = 1;
    } elsif ($arg =~ /^-shuffle/) {
	$do_shuffle = 1;
	$do_scramble = 1;
    } elsif ($arg eq "-no_for_build") {
	$build_arg = "";
    } elsif ($arg eq "-no_natural") {
	$natural_arg = "-no_natural";
    } elsif ($arg eq "-rand_build") {
	$do_rand_build = 1;
    } elsif ($arg eq "-no_rand_build") {
	$do_rand_build = 0;
    } elsif ($arg eq "-no_hybrid") {
	$hybrid_arg = "-no_hybrid";
    } elsif ($arg eq "-opt_style") {
	$do_opt = 1;
	$remove_random = 0;	# This was the default; shut it off
	my $os = shift;
	if ($os eq "like_add") {
	    $remove_like_add = 1;
	} elsif ($os eq "reverse_add") {
	    $remove_reverse_add = 1;
	} elsif ($os eq "from_top") {
	    $remove_from_board_top = 1;
	} elsif ($os eq "from_bottom") {
	    $remove_from_board_bottom = 1;
	} elsif ($os eq "remove_high") {
	    $remove_high = 1;
	} elsif ($os eq "random") {
	    $remove_random = 1;
	} else {
	    print "-opt_style options:  like_add reverse_add from_top from_bottom remove_high random\n";
	    print "-fill_how options:  plain random spiral reverse_spiral partial_squares whole_squares corner_to_corner pattern\n";
	    exit;
	}
    } elsif ($arg eq "-fill_how") {
	$fill_how = shift;
	if ($fill_how eq "pattern") {
	    $fill_pattern_file = shift;
	}
    } elsif ($arg eq "-force_pattern") {
	$force_pattern = 1;
    } elsif ($arg eq "-build_in_pattern") {
	$build_in_pattern = 1;
    } elsif ($arg eq "-build_to_level") {
	$build_to_level = 1;
    } elsif ($arg eq "-sparse") {
	$sparse = 1;
    } elsif ($arg =~ /^-/) {
	die "Argument $arg not understood\n";
    } else {
	if (defined($seed_fname)) {
	    die "Too many seed files provided!\n";
	}
	$seed_fname = $_;
    }
}

if (!defined $seed_fname) { die "Need a seed file name\n"; }

# ****************************************************************
# Drive the program

read_seed_file();

my $built = 0;

if ($do_rand_build) {
    $built = 1;
    my @starting_board = @board;
    my $done = 0;
    while (! $done) {
	get_possibilities();
	$done = build_random_board();
	if (!$done) { @board = @starting_board; } # Restore the board before restarting the build
    }
    print_board ("Constructed board:", @board);
} elsif ($do_build_board) {
    $built = 1;
    my $try = 0;
    while (1) {
	$try++;
	print "Try $try...\n";
	if (read_solutions() <= 1) { last ; }
	diff_solutions();
	apply_diffs();
    }
    print_board ("Final board:", @board);
}

if ($built) {
    write_scratch_board (".plain");
    print "Constructed board is in ${scratch_fname}.plain\n";
    read_solutions();		# Make sure this got done.
}

if ($do_opt) {
    my $opt_time_start = time();
    while (1) {
	my @pre_opt_board = @board;
	my $oc = optimize();
	if ($oc == 0) {
	    print "Nothing can be removed.\n";
	} else {
	    print "Optimized out $oc squares.\n";
	    read_solutions();
	    if ($solver_level < $min_level) {
		print " .. Result at level $solver_level, trying for level $min_level -- retrying optimization with random removal\n";
		@board = @pre_opt_board;
		$remove_random = 1;
		if ($level_max_retries) { # If we're only supposed to do this some fixed number of times, count it down
		    $level_max_retries--; # Exceeded the max => clear the max level
		    if (!$level_max_retries) {
			$min_level = 0;
		    }
		}
		my $opt_time = time() - $opt_time_start;
		if ($opt_time > $max_optimize_time) {
		    print "Ran out of time to optimize the board.\n";
		    $min_level = 0; # Zap this out after we've run too long.
		} else {
		    my $remaining = $max_optimize_time - $opt_time;
		    print "Still have $remaining seconds left to optimize the board\n";
		}
		next;
	    }
	    print_board ("Optimized board:", @board);
	    write_scratch_board(".opt");
	    print "Optimized board is in ${scratch_fname}.opt\n";
	}
	last;
    }
}

print "Solver level:  $solver_level\n" .
    "Raw rating:    $raw_rating\n" .
    "Stars rating:  $stars_rating\n";

if ($do_shuffle) {
    shuffle_board();
    print_board ("Shuffled board:", @board);
    write_scratch_board(".shuffle");
    print "Shuffled board is in ${scratch_fname}.shuffle\n";
}

if ($do_scramble) {
    scramble_board();
    print_board ("Scrambled board:", @board);
    write_scratch_board(".scramble");
    print "Scrambled board is in ${scratch_fname}.scramble\n";
}