NEW CODE: Making Sudoku Puzzles Using PDF::API2

FYI, now that the latest Perl Review has been released I've had a chance to play around with the Sudoku generator. I added some spice to allow one to create multiple Sudoku puzzles in a PDF document. Attached are a few scripts:

A slightly modified sudoku_generator.pl file
A modestly modified sudoku_maker.pl file, renamed to sudoku2pdf.pl for de-obfuscation purposes
A sample shell script, create_sudoku_puzzles.sc that accepts two command line arguments: number of puzzles to create and PDF filename; it will then loop through and create x number of puzzles in the given PDF file

Here they are:

sudoku_generator.pl

#!/usr/bin/perl

############################################################
##   INIT                                                 ##
############################################################

use strict;
use warnings;
use List::Util qw{ shuffle };

# constants
our $COLCNT    = 4 * 9**2;    # number of columns in cover
our $ROWCNT    = 9**3;        # number of rows in cover

# bitvecs for full and empty rows and cols
our $ZEROCOL   = pack( 'b*', "0" x $COLCNT );
our $ZEROROW   = pack( 'b*', "0" x $ROWCNT );
our $FULLCOL   = pack( 'b*', "1" x $COLCNT );
our $FULLROW   = pack( 'b*', "1" x $ROWCNT );


############################################################
##   MAIN                                                 ##
############################################################

# use STDERR because STDOUT is used to pass the puzzle text
#  to sudoku2pdf.pl
print STDERR "Generating Sudoku puzzle...\n";  

# create the cover puzzle, and an initial path stash
my $puzzle = make_puzzle();
my $pstash = make_path_stash( $puzzle );

# find a completed Sudoku puzzle
my @solutions = solve_cover( $puzzle, $pstash, 1 );
my $solset    = pop @solutions;

#print "\nComplete puzzle:\n";
#pprint_puzzle( @$solset );

# find -a- minimal puzzle with that set
my @sol = find_minimal( @$solset );

#print "\nMinimal puzzle:\n";
pprint_puzzle( @sol );

# for fun, re-solve the puzzle
#print "\nRe-solved:\n";

#my $nstash    = make_path_stash( $puzzle, @sol );
#my @re_solved = solve_cover( $puzzle, $nstash, 1 );

#pprint_puzzle( @{ $re_solved[0] } );


############################################################
##   FUNCTIONS                                            ##
############################################################


############################################################
# solve_cover() - given an initial path stash, solve puzzle

sub solve_cover
{
  my ( $puzref, $iloc, $tofind ) = @_;
  $tofind      ||= 1;

  # initialize as much as possible here,
  # to avoid allocing during tightloop
  my @stack      = ( $iloc );   # 'recurse' agenda
  my @liverows   = ();          # don't allocated any arrays in
  my @pivrows    = ();          # loop - expensive.
  my @solutions  = ();          # solutions found
  my $curpaths   = 0;           # counter for paths (stats only)
  my @puz        = @$puzref;

  RECURSE:
  while ( 1 )
  {
     # basecase 1:
     my $rloc = pop @stack or last RECURSE;

     if ( $rloc->{livecol} eq $ZEROCOL )
     {
        my @setlist = grep { vec $rloc->{solset}, $_, 1 } 0.. ( $ROWCN
+T - 1 );
        push @solutions, \@setlist;

        # basecase 2 - we satisfy our solution agenda
        last RECURSE if ( scalar( @solutions ) >= $tofind );
        next RECURSE;
     }

     # enumerate active rows
     my $cand = ( ~ $rloc->{removed} );
     @liverows = ();
     vec( $cand, $_, 1 ) && push( @liverows, $_ )
        for 0 .. ( $ROWCNT - 1 );

     # basecase 3:
     my $colcheck = $ZEROCOL;
     $colcheck |= $puz[$_] for @liverows;
     next RECURSE unless $colcheck eq $rloc->{livecol};

     # select a pivot column
     my $pivcol; my $pivmask;

     COLPICK:
     for my $col ( 0 .. $COLCNT - 1 )
     {
        next COLPICK unless vec( $rloc->{livecol}, $col, 1 );

        $pivcol = $col;
        $pivmask = $ZEROCOL;
        vec( $pivmask, $pivcol, 1 ) = 1;

        my $cnt = 0;
        (( $pivmask & $puz[$_] ) ne $ZEROCOL ) and $cnt++
           for @liverows;

        # shortcurcuit select if any singletons found
        last COLPICK if $cnt == 1;
     }

     # enumerate pivot rows:
     @pivrows = ();
     for ( @liverows )
     {
        push @pivrows, $_
           if (( $pivmask & $puz[$_] ) ne $ZEROCOL );
     }

     # DESCEND - each pivot row is a path to descend into
     for my $prow ( shuffle @pivrows )
     {
        my %crloc = %$rloc;

        # prune out covered rows
        for my $r ( @liverows )
        {
           vec( $crloc{removed}, $r, 1 ) = 1
              if ( $puz[$r] & $puz[$prow] ) ne $ZEROCOL;
        }

        # mask out consumed columns
        $crloc{livecol} &= ~ $puz[$prow];

        # add row to solutionset
        vec( $crloc{solset}, $prow, 1 ) = 1;

        $curpaths++;
        push @stack, \%crloc;
     }

  }
  return @solutions;
}

