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

On Thu, Oct 14, 2004 at 04:49:48PM -0400, Mark Jason Dominus wrote:

>This week, you'll write a program to format and print puzzles.  The
>input to the program will be a file with two sections.  The first
>section will be the quotation, and will be followed by a single blank
>line, and then the second section, which will be the list of answer
>words, one per line.

There are two parts to this puzzle I found technically interesting: the
wrapping of an output which is itself multiline over multiple "large"
lines, which I performed with an output line cache, and the spread of
answer letters among different clues.

The latter is done with a weighting system. Each clue-word has a
weight, initially 0; when a letter is chosen from it, the weight is
increased by N (equal to the number of clue-words). For a word to be
used, a random number from 0 to N must exceed the word's current
weight. If after ten selections no candidate word has been found, all
non-zero weights are decreased by 1.

#! /usr/bin/perl -w

use strict;

my $outputwidth=($ENV{COLUMNS} || 80) - 8;

my $quotation='';
my @words;
my $state=0;
while (<>) {
  chomp;
  if ($_ eq '') {
    $state=1;
  } else {
    $_=lc($_);
    if ($state==0) {
      $quotation.=" $_";
    } else {
      push @words,$_;
    }
  }
}
$quotation =~ s/[^a-z ]//g;
$quotation =~ s/\s{2,}/ /g;
my @quotation=split ' ',$quotation;

my %letters;
my %locations;
foreach my $wn (0..$#words) {
  my @letters=split '',$words[$wn];
  foreach my $ln (0..$#letters) {
    my $letter=$letters[$ln];
    push @{$letters{$letter}},$wn;
    push @{$locations{$letter}},$ln;
  }
}

my @wordlabels;
{
  my $nn=1;
  while (scalar @wordlabels < scalar @words) {
    push @wordlabels, map {$_ x $nn} ('A'..'Z');
  }
}

my $n=1;
my @output;
my @wt;
my @weights=(0) x scalar @words;
foreach my $qword (@quotation) {
  my @ow;
  foreach my $letter (split '',$qword) {
    my $own;
    my $wn;
    do {
      my $tick=10;
      do {
        $own=int(rand(scalar @{$letters{$letter}}));
        $wn=$letters{$letter}[$own];
        $tick--;
      } while (rand(scalar @words) <= $weights[$wn] && $tick);
      if ($tick==0) {
        map {($weights[$_]==0)?0:$weights[$_]--} (0..$#weights);
      }
    } while (rand(scalar @words) <= $weights[$wn]);
    $weights[$wn]+=scalar @words;
    splice @{$letters{$letter}},$own,1;
    my $ln=splice @{$locations{$letter}},$own,1;
    push @ow,$n.$wordlabels[$wn];
    $wt[$wn][$ln]=$n;
    $n++;
  }
  push @output,\@ow;
}

my $maxlen=length($n.$wordlabels[-1]);
my @outlines=('','');
foreach my $wn (0..$#output+1) {
  my @str=('','');
  if ($wn <= $#output) {
    my $word=$output[$wn];
    $str[0]=join(' ',('_' x $maxlen) x scalar @{$word});
    $str[1]=join(' ',map {sprintf("%-${maxlen}s",$_)} @{$word});
  }
  my $len=length($outlines[0])+length($str[0])+$maxlen+2;
  if ($len > $outputwidth || $wn > $#output) {
    print "$outlines[0]\n$outlines[1]\n\n\n";
    @outlines=@str;
  } else {
    if ($outlines[0]) {
      map {$outlines[$_].=' ' x (2+$maxlen)} (0,1);
    }
    map {$outlines[$_].=$str[$_]} (0,1);
  }
}

foreach my $clue (0..$#wt) {
  printf('%'.length($wordlabels[-1]).'s. ',$wordlabels[$clue]);
  print join ' ',map{'_' x $maxlen} (1..length($words[$clue]));
  print "\n";
  print ' ' x (length($wordlabels[-1])+2);
  print join ' ',map {sprintf("%-${maxlen}s",$_)} @{$wt[$clue]};
  print "\n\n";
}