use warnings;
use strict;
use List::Compare;
use Storable qw(dclone);
use Tk;

use constant kMaxFrac => 0.75;

my @colours = (
    '#ff8080', '#ff0000', '#8080ff', '#e08080', '#ffffff',
    '#80ffff', '#ffff80', '#e06080', '#808080',
    );

my @sizes = (
    [300, 300], [450, 300], [450, 450], [600, 450], [600, 600],
    [600, 300], [750, 600], [750, 750], [900, 900]
    );
my %lengths;

$lengths{$_->[0]}++, $lengths{$_->[1]}++ for @sizes;

my @factors = map {[factors ($_)]} keys %lengths;
my @commonFactors = findCommon (@factors);
my $gcd = 1;
my $type = 1;

$gcd *= $_ for @commonFactors;

@sizes = map {[@$_, $type++]} @sizes;

my @rectangles = grep {$_->[0] != $_->[1]} @sizes;
my @tiles = (@sizes, map {[$_->[1], $_->[0], $_->[2]]} @rectangles);

@tiles = sort {$a->[0] <=> $b->[0]} map {[$_->[0] / $gcd, $_->[1] / $g
+cd, $_->[2]]} @tiles;

while (<DATA>) {
    my ($pw, $ph) = map {$_ * 1000} split /\s/;
    
    $_ = $gcd * int (($_ + $gcd - 1) / $gcd) for ($pw, $ph);
    
    print "Rounded dimensions are $pw mm x $ph mm\n";
    $_ /= $gcd for ($pw, $ph);
    
    my $area = $pw * $ph;
    my $nextTileCode = 0;
    my @stockList;
    my @corners = [0, 0];
    my @tileList;
    my @row = (0) x $pw;
    my @patio;
    
    for my $tile (@tiles) {
        my ($x, $y) = @$tile;
        my $count = ($area / ($x * $y));
        
        $count /= 2 if $x != $y;
        push @stockList, ($nextTileCode++) x $count;
    }

    push @patio, [@row] for 1 .. $ph;
    
    if (! placeTiles (0, 0, \@stockList, \@tileList, \@patio)) {
        print "Didn't find a suitable placement pattern.\n";
        next;
    }

    # Display the result
    my $mw = MainWindow->new;
    my $topframe = $mw->Frame(-bg=>'black')->pack(-fill=>'x');
    $_ *= $gcd / 1000 for ($pw, $ph);
    
    $topframe->Label(-text=>"X-Y = $pw - $ph (rounded)",
        -bg => 'black',
        -fg => 'lightblue',
        )->pack(-side=>'left');
    
    print "X,\tY,\tType\n";

    my $S_canvas = $mw->Scrolled('Canvas',
        -width => $pw * 100, -height => $ph * 100 + 10,
        -bg => 'black',
        -borderwidth => 3,
        -relief => 'sunken',
        -scrollbars => 'osoe',
        )->pack(-expand => 1, -fill =>'both');
    
    my $canvas = $S_canvas->Subwidget('scrolled');
    for (@tileList) {
        $_ *= $gcd for ($_->[0], $_->[1], $_->[3], $_->[4]);
    };
    
    for (@tileList) {
        my ($x, $y, $type) = @$_;
        my ($w, $h, $sizeType) = @{$tiles[$type]};
   
        $_ *= $gcd for ($w, $h); 
        print "$x,\t$y,\t$sizeType ($w x $h)\n" ;
        $_ /= 10 for ($x, $y, $w, $h);

        $canvas->createRectangle(
            $x, $y, $x + $w, $y + $h,
            -fill => $colours[$sizes[$sizeType - 1][2] - 1],
            -tags => ['paver'],
            );
    }
    
    MainLoop;
}


sub placeTiles {
    my ($x, $y, $stockList, $tileList, $patio) = @_;
    my $height = @$patio;
    my $width = @{$patio->[0]};
    my @availTiles = @$stockList;
    my $tile;
    
    TILE: while (@availTiles) {
        # Select a tile
        $tile = $availTiles[rand @availTiles];

        # Remove selected tile type from available list
        @availTiles = grep {$_ != $tile} @availTiles;
        
        # Try placing the tile
        my ($tw, $th) = @{$tiles[$tile]}[0..1];
        push @$tileList, [$x, $y, $tile, $tw, $th];
    
        next if $x + $tw > $width;
        next if $y + $th > $height;
        next if ! placeTile ($tileList, $patio);

        next if badEdge ($width, $height, $tileList, $patio);
        
        my $newX = $x;
        my $newY = $y;
        
        # Skip to next possible block insertion point
        if ($newX + $tileList->[-1][3] == $width) {
            # Move down a row
            $newX = 0;
            ++$newY;
        } else {
            $newX += $tileList->[-1][3];
        }

        # Scan for next block insertion point
        SEEK: while ($newY < $height) {
            while ($newX < $width) {
                last SEEK if ! $patio->[$newY][$newX];
                ++$newX;
            }
            
            $newX = 0;
            ++$newY;
        }

        if ($newY == $height) {
            next if badEdge ($width, $height, $tileList, $patio);
            return 1; # Placed last tile, done
        }

        # Fill remaining area. Done if ok
        return 1 if placeTiles ($newX, $newY, $stockList, $tileList, $
+patio);
    } continue {
        # Failed, back off and try again
        unplaceTile ($tileList, $patio);
        pop @$tileList;
    }

    return undef;
}