############################################################

sub find_minimal
{
  my ( @solset ) = @_;

  # This is cheap and dirty, but at least it's cheap and dirty.
  my @sol;
  do
  {
     @sol = shuffle @solset;
     pop @sol for 0..30;
  }
  until ( is_unambiguous( @sol ) );

  TRIM:
  while ( 1 )
  {
     for ( 0..$#sol )
     {
        my $front = shift @sol;
        next TRIM if is_unambiguous( @sol );
        push @sol, $front;
     }
     last TRIM;  # none can be removed
  }

  return @sol;
}

############################################################

sub is_unambiguous
{
  my @set        = @_;
  my $puzzle     = make_puzzle();
  my $pstash     = make_path_stash( $puzzle, @set );

  my @solutions  = solve_cover( $puzzle, $pstash, 2 );

  return ( scalar( @solutions ) == 1 );
}

############################################################

sub make_path_stash
{
  my( $puz, @set ) = @_;
  my $mask    = $ZEROCOL;
  my $solset  = $ZEROROW;
  my $remset  = $ZEROROW;

  if ( @set )
  {
     $mask |= $puz->[$_] for @set;

     for my $row ( 0.. ( $ROWCNT - 1 ) )
     {
        vec( $remset, $row, 1 ) = 1
           if ( ( $puz->[$row] & $mask ) ne $ZEROCOL );
     }

     vec( $solset, $_, 1 ) = 1 for @set;
  }

  return {
           livecol  => ( ~ $mask ) & $FULLCOL,
           removed  => $remset,
           solset   => $solset,
           colptr   => 0,
         };
}

############################################################
# return puzzle array

sub make_puzzle
{
  my @puz;
  for my $sqr ( 0..80 )
  {
     for my $val ( 1..9 )
     {
        push @puz, map_to_covervec( $val, $sqr );
     }
  }

  return \@puz;
}

############################################################
# given a square and a value, return bitvec

sub map_to_covervec
{
  my ( $num, $sqr ) = @_;
  my $bitmap = $ZEROCOL;        # blank row
  my $seg = 9**2;               # constraint segment offset

  my $row = int( $sqr / 9 );    # row
  my $col = $sqr % 9;           # col
  my $blk = int( $col / 3 ) +   # block
            int( $row / 3 ) * 3;

  # map to contraint offsets
  my @offsets = (
     $sqr,
     $seg + $row * 9 + $num - 1,
     $seg * 2 + $col * 9 + $num - 1,
     $seg * 3 + $blk * 9 + $num - 1,
     );

  # poke out offsets
  vec( $bitmap, $_, 1 ) = 1 for @offsets;

  return $bitmap;
}

############################################################
# pretty print puzzle

sub pprint_puzzle
{
  my @set = @_;

  # map values on to squares:
  my @puzzle;
  $puzzle[int($_ / 9)] = 1 + $_ % 9 for @set;

  for ( 1..81 )
  {
     print( ( $puzzle[$_-1] ) ? "$puzzle[$_-1] " : "- " );
     print "  " unless $_ % 3;
     print "\n" unless $_ % 9;
     print "\n" unless $_ % (9*3);
  }
}


__END__
Complete puzzle:
8 2 3   5 6 4   9 1 7
1 5 9   8 2 7   6 4 3
6 4 7   3 9 1   8 5 2

7 6 1   2 8 5   4 3 9
3 8 5   4 7 9   1 2 6
4 9 2   6 1 3   7 8 5

2 1 8   7 5 6   3 9 4
9 3 6   1 4 2   5 7 8
5 7 4   9 3 8   2 6 1


Minimal puzzle:
8 - 3   - - 4   - - 7
1 5 -   - 2 7   - 4 -
- 4 -   3 - -   - - 2

- - -   - 8 -   4 - -
3 - 5   - - -   - - 6
- - -   - 1 -   - - -

- - -   7 - 6   - - -
- - 6   - - 2   5 - -
- - -   - - -   2 - -


Re-solved:
8 2 3   5 6 4   9 1 7
1 5 9   8 2 7   6 4 3
6 4 7   3 9 1   8 5 2

7 6 1   2 8 5   4 3 9
3 8 5   4 7 9   1 2 6
4 9 2   6 1 3   7 8 5

2 1 8   7 5 6   3 9 4
9 3 6   1 4 2   5 7 8
5 7 4   9 3 8   2 6 1
[download]

sudoku2pdf.pl

#!/usr/bin/perl

=head1 NAME

sudoku2pdf.pl - create Sudoku puzzles with PDF::API2

=head1 SYNOPSIS

    % <sudoku text> | perl sudoku2pdf.pl sudoku.pdf
    - - 6   8 - 4   - - -
    - - -   - 9 -   7 - 8
    - - -   5 - -   - 9 -

    1 - -   - 4 -   - - 9
    - - -   - - -   5 - -
    4 6 -   - - 1   - 3 -

    8 7 -   - - -   4 - -
    - - -   - 5 -   2 - -
    - - -   - - 2   - 1 -

=head1 DESCRIPTION

This is a proof-of-concept script. Eric Maki created a Sudoku puzzle
generator, but he output the text you see in the SYNOPSIS. I wanted
to turn that into a nice puzzle so I started tinkering with PDF::API2.
Eric's source will be part of the Spring 2006 issue of The Perl Review
+.

If you want to change the input, change C<get_puzzle> to parse it
correctly.

UPDATE: Some additions by Michael S. Collins to make the PDF stuff mor
+e usable:
    Added cmd line arg: input/output PDF file name
    Changed program output to write directly to PDF file instead of ST
+DOUT
    Added PDF-specific information:
        'Author'   = 'sudoku2pdf.pl'
        'Keywords' = 'puzzlecount=##' (where ## = number of puzzles in
+ PDF doc)
    (To view this information in Adobe Reader, click File > Document P
+roperties)
    Added quick & dirty validation routine:
        If supplied PDF file does not exist it is created
            ('.pdf' appended if necessary)
        If supplied PDF file does exist, checks for 'Author' to be equ
+al to
            'sudoku2pdf.pl'; dies if not
        This prevents the script from putting sudoku puzzles on 'norma
+l' PDFs!
        Looks for 'puzzlecount=##' in 'Keywords'; if not found, start 
+at 0
    Added logic to put allow six puzzles per page
    After six puzzles, a new page is added and newest puzzle placed
    Repeated calls to sudoku2pdf.pl with the same PDF file will result
+ in
        many puzzles appended

=head1 TO DO

=over 4

=item * most things can be configurable, but I hardcoded them

=item * i'd like to generate several puzzles per page (see MC UPDATE a
+bove)

