Re: [FWP] Anacrossagrams

[John Porter <jdporter@min.net>]

RJK wrote:
> 
> Okay, _now_ have fun!  :)

Okay.  Here's my solution. 
(I'm getting in the habit of excusing inefficiency as "fun".  :-)

This is set up as a subroutine, to make it easier to test against
sets of problems (like those at the given URL).
If a problem can't be solved, some useful state information is printed.
For example, in the "soaky" case, the output looks like this:

    Across: erupt nymph horse soaky twist
      Down: risky heath spoon strum swept
    1 cells unresolved:
    3 Across: y
    4 Down: s
    r e p u t 
    y h n m p 
    s h o r e 
    k a o s . 
    i t s t w 

(Row and column numbering is 0-based, of course.)

John Porter

__DATA__


sub anacrossagram {
  my( $ar1, $ar2 ) = @_;
  my @across = @$ar1;
  my @down   = @$ar2;
  print "Across: @across\n  Down: @down\n";
  my @grid;
  my $n_empty = @across * @down;
  my $resolv_lim = 1;
  while ( $n_empty ) {
    my $n_changes = 0;
    for my $y ( 0 .. $#across ) {
    for my $x ( 0 .. $#down ) {
      next if defined $grid[$y][$x];
      my( $i_ac, $i_dn ) = common( $resolv_lim, $across[$y], $down[$x] );
      defined $i_dn or next; # no single common.
      $grid[$y][$x] = substr $across[$y], $i_ac, 1;
      $n_empty--;
      $n_changes++;
      substr( $across[$y], $i_ac, 1 ) = '';
      substr( $down[$x], $i_dn, 1 ) = '';
    }
    }
    unless ( $n_changes ) {
      ++$resolv_lim <= 5 or last;
    }
  }

  if ( $n_empty ) {
    print "$n_empty cells unresolved:\n";
    for my $y ( 0 .. $#across ) {
      print "$y Across: $across[$y]\n" if length $across[$y];
    }
    for my $x ( 0 .. $#down ) {
      print "$x Down: $down[$x]\n" if length $down[$x];
    }
  }

  for my $y ( 0 .. $#across ) {
    for my $x ( 0 .. $#down ) {
      print defined($grid[$y][$x])
        ? "$grid[$y][$x] "
        : ". ";
    }
    print "\n";
  }
  print "\n";
}


# returns the indexes (a pair) of the single common element if there is one,
# or () if not.
sub common {
  my( $n, $s1, $s2 ) = @_;
  my( %h1, %h2 );
  for ( 0 .. length($s1)-1 ) { $h1{ substr($s1,$_,1) } = $_; }
  for ( 0 .. length($s2)-1 ) { $h2{ substr($s2,$_,1) } = $_; }
  my %seen;
  for ( keys( %h1 ), keys( %h2 ) ) { $seen{$_}++ }
  for ( keys %seen ) { delete $seen{$_} if $seen{$_} == 1; }
  my @k = keys %seen;
  @k <= $n or return();
  my $elem = $k[0];
  return( $h1{$elem}, $h2{$elem} );
}



==== Want to unsubscribe from Fun With Perl?  Well, if you insist...
==== Send email to <fwp-request@technofile.org> with message _body_
====   unsubscribe