use strict;
use warnings;
use Tk;
use Tk::Canvas;
use List::Util qw(min max);

my $kMaxRadius = 400;
my $kMinRadius = 50;
my $kNumPoints = 1000;

run();


sub run {
    my $halfSteps = 20;
    my $halfWidth = 350;
    my ($spanAdj, @attractors) = calcAttractors(1 + rand 3, $halfWidth
+);
    my @points = genPoints($halfWidth, $kNumPoints);
    #my @points = genGrid($halfSteps, $halfWidth / $halfSteps);
    my @biasedPoints = biasPoints(\@attractors, $spanAdj, @points);

    my $margin     = 10;
    my $max        = 2 * $margin + $halfWidth * 2 - 1;
    my $mw = MainWindow->new(-title => "Biased random");
    my $canvas     = $mw->Canvas(-height => $max, -width => $max)->pac
+k();
    my $offset     = $margin + $halfWidth;

    plot($canvas, $offset, 'blue', @points);
    plot($canvas, $offset, 'red',  @biasedPoints);
    #plotAttractors($canvas, $offset, $max, @attractors);

    $mw->MainLoop();
}


sub calcAttractors {
    my ($num, $w2) = @_;
    my $width = 2 * $w2;
    my @attractors;
    my $adj = 1;

    for (1 .. $num) {
        my $x      = rand ($width) - $w2;
        my $y      = rand ($width) - $w2;
        my @edges  = ([$w2, $y], [-$w2, $y], [$x, $w2], [$x, -$w2]);
        my $radius = $kMinRadius + rand ($kMaxRadius - $kMinRadius);
        my @biases;

        push @biases, calcBias($_->[0], $_->[1], [$x, $y, $radius]) fo
+r @edges;
        my $maxBias = max(map {abs} @biases);

        $adj = max($adj, ($w2 + $maxBias) / $w2);
        push @attractors, [$x, $y, $radius];
    }

    return $adj, @attractors;
}


sub genPoints {
    my ($halfWidth, $numPoints) = @_;
    my $width = $halfWidth * 2;
    my @points;

    for (1 .. $numPoints) {
        push @points, [rand ($width) - $halfWidth, rand ($width) - $ha
+lfWidth];
    }

    return @points;
}


sub biasPoints {
    my ($attractors, $spanAdj, @inPoints) = @_;
    my @outPoints;

    return @inPoints if !$attractors || !@$attractors;

    for my $point (@inPoints) {
        my ($x, $y) = @$point;
        my $xOff;
        my $yOff;

        for my $atPt (@$attractors) {
            my ($xBias, $yBias) = calcBias($x, $y, $atPt);

            $xOff += $xBias;
            $yOff += $yBias;
        }

        push @outPoints,
            [$spanAdj * $point->[0] + $xOff, $spanAdj * $point->[1] + 
+$yOff];
    }

    return @outPoints;
}


sub calcBias {
    my ($x, $y, $point, $spanAdj) = @_;
    my ($pX, $pY, $pRadius) = @$point;
    my $dX   = $pX - $x;
    my $dY   = $pY - $y;
    my $dist = sqrt ($dX**2 + $dY**2);

    my $scale = cos (1.5708 * min(1, $dist / $pRadius));

    return $dX * $scale, $dY * $scale;
}


sub genGrid {
    my ($halfSteps, $inc) = @_;
    my @points;

    for my $x (-$halfSteps .. $halfSteps) {
        for my $y (-$halfSteps .. $halfSteps) {
            push @points, [$x * $inc, $y * $inc];
        }
    }

    return @points;
}


sub plot {
    my ($canvas, $offset, $colour, @points) = @_;

    for my $point (@points) {
        my ($x, $y) = @$point;

        $x += $offset;
        $y += $offset;
        $canvas->createLine($x - 1, $y,     $x + 2, $y,     -fill => $
+colour);
        $canvas->createLine($x,     $y - 1, $x,     $y + 2, -fill => $
+colour);
    }
}

sub plotAttractors {
    my ($canvas, $offset, $max, @attractors) = @_;

    for my $point (@attractors) {
        my ($x, $y, $radius) = @$point;

        $radius /= 4;
        $radius ||= 1;
        $x += $offset;
        $y += $offset;
        $canvas->createLine(
            max($x - $radius, 1),
            $y, min($x + $radius + 1, $max),
            $y, -fill => 'green'
        );
        $canvas->createLine(
            $x, max($y - $radius, 1),
            $x,
            min($y + $radius + 1, $max),
            -fill => 'green'
        );
    }
}
[download]