SPOILER: Solution to Perl Quiz of the Week #26 (Acrostic puzzle formatter)

On Thu, 14 Oct 2004, Mark Jason Dominus wrote:


> This week, you'll write a program to format and print puzzles.  

I got the idea from this quiz for a different sort of competitive
game. Two readers feed two writers with the letters from the
answer words. The writers fill in the quotation and, at the same
time, try to guess the other side's letters, if they can.

So in my solution, instead of spaces, I insert the actual letters themselves
in the answer words, and I divide the words between two sides.

My solution puts two copies of the puzzle on one piece of B5 paper using latex. The
program assumes quotations will not be longer than 99
letters plus words.

I used code from XERN's Games::Crossword,
which does a similar job to this quiz for crosswords.


#!/usr/bin/perl -wd

use strict;
use warnings;

my $quote = <>;
chomp $quote;
<>;
my @answers;
while (<>)
{
    chomp;
    push @answers, $_;
}
my $half = $#answers / 2;
my $answers;
push @{ $answers->{RED} },   shift @answers while $half-- > 0;
push @{ $answers->{BLACK} }, shift @answers while @answers;
my %dim = ( 'y' => 9, x => 11 );

$quote =~ tr/a-zA-Z/ /cs;
my $length = length $quote;

my $answerhash;
foreach my $team (qw/RED BLACK/)
{
    my $word = 'a';
    foreach my $answer ( @{ $answers->{$team} } )
    {
        my $length = length $answer;
        my $offset = 0;
        while ( $offset < $length )
        {
            my $key = substr $answer, $offset, 1;

            # I store the letters (as tokens) keyed on the letters (as types)

            push @{ $answerhash->{$team}->{$key} },
              { word => $word, offset => $offset };
            $offset++;
        }
        $word++;
    }
}

my $HEAD = <<HEAD;
\\documentclass[b5paper]{article}
\\newcommand{\\printlandscape}{\\special{landscape}}
\\printlandscape
\\pagestyle{empty}
\\usepackage{texdraw}
\\usepackage{color}
\\setlength{\\unitlength}{1cm}
\\newcommand{\\mypuzzle}[1]{%
\\setlength{\\unitlength}{1cm}
\\begin{picture}(5,7)#1
\\begin{texdraw}
\\begin{ttfamily}
HEAD

my $FOOT = <<FOOT;
\\end{ttfamily}
\\end{texdraw}
\\end{picture}
}
\\begin{document}
\\begin{minipage}{17cm}
\\mypuzzle{(+1.5,6.2)}
\\mypuzzle{(-5.9,6.2)}
\\end{minipage}
\\end{document}
FOOT

my ( $dx, $dy ) = ( 0.9, 0.9 );
my $tex = "\\drawdim{cm} ";

my $arr;
my $blank = 1;
my $word;
my $offset = 0;
my $team   = 'RED';
my $correspondence;

foreach my $i ( 0 .. $dim{y} - 1 )
{
    foreach my $j ( 0 .. $dim{x} - 1 )
    {
        $tex .= "\\move(@{[$j*$dx]} -@{[$i*$dy]}) ";
        $tex .=
"\\linewd 0.01 \\rlvec(0 -$dy) \\linewd 0.03 \\rlvec($dx 0) \\linewd 0.01 \\rlvec(0 $dy) \\linewd 0.03 \\rlvec(-$dx 0) ";
        if ( $offset < $length )
        {
            my $letter = $arr->[$i]->[$j] = substr $quote, $offset++, 1;
            if ( $letter ne ' ' )
            {

  # I match the letters from the quote with a letter popped from the answer hash
  # I get clumping of letters, but it is LIFO clumping :->

                my $correspondent = pop @{ $answerhash->{$team}->{$letter} };
                if ( not defined $correspondent )
                {
                    $team = ( $team eq 'RED' ) ? 'BLACK' : 'RED';
                    $correspondent = pop @{ $answerhash->{$team}->{$letter} };
                }
                $word = $correspondent->{word};
                my $offset = $correspondent->{offset};

  # I store the letters from the quote keyed on the correspondent in the answers

                $correspondence->{$team}->{$word}->{$offset} =
                  { letter => $letter, number => $blank };
            }
        }
        else
        {
            $arr->[$i]->[$j] = ' ';
        }
        if ( $arr->[$i]->[$j] eq ' ' )
        {
            $tex .= "\\lfill f:0.5\n";
        }
        else
        {
            my $color = ( $team eq 'RED' ) ? 'red' : 'black';
            $tex .= "\\rmove(-0.19 -0.24) ";

# this prints the number of the blank and corresponding answer word

            $tex .= "\\htext{ \\textcolor{$color}{$blank$word }}\n";
            $blank++;
            $team = ( $team eq 'RED' ) ? 'BLACK' : 'RED';
        }
    }
}

( $dx, $dy ) = ( 0.75, 0.75 );
my $i = 0;
foreach my $team (qw/RED BLACK/)
{
    $i++;
    my $color = ( $team eq 'RED' ) ? 'red' : 'black';
    $tex .= "\\color{$color}";

    # $tex .= "\\move(0 -@{[1.1*$dim{y}+$i*($dy+0.2)]}) ";
    # $tex .= "\\htext{$team }";
    foreach my $word ( sort keys %{ $correspondence->{$team} } )
    {
        my @letters = sort keys %{ $correspondence->{$team}->{$word} };
        $tex .= "\\move(0 -@{[0.95*$dim{y}+$i*($dy)]}) ";
        $tex .= "\\htext{$word. }";
        my $j = 1;
        foreach my $letter (@letters)
        {

            # # $tex .= "\\move(@{[$j*$dx]} -@{[$i*$dy]}) ";
            $tex .= "\\move(@{[$j*$dx]} -@{[0.95*$dim{y}+$i*($dy)]}) ";
            $tex .=

# this prints the answer word

"\\huge \\htext{$correspondence->{$team}->{$word}->{$letter}->{letter}}";
            $tex .= "\\rmove(-0.19 -0.24) ";
            $tex .=

# this prints the number of the blank in the quote

"\\normalsize \\htext{ $correspondence->{$team}->{$word}->{$letter}->{number} }\n";

            $j++;
        }
        $i++;
    }
}

$tex .= "\n";
open F, '>qotw.tex';
print F $HEAD . $tex . $FOOT;
close F;