comment on

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!

In reply to NEW CODE: Making Sudoku Puzzles Using PDF::API2 by mercutio_viz
in thread Making Sudoku Puzzles Using PDF::API2 by brian_d_foy

Are you posting in the right place? Check out Where do I post X? to know for sure.
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
Want more info? How to link or How to display code and escape characters are good places to start.


more useful options
	PerlMonks