#!/usr/bin/perl
use strict;
use Algorithm::Numerical::Shuffle qw(shuffle);

my @tiles = ([2,2], [2,3], [2,4], [3,3], [3,4], [4,4], [4,5], [4,6], [
+5,5]);
my $maxtile = (sort map @$_, @tiles)[-1];
my $dimx = shift || 50;
my $dimy = shift || 25;
my $progress;
my @ground;
my @pos;

foreach(0 .. $dimy-1) {
    @{$ground[$_]} = ((0) x $dimx, -1);
}
@{$ground[$dimy]} = (-1) x ($dimx+1);

foreach(@tiles) {
    if(${$_}[0] < ${$_}[1]) {
        push @tiles, [reverse @$_];
    }
}
@tiles = sort {${$a}[0] <=> ${$b}[0]} @tiles;

foreach my $i (0 .. $dimx+$dimy-2) {
    foreach my $y (0 .. $i) {
        my $x = $i-$y;
        next if $x >= $dimx || $y >= $dimy;
        push @pos, [$x,$y];
    }
}
push @pos, [$dimx, $dimy];

sub pave {
    my ($idx, $size, $val) = @_;
    my ($w, $h) = @{$tiles[$size]};
    my ($x0, $y0) = @{$pos[$idx]};
    foreach my $x ($x0 .. $x0+$w-1) {
        foreach my $y ($y0 .. $y0+$h-1) {
            $ground[$y][$x] = $val;
        }
    }
}

sub candidates {
    my ($idx) = @_;
    my ($x, $y) = @{$pos[$idx]};
    my $maxw = $dimx;
    my $maxh = $dimy;
    foreach my $w (1 .. $maxtile) {
        if($ground[$y][$x+$w]
           || (!$ground[$y-1][$x+$w] && $ground[$y-2][$x+$w])) {
            $maxw = $w;
            last;
        }
    }
    foreach my $h (1 .. $maxtile) {
        if($ground[$y+$h][$x]
           || (!$ground[$y+$h][$x-1] && $ground[$y+$h][$x-2])) {
            $maxh = $h;
            last;
        }
    }
    my %ws = ();
    my %hs = ();
    my @candidates;
    # some culling. this doesn't affect the outcome,
    # but reduces the branching factor.
    # these work because none of the tiles have width=1.
    foreach my $w (1 .. $maxtile) {
        next if $w > $maxw || $w == $maxw - 1;
        if($ground[$y-1][$x+$w-1]) {
            next if $ground[$y-1][$x+$w] != $ground[$y][$x+$w]
                 && $ground[$y-1][$x+$w] != $ground[$y-1][$x+$w-1];
        } else {
            last if $ground[$y-2][$x+$w-1];
        }
        $ws{$w} = 1;
    }
    foreach my $h (1 .. $maxtile) {
        next if $h > $maxh || $h == $maxh - 1;
        if($ground[$y+$h-1][$x-1]) {
            next if $ground[$y+$h][$x-1] != $ground[$y+$h][$x]
                 && $ground[$y+$h][$x-1] != $ground[$y+$h-1][$x-1];
        } else {
            last if $ground[$y+$h-1][$x-2];
        }
        $hs{$h} = 1;
    }
    return grep {$ws{$tiles[$_][0]} && $hs{$tiles[$_][1]};}
                (0 .. $#tiles);
}

sub place {
    my ($idx) = @_;
    while($ground[$pos[$idx][1]][$pos[$idx][0]] > 0) {
        $idx++;
    }
    if($idx == $#pos) {
        return 1;
    }
    if(!(++$progress & 0xffff)) {
        display();
    }
    my ($x, $y) = @{$pos[$idx]};
    if($x > 0 && $y > 0
       && $ground[$y-1][$x-1] != $ground[$y][$x-1]
       && $ground[$y-1][$x-1] != $ground[$y-1][$x]) {
        return 0;
    }
    foreach my $c (shuffle(candidates($idx))) {
        pave($idx, $c, $idx+1);
        place($idx+1) and return 1;
        pave($idx, $c, 0);
    }
    return 0;
}

sub display {
    foreach my $y (0 .. $dimy) {
        foreach my $x (0 .. $dimx) {
            my $dx = ($ground[$y][$x] != $ground[$y][$x-1]) ||
                     ($ground[$y-1][$x] != $ground[$y-1][$x-1]);
            my $dy = ($ground[$y][$x] != $ground[$y-1][$x]) ||
                     ($ground[$y][$x-1] != $ground[$y-1][$x-1]);
            print $dx ? $dy ? '+' : '|' : $dy ? '-' : ' ';
        }
        print "\n";
    }
    print "\n";
}

place(0) or warn "paving failed\n";
display();
[download]