sub badEdge {
    my ($width, $height, $tileList, $patio) = @_;

    # Check for long horiz edges
    my @testTiles = sort {$a->[1] <=> $b->[1] || $a->[0] <=> $b->[0]} 
+@$tileList;
    my $lastEnd = 0;
    my $edge = 0;
    
    for my $tile (@testTiles) {
        next if $tile->[3] == $width; # Allow a full width block
        next if $tile->[1] == 0; # Skip blocks on the edge
        
        if ($tile->[0] != $lastEnd) {
            $edge = $tile->[3];
        } else {
            $edge += $tile->[3];
        }
        
        if ($edge > $width * kMaxFrac) {
            return 1;
        }
    } continue {
        $lastEnd = $tile->[0] + $tile->[3];
    }

    # Check for long vertical edges
    @testTiles = sort {$a->[0] <=> $b->[0] || $a->[1] <=> $b->[1]} @$t
+ileList;
    $lastEnd = 0;
    $edge = 0;
    
    for my $tile (@testTiles) {
        next if $tile->[4] == $height; # Allow a full heigth block
        next if $tile->[0] == 0; # Skip blocks on the edge
        
        if ($tile->[1] != $lastEnd || $tile->[1] < $lastEnd) {
            $edge = $tile->[4];
        } else {
            $edge += $tile->[4];
        }
        
        if ($edge > $height * kMaxFrac) {
            return 1;
        }
    } continue {
        $lastEnd = $tile->[1] + $tile->[4];
    }

    return undef;
}

sub placeTile {
    my ($tileList, $patio) = @_;
    my ($x, $y, $tile, $w, $h) = @{$tileList->[-1]};
    
    my $yEnd = $y + $h - 1;
    my $xEnd = $x + $w - 1;
    
    if ($yEnd > $#$patio  || $xEnd > $#{$patio->[0]}) {
        return undef;
    }
    
    # Check for collisions
    for my $yi ($y .. $yEnd) {
        for my $xi ($x .. $xEnd) {
            if ($patio->[$yi][$xi]) {
                return undef ;
            }
        }
    }
    
    # Paint the tile
    for my $yi ($y .. $yEnd) {
        ++$patio->[$yi][$_] for $x .. $xEnd;
    }
    
    return 1;
}


sub unplaceTile {
    my ($tileList, $patio) = @_;
    my ($x, $y, $tile, $w, $h) = @{$tileList->[-1]};

    if (! $patio->[$y][$x]) {
        return;
    }
    
    my $yEnd = $y + $h - 1;
    my $xEnd = $x + $w - 1;
    
    if ($yEnd > $#$patio  || $xEnd > $#{$patio->[0]}) {
        return undef;
    }
    
    for my $yi ($y .. $yEnd) {
        for my $xi ($x .. $xEnd) {
            --$patio->[$yi][$xi] if $patio->[$yi][$xi];
        }
    }
}


    {
    my @p;
    BEGIN {@p = (2, 3, 5, 7);}

    sub nextprime {
        my $p = $p[$#p];
        DIV: while (1) {
            $p += 2;
            my $pc = 0;
            while (1) {
                my $d = $p[$pc++];
                last if $d * $d > $p;
                next DIV unless $p % $d;
            }

            $p[@p] = $p;
            return $p;
        }
    }
    
    sub factors {
        my $n = shift;
        my $pc = 0;
        my @result;

        while ($n > 1) {
            my $d = $p[$pc++] || nextprime();
            if ($d * $d > $n) {
                push @result, $n;
                $n = 1;
            } else {
                while ($n % $d == 0) {
                    $n /= $d;
                    push @result, $d;
                }
            }
        }

        return @result;
    }
}


sub findCommon {
    my @lists = @_;
    my @common;
    
    while (@lists == grep {@$_} @lists) {
        my %hits;
        
        $hits{$_->[0]}++ for @lists;
        
        my $least = (sort keys %hits)[0];
        
        push @common, $least if $hits{$least} == @lists;
        $_->[0] eq $least && shift @$_ for @lists;
    }
    
    return @common;
}

__DATA__
1.5 1.2
[download]