=item * the C<place_digit> routine is a bit of guess work for font cen
+tering.

=back

=head1 AUTHOR

brian d foy, C<< <bdfoy@cpan.org> >

=head1 COPYRIGHT and LICENSE

Copyright 2006, brian d foy, All rights reserved.

This software is available under the same terms as perl.

=cut

use strict;
use warnings;

use PDF::API2;

use constant PAGE_WIDTH      => 595;
use constant PAGE_HEIGHT     => 842;
use constant MARGIN          =>  25;
use constant GUTTER          =>  32;

use constant WIDE_LINE_WIDTH =>   3;
use constant LINE_WIDTH      =>   2;
use constant THIN_LINE_WIDTH =>   1;

use constant X_COORD         =>   0;
use constant Y_COORD         =>   1;

use constant SQUARE_SIDE     => 243;  # changed from brian's 270

use constant FONT_SIZE       => int( 0.70 * SQUARE_SIDE / 9 );

use constant MAX_PUZZLES     => 6;  # max number puzzles per page

# Now we cheat a bit: there are only 6 possible starting x,y positions
# array of anonymous arrays -
# $xy_pos[1] = [x1,y1], $xy_pos[2] = [x2,y2], etc.
# NOTE: puzzle 6 = $xy_pos[0] = [x0,y0] because we use modulus
# Then when we call make_grid and place_digit we use these as our x,y
# GUTTER = horizontal space between puzzles

