Re: [FWP] Anacrossagrams

[Fergal Daly <fergal@esatclear.ie>]

Try

anacrossagram(
	[qw( abcd afgh ijkl mnop )],
	[qw( afkp bajn cgko dhlp )],
);

This has a solution, but the code below doesn't find it. The problem is
that there is more than one solution the solver needs to choose an option
and then recursively solve this problem,

Fergal


At 14:31 18/07/99 -0400, John Porter wrote:
>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
>
>
>


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