#!perl -w
use strict;
our(@empty_square, @full_square);

my @sample_puzzle = qw(
....X.....X....
....X.....X....
....X.....X....
.......X.......
XXX......X.....
.....X......XXX
......X...X....
...X.......X...
....X...X......
XXX......X.....
.....X......XXX
.......X.......
....X.....X....
....X.....X....
....X.....X....
);

map { y/./ / } @empty_square;

# Some constants

my $cellheight  = scalar @empty_square;
my $cellwidth   = length $empty_square[0];

my $cellheight2 = scalar @full_square;
my $cellwidth2  = length $full_square[0];

die 'Empty and full square sizes mismatch !'
    unless ($cellheight == $cellheight2 and $cellwidth == $cellwidth2);


my $puzzleheight = scalar @sample_puzzle;
my $puzzlewidth  = length $sample_puzzle[0];

warn 'Puzzle is not square' unless $puzzleheight == $puzzlewidth;

my $expected_height = $puzzleheight * ( $cellheight-1 ) + 1;
my $expected_width  = $puzzlewidth  * ( $cellwidth -1 ) + 1;

#
# row, col, @sample_puzzle
# returns the appropriate character ( '.' or 'X' )
# Returns 'X' if out of bounds
#
sub indexer( $$@; )
{
    my $row = shift;
    if( $row < 0 )
    {
        return 'X';
    }
    my $col = shift;
    if( $col < 0 )
    {
        return 'X';
    }
    my $line = $_[ $row ];
    substr $line, $col, 1
}