my @xy_pos = (

    [ ( PAGE_WIDTH  + GUTTER) / 2,
      PAGE_HEIGHT - SQUARE_SIDE * 3 - GUTTER * 2 - MARGIN ],  # x,y pu
+zzle 6

    [ ( PAGE_WIDTH - (SQUARE_SIDE * 2 + GUTTER) ) / 2,
      PAGE_HEIGHT - SQUARE_SIDE - MARGIN ],                   # x,y pu
+zzle 1
      
    [ ( PAGE_WIDTH  + GUTTER) / 2,
      PAGE_HEIGHT - SQUARE_SIDE - MARGIN ],                   # x,y pu
+zzle 2

    [ ( PAGE_WIDTH - (SQUARE_SIDE * 2 + GUTTER) ) / 2,
      PAGE_HEIGHT - SQUARE_SIDE * 2 - GUTTER - MARGIN ],      # x,y pu
+zzle 3
      
    [ ( PAGE_WIDTH  + GUTTER) / 2,
      PAGE_HEIGHT - SQUARE_SIDE * 2 - GUTTER - MARGIN ],      # x,y pu
+zzle 4
      
    [ ( PAGE_WIDTH - (SQUARE_SIDE * 2 + GUTTER) ) / 2,
      PAGE_HEIGHT - SQUARE_SIDE * 3 - GUTTER * 2 - MARGIN ]   # x,y pu
+zzle 5
      
);

my $pdf;              # pdf object
my $puzzle_count;     # how many puzzles in this PDF
my $page_count;       # how many pages in this PDF
my $puzzlenum;        # which puzzle on this page (1, 2, 3...)

# if have cmd line arg, assume it's a file name + path
# if file exists, assume it's a pdf, open it for appending puzzles
# if file does not exist, create it

my $infile = $ARGV[0];
print "Using $infile as pdf file...\n";

