Re: [FWP] Anacrossagrams

[Fergal Daly <fergal@esatclear.ie>]

John Porter wrote:
> 
> Fergal wrote:
> > Try
> >
> > anacrossagram(
> >       [qw( abcd afgh ijkl mnop )],
> >       [qw( afkp bajn cgko dhlp )],
> > );
> >
> > This has a solution,
> 
> No, it doesn't.
> 
> Add the following block of code after the first print in my sub
> anacrossagrams:
> 
> {
>   # see if the problem is even soluble:
>   my @a = sort map { split // } @across;
>   my @d = sort map { split // } @down;
>   unless ( "@a" eq "@d" ) {
>     print "Impossible to solve, because
> across letters: @a
>   down letters: @d
> ";
>     return();
>   }
> }

Yeah I noticed that a while ago when I tried it myself. What I meant to
write was

anacrossagram(
  [qw( abcd efgh ijkl mnop )],
  [qw( aeim bfjn cgko dhlp )],
);
which your code does solve.

Your code finds one solution to this

anacrossagram(
  [qw( abcd bagh ijkl mnop )],
  [qw( abim bajn cgko dhlp )],

the code attached finds all solutions (I hope), although it's not
pretty,

Fergal
#! /usr/bin/perl

use strict;

my @across;
my @down;

my $which = 3;
if ($which == 0)
{
	@across = qw( erupt nymph horse soaky twist );
	@down = qw( risky heath spoon strum swept );
}
elsif($which == 1)
{
	@across = qw( erupt nymph horse soaks twist );
	@down = qw( risky heath spoon strum swept );
}
elsif($which == 2)
{
	@across = qw( abcd efgh ijkl mnop );
	@down = qw( aeim bfjn cgko dhlp );
}
elsif($which == 3)
{
	@across = qw( abcd bagh ijkl mnop );
	@down = qw( abim bajn cgko dhlp );
}
elsif($which == 4)
{
	@across = qw( abcd abcd abcd abcd );
	@down = qw( abcd abcd abcd abcd );
}

my @solns;


my %a_grid;
my %d_grid;

for (my $x = 0; $x < @across; $x++)
{
	for (my $y = 0; $y < @down; $y++)
	{
		$a_grid{"$x,$y"} = $across[$y];
		$d_grid{"$x,$y"} = $down[$x];
	}
}

my @state = (\%a_grid, \%d_grid);

print "The problem\n";
print_grid(@state);
eval{ solve(@state) };
print "$@\n" if $@;


print "The solutions follow\n";
foreach my $soln (@solns)
{
	print_grid(@$soln);
	print "\n";
}

print "We got ".@solns." solutions\n";

sub solve
{
	my %a_grid = %{shift()};
	my %d_grid = %{shift()};

	print "Attempting to solve\n";
	print_grid(\%a_grid, \%d_grid);

	# Go over the whole grid eliminating any that are impossible. If we don't
	# encounter any choices then we have a solution, if we do, we need to try
	# both options , so keep note of the first one which needs a choice

	my $choice_pos;

	for (my $x = 0; $x < @across; $x++)
	{
		for (my $y = 0; $y < @down; $y++)
		{
			my $pos = "$x,$y";
			my $a = $a_grid{$pos};
			my $d = $d_grid{$pos};

			(my $a_nospace = $a) =~ s/ //g;
			(my $d_nospace = $d) =~ s/ //g;
			if ( length $a_nospace == 1 and length $d_nospace == 1 and $a_nospace eq $d_nospace)
			{
				next;
			}
			my $int = intersect($a_nospace, $d_nospace);

			if (length $int == 0)
			{
				die "Can't solve this, ended up blank for ($pos)\n";
			}
			elsif (length $int == 1)
			{
				fix(\%a_grid, \%d_grid, $x, $y, $int);
			}
			else
			{
				$choice_pos ||= $pos;
				$a_grid{$pos} = filter($a, $int);
				$d_grid{$pos} = filter($d, $int);
			}
		}
	}

	if ($choice_pos)
	{
		my $choices = $a_grid{$choice_pos};

		my ($x, $y) = split(",", $choice_pos);
		foreach my $choice (grep {/\S/} split("", $choices))
		{
			my %new_a_grid = %a_grid;
			my %new_d_grid = %d_grid;
			print "I have a choice to make at ($choice_pos)\n";
			print_grid(\%new_a_grid, \%new_d_grid);

			print "trying '$choice' at ($choice_pos)\n";
			fix(\%new_a_grid, \%new_d_grid, $x, $y, $choice);

			eval {solve(\%new_a_grid, \%new_d_grid)};
			if ($@)
			{
				print "$@\n";
			}
		}
	}
	else
	{
		print "We have a solution\n";
		print_grid(\%a_grid, \%d_grid);
		push(@solns, [\%a_grid, \%d_grid]);
	}
}

sub fix
{
	my ($a_grid, $d_grid, $fix_x, $fix_y, $char) = @_;

	my $pos = "$fix_x,$fix_y";

#	print "fixing ($pos) on $char from ".join(", ", caller)."\n";
	
#	print_grid($a_grid, $d_grid);
	my $a_index = index($a_grid->{$pos}, $char);

	my $a_blank = " " x @across;

	substr($a_blank, $a_index, 1, $char);
	$a_grid->{$pos} = $a_blank;
	for (my $x = 0; $x < @across; $x++)
	{
		if ($x == $fix_x)
		{
			next;
		}

		my $str = $a_grid->{"$x,$fix_y"};
		substr($str, $a_index, 1, ' ');
		$a_grid->{"$x,$fix_y"} = $str;
	}

#	print_grid($a_grid, $d_grid);

	my $d_index = index($d_grid->{$pos}, $char);

	my $d_blank = " " x @down;
	substr($d_blank, $d_index, 1, $char);
	$d_grid->{$pos} = $d_blank;
	for (my $y = 0; $y < @down; $y++)
	{
		if ($y == $fix_y)
		{
			next;
		}

		my $str = $d_grid->{"$fix_x,$y"};
		substr($str, $d_index, 1, ' ');
		$d_grid->{"$fix_x,$y"} = $str;
	}

#	print_grid($a_grid, $d_grid);

}

sub filter
{
	my ($string, $chars) = @_;

#	print "filtering '$string' on '$chars' ... ";
	$string =~ s/[^ $chars]/ /g;
#	print "got '$string'\n";
	return $string;
}

sub intersect
{
	my ($a, $b) = @_;

	my %a_char;
	foreach my $char (split("", $a))
	{
		$a_char{$char}++;
	}
#	delete $a_char{' '}; # we don't want to match ' '

	my %b_char;
	foreach my $char (split("", $b))
	{
		$b_char{$char}++;
	}

	my $intersect;
	foreach my $char (keys %a_char)
	{
#		push(@intersect, $char) if $b_char{$char};
		$intersect .= $char if $b_char{$char};
	}

#	print "inter of '$a', '$b' is '$intersect'\n";
	return $intersect;
}

sub print_grid
{
	my ($a_grid, $d_grid) = @_;

	my $piece = "+-".("-" x @across)."-";

	my $boundary = ($piece x @across)."+";
	for (my $x = 0; $x < @across; $x++)
	{
		print "$boundary\n";
		my $a_line = '';
		my $d_line = '';
		for (my $y = 0; $y < @down; $y++)
		{
			
			$a_line .= "| ".$a_grid->{"$x,$y"}." ";
			$d_line .= "| ".$d_grid->{"$x,$y"}." ";
		}
		print "$a_line|\n";
		print "$d_line|\n";
	}
	print "$boundary\n";
	
}