#
# Pass @sample_puzzle
# returns a list-of-lists with the appropriate number,
# 0 if empty and -1 if black square
#
sub compute_numerals( @; )
{
    my @twodim;
    my $numer = 0;

    foreach my $r ( 0 .. $#_ )
    {
        my @onedim;
        foreach my $c ( 0 .. length($_[$r])-1 )
        {
            my $i = indexer( $r, $c, @_ );
            if( $i eq '.' )
            {
                # empty
                my $above = indexer( $r-1, $c  , @_ );
                my $left  = indexer( $r  , $c-1, @_ );
                if( $above eq 'X'
                   or $left eq 'X' )
                {
                    push @onedim, ++$numer;
                }
                else
                {
                    push @onedim, 0;
                }
            }
            else
            {
                push @onedim, -1;
            }
        }

        push @twodim, \@onedim;
    }

    @twodim;
}

my @n = compute_numerals @sample_puzzle;
foreach my $nn ( @n )
{
    my @rr = @$nn;
    foreach my $cell ( @rr )
    {
        printf '%2d ', $cell;
    }
    print "\n";
}

my @retval;

sub poke( $$\@ )
{
    my $top  = shift;
    my $left = shift;

    #    print STDERR "poke( $top,$left )\n";

    #    my @retval = @{ +shift };
    my @square = @{ +shift };
    for( my $row_poke = 0; $row_poke < $cellheight; ++$row_poke )
    {
        #        print STDERR "poking [$top + $row_poke][$left] with $square[$row_poke]\n";
        my $sub = substr $retval[$top + $row_poke], $left, $cellwidth, $square[$row_poke];
        #        print STDERR "[$sub], \n";
    }
}

#
# Returns an array of strings
#
sub layout_crossword( @; )
{
    # init the retval to the required number of strings
    foreach(1..$expected_height){ push @retval, ' ' x $expected_width }


    my $top = 0; # the index of the top row of the cell
    my $left= 0; # the index of the left column of the cell

    my @numbered = compute_numerals @sample_puzzle;

    for( my $row = 0; $row < $puzzleheight; ++$row )
    {
        $left = 0;
        for( my $column = 0; $column < $puzzlewidth; ++$column )
        {
            my $cell = $numbered[$row][$column];

            if( $cell < 0 )
            {
                # A black square
                poke $top, $left, @full_square;
            }
            elsif( $cell == 0 )
            {
                # An empty square
                poke $top, $left, @empty_square;
            }
            else
            {
                # A numbered square
                my @numbered_square = @empty_square;
                my $rep = substr $numbered_square[1], 1, length $cell, $cell;
                die "Number won't fit in cell" if $rep =~ /X/;
                poke $top, $left, @numbered_square;
            }

            $left += $cellwidth-1;
        } # next column

        $top += $cellheight-1;
    } # next row

    @retval;
}


my @expected =
(
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX',
'X1   X2   X3   X4   XXXXXX5   X6   X7   X8   X9   XXXXXX10  X11  X12  X13  X',
'X    X    X    X    XXXXXX    X    X    X    X    XXXXXX    X    X    X    X',
'X    X    X    X    XXXXXX    X    X    X    X    XXXXXX    X    X    X    X',
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX',
'X14  X    X    X    XXXXXX15  X    X    X    X    XXXXXX16  X    X    X    X',
'X    X    X    X    XXXXXX    X    X    X    X    XXXXXX    X    X    X    X',
'X    X    X    X    XXXXXX    X    X    X    X    XXXXXX    X    X    X    X',
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX',
'X17  X    X    X    XXXXXX18  X    X    X    X    XXXXXX19  X    X    X    X',
'X    X    X    X    XXXXXX    X    X    X    X    XXXXXX    X    X    X    X',
'X    X    X    X    XXXXXX    X    X    X    X    XXXXXX    X    X    X    X',
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX',
'X20  X    X    X    X21  X    X    XXXXXX22  X    X23  X    X    X    X    X',
'X    X    X    X    X    X    X    XXXXXX    X    X    X    X    X    X    X',
'X    X    X    X    X    X    X    XXXXXX    X    X    X    X    X    X    X',
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX',
'XXXXXXXXXXXXXXXX24  X    X    X    X25  X    XXXXXX26  X    X    X    X    X',
'XXXXXXXXXXXXXXXX    X    X    X    X    X    XXXXXX    X    X    X    X    X',
'XXXXXXXXXXXXXXXX    X    X    X    X    X    XXXXXX    X    X    X    X    X',
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX',
'X27  X28  X29  X    X    XXXXXX30  X    X    X31  X         XXXXXXXXXXXXXXXX',
'X    X    X    X    X    XXXXXX    X    X    X    X         XXXXXXXXXXXXXXXX',
'X    X    X    X    X    XXXXXX    X    X    X    X         XXXXXXXXXXXXXXXX',
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX',
'X32  X    X    X    X    X33  XXXXXX34  X    X    XXXXXX35  X36  X37  X38  X',
'X    X    X    X    X    X    XXXXXX    X    X    XXXXXX    X    X    X    X',
'X    X    X    X    X    X    XXXXXX    X    X    XXXXXX    X    X    X    X',
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX',
'X39  X    X    XXXXXX40  X    X41  X    X    X    X42  XXXXXX43  X    X    X',
'X    X    X    XXXXXX    X    X    X    X    X    X    XXXXXX    X    X    X',
'X    X    X    XXXXXX    X    X    X    X    X    X    XXXXXX    X    X    X',
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX',
'X44  X    X    X45  XXXXXX46  X    X    XXXXXX47  X    X48  X    X    X    X',
'X    X    X    X    XXXXXX    X    X    XXXXXX    X    X    X    X    X    X',
'X    X    X    X    XXXXXX    X    X    XXXXXX    X    X    X    X    X    X',
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX',
'XXXXXXXXXXXXXXXX49  X50  X    X    X    X51  XXXXXX52  X    X    X    X    X',
'XXXXXXXXXXXXXXXX    X    X    X    X    X    XXXXXX    X    X    X    X    X',
'XXXXXXXXXXXXXXXX    X    X    X    X    X    XXXXXX    X    X    X    X    X',
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX',
'X53  X54  X55  X    X    XXXXXX56  X    X    X57  X         XXXXXXXXXXXXXXXX',
'X    X    X    X    X    XXXXXX    X    X    X    X    X    XXXXXXXXXXXXXXXX',
'X    X    X    X    X    XXXXXX    X    X    X    X    X    XXXXXXXXXXXXXXXX',
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX',
'X58  X    X    X    X    X59  X    XXXXXX60  X    X    X    X61  X62  X63  X',
'X    X    X    X    X    X    X    XXXXXX    X    X    X    X    X    X    X',
'X    X    X    X    X    X    X    XXXXXX    X    X    X    X    X    X    X',
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX',
'X64  X    X    X    XXXXXX65  X    X66  X    X    XXXXXX67  X    X    X    X',
'X    X    X    X    XXXXXX    X    X    X    X    XXXXXX    X    X    X    X',
'X    X    X    X    XXXXXX    X    X    X    X    XXXXXX    X    X    X    X',
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX',
'X68  X    X    X    XXXXXX69  X    X    X    X    XXXXXX70  X    X    X    X',
'X    X    X    X    XXXXXX    X    X    X    X    XXXXXX    X    X    X    X',
'X    X    X    X    XXXXXX    X    X    X    X    XXXXXX    X    X    X    X',
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX',
'X71  X    X    X    XXXXXX72  X    X    X    X    XXXXXX73  X    X    X    X',
'X    X    X    X    XXXXXX    X    X    X    X    XXXXXX    X    X    X    X',
'X    X    X    X    XXXXXX    X    X    X    X    XXXXXX    X    X    X    X',
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX',
);

#
# Here we get the result !
#
my @actual = layout_crossword @sample_puzzle;

$, = "\n";
print @actual;

for ( my $i =0 ; $i < $expected_height; ++$i )
{
    die "\n\nMismatch at $i\nA=$actual[$i]\nE=$expected[$i]\n" unless

$actual[$i] eq $expected[$i];
}

__END__

Not very Perl-like, I'm afraid (I'm a C/C++ programmer at heart).
I used substr to overwrite the existing data (the buffer technique as
described by Dan Schmidt).

(the spurious semicolons in the subroutine prototypes are there to keep my

editor's syntax coloring happy :-)


--
Csaba Ráduly, Software Engineer                           Sophos Anti-Virus

email: csaba.raduly@sophos.com                        http://www.sophos.com

US Support: +1 888 SOPHOS 9                     UK Support: +44 1235 559933