if ( -f $infile ) {
    $pdf = PDF::API2->open( $infile ) or
        die "Unable to open PDF file $infile \n";
    my %pdfinfo = $pdf->info;
    my $keywords = $pdfinfo{'Author'};
    if ( $keywords !~ m/sudoku2pdf\.pl/ ) {
        die "This is not a PDF created by sudoku2pdf.pl \n";
    }
    (undef,$puzzle_count) = split "=",$pdfinfo{'Keywords'};
    if ( ! $puzzle_count ) {
        $puzzle_count = 0;    # no puzzle count, setting it to 0
    }
    $page_count = $pdf->pages;
} else {
   $pdf  = PDF::API2->new;
   $pdf->info( 'Author'   => 'sudoku2pdf.pl' );
   $page_count            = 1;
   $puzzle_count          = 0;
   $pdf->mediabox( PAGE_WIDTH, PAGE_HEIGHT );
   if ( substr( $infile, -4 ) ne '.pdf' ) {
      $infile .= '.pdf';
   }
}

my $font = $pdf->corefont( 'Helvetica-Bold' );

run() unless caller;

sub run
    {
    my $page;         # it's generally easier to have a page object av
+ailable
    $page = $pdf->openpage( $page_count );
    if ( ! $page ) {
        $page = $pdf->page;   # first page of brand new PDF doc
    }

    # check to see if we need to add a page
    if ( ++$puzzle_count / MAX_PUZZLES > $page_count ) {
        $page = $pdf->page;   # adds a new page, sets $page obj to new
+ page
    }
    
    # determine which puzzle on page to use:
    # 1st puzzle = upper left, 2nd = upper right
    # 3rd puzzle = mid left, 4th = mid right
    # 5th puzzle = lower left, 6th = lower right
    
    $puzzlenum = $puzzle_count % MAX_PUZZLES;

    my $gfx = $page->gfx;
    $gfx->strokecolor( '#000' );
    $gfx->linewidth( WIDE_LINE_WIDTH );

    make_grid(
        $gfx,
        #$xpos[ $puzzlenum ],    # x
        #$ypos[ $puzzlenum ],    # y
        $xy_pos[$puzzlenum]->[X_COORD],   # x
        $xy_pos[$puzzlenum]->[Y_COORD],   # y
        );

    populate_puzzle( $gfx, get_puzzle() );

    $pdf->info( 'Keywords' => "puzzlecount=$puzzle_count" );
    $pdf->saveas($infile);
    print "$infile now has $puzzle_count Sudoku puzzle";
    if ( $puzzle_count > 1 ) {
        print "s";
    } # if
    }
    print ".\n\n";

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 
+# #
sub populate_puzzle
    {
    my( $gfx, $array ) = @_;

    foreach my $row ( 0 .. $#$array )
        {
        my $row_array = $array->[$row];

        foreach my $column ( 0 .. $#$row_array )
            {
            next unless defined $row_array->[$column];
            place_digit( $gfx, $row, $column, $row_array->[$column] )
            }
        }
    }

sub place_digit
    {
    my( $gfx, $row, $column, $digit ) = @_;

    #my $x_start = $xpos[$puzzlenum];
    #my $y_start = $ypos[$puzzlenum];
    my $x_start = $xy_pos[$puzzlenum]->[X_COORD];
    my $y_start = $xy_pos[$puzzlenum]->[Y_COORD];

    my $x_offset = 0.30 * SQUARE_SIDE / 9; # empirically derived
    my $y_offset = 0.25 * SQUARE_SIDE / 9;

    my $x = $x_start + $column * SQUARE_SIDE / 9 + $x_offset;
    my $y = $y_start + $row * SQUARE_SIDE / 9 + $y_offset;

    $gfx->textlabel( $x, $y, $font, FONT_SIZE, $digit );

    }

sub get_puzzle
    {
    my @array;

    print STDERR "Reading puzzle from Sudoku generator...\n";

    while( <STDIN> )
        {
        chomp;
        s/^\s|\s$//g;
        next unless length $_;
        push @array, [ map { $_ eq '-' ? undef : $_ } split ];
        }

    print "Puzzle data read from STDIN.\n";
    print "Adding puzzle to PDF file...\n";

    return \@array;
    }

sub make_grid
    {
    my( $gfx, $lower_left_x, $lower_left_y ) = @_;

    make_outline( $gfx, $lower_left_x, $lower_left_y );

    $gfx->linewidth( THIN_LINE_WIDTH );
    make_blocks(  $gfx, $lower_left_x, $lower_left_y, 9 );

    $gfx->linewidth( LINE_WIDTH );
    make_blocks(  $gfx, $lower_left_x, $lower_left_y, 3 );
    }

sub make_blocks
    {
    my( $gfx, $lower_left_x, $lower_left_y, $cells ) = @_;

    my( $xs, $ys ) =
        map {
            my $point = $_;
            [ map { $point + $_ * SQUARE_SIDE / $cells } 1 .. $cells -
+ 1 ];
            } ( $lower_left_x, $lower_left_y );

    foreach my $x ( @$xs )
        {
        make_line( $gfx,
            $x, $lower_left_y,
            $x, $lower_left_y + SQUARE_SIDE,
            );
        }

    foreach my $y ( @$ys )
        {
        make_line( $gfx,
            $lower_left_x, $y,
            $lower_left_x + SQUARE_SIDE, $y,
            );
        }
    }

sub make_outline
    {
    my( $gfx, $lower_left_x, $lower_left_y ) = @_;

    my( $upper_right_x, $upper_right_y ) =
        map { $_ + SQUARE_SIDE } ( $lower_left_x, $lower_left_y );

    my @points = (
        [ $lower_left_x,   $lower_left_y - WIDE_LINE_WIDTH / 2,
          $lower_left_x,   $upper_right_y ],
        [ $lower_left_x, $upper_right_y - WIDE_LINE_WIDTH / 2,
          $upper_right_x, $upper_right_y ],
        [ $upper_right_x - WIDE_LINE_WIDTH / 2, $upper_right_y,
          $upper_right_x, $lower_left_y ],
        [ $upper_right_x, $lower_left_y + WIDE_LINE_WIDTH / 2,
          $lower_left_x, $lower_left_y ],
        );

    foreach my $tuple ( @points ) { make_line( $gfx, @$tuple ) }
    }

sub make_line
    {
    my( $gfx, $x, $y, $x2, $y2 ) = @_;

    $gfx->move( $x,  $y  );
    $gfx->line( $x2, $y2 );
    $gfx->fillstroke;
    }

__END__
- - 6   8 - 4   - - -
- - -   - 9 -   7 - 8
- - -   5 - -   - 9 -

1 - -   - 4 -   - - 9
- - -   - - -   5 - -
4 6 -   - - 1   - 3 -

8 7 -   - - -   4 - -
- - -   - 5 -   2 - -
- - -   - - 2   - 1 -
[download]

create_sudoku_puzzles.sc

# create_sudoku_puzzles.sc
#
# accepts a number and a file name/path on the command line
# creates x number of puzzles in PDF of filename
#
# simply loops x number of times and launches this combo of Perl scrip
+ts:
#  sudoku_generator.pl | sudoku2pdf.pl $filename
#
# That's it!

numpuzzles=$1
filename=$2
count=1

echo Creating $numpuzzles puzzle\(s\) in file
echo $filename

while [ $count -le $numpuzzles ]; do
    echo ""
    echo Creating puzzle $count
    sudoku_generator.pl | sudoku2pdf.pl $filename
    count=$(($count+1))
done

echo Done with puzzle creation
[download]

I've tested this shell script values up to 100 and it seems to work okay. YRMV, but have fun with it!

-MC

P.S. - To brian, Eric, and the rest of you TPR guys: Thanks! I just subscribed to The Perl Review and I love it!

Comment on NEW CODE: Making Sudoku Puzzles Using PDF::API2 Select or Download Code


Welcome to the Monastery
	PerlMonks