Re: [FWP] Anacrossagrams

[Rick Delaney <rick.delaney@home.com>]

Fergal Daly wrote:
> 
> Try
> 
> anacrossagram(
>         [qw( abcd afgh ijkl mnop )],
>         [qw( afkp bajn cgko dhlp )],
> );
> 
> This has a solution, but the code below doesn't find it.

[snip John's code]

My code, which I think is quite different from John's (except for the
first few lines that I ripped off), doesn't find a solution to that
either.  Hmm.

Anyway, for fun, here it is.  I got &permute from the FAQ and just
modified it the quickest way I could think of to give me an array of all
permutations.  It's not very efficient either but I haven't raced it
against John's yet to see just how bad it is.

sub anacrossagram {
    my( $ar1, $ar2 ) = @_;
    my @across = @$ar1;
    my @down   = @$ar2;
    my $high = $#across;
    return if $#down != $high;
    print "Across: @across\n  Down: @down\n";

    local $" = "";
    my @permutations;
    permute([0 .. $high], [], \@permutations);
    my @down_pat = map { qr/[$_]/ } @down;

    my @grid;
    my %seen;
    for my $order (@permutations) {
        my $pat = "@down_pat[@$order]";
        for my $i (0 .. $high) {
            my $ac = $across[$i];
            if ($ac =~ $pat) {
                my @ac_perm;
                @ac_perm[@$order] = split //, $ac;
                my $ac_perm = "@ac_perm";
                push @{ $grid[$i] }, $ac_perm unless
                    $seen{$i}{$ac_perm}++;
            }
        }
    }
    for my $i (0 .. $high - 1) {
        my @seg;
        for my $this (@{ $grid[$i] })  {
            for my $next (@{ $grid[$i+1] }) {
                my $grid = "$this\n$next";
                push @seg, $grid;
            }
        }
        $grid[$i+1] = \@seg;
    }

    Grid:
    for (@{pop @grid}) {
        my @words = split /\n/;
        for my $i (0 .. $high) {
            my $word = join "", map { substr($_, $i, 1) } @words;
            next Grid unless 
                "@{[ sort split //, $word ]}" 
                    eq 
                "@{[ sort split //, $down[$i] ]}";
        }
        return "$_\n";
    }
    return;
}
        
sub permute {
    my @items  = @{ $_[0] };
    my @perms  = @{ $_[1] };
    my $return = $_[2];
    unless (@items) {
        push @$return, \@perms;
    } else {
        my(@newitems,@newperms,$i);
        foreach $i (0 .. $#items) {
            @newitems = @items;
            @newperms = @perms;
            unshift(@newperms, splice(@newitems, $i, 1));
            permute([@newitems], [@newperms], $return);
        }
    }
}

-- 
Rick Delaney
rick.delaney@home.com

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