A little late to the party, but maybe interesting. The following code generates a random set of "attractors" which tend to suck near by randomly generated points closer to the attractor. Attractors have a radius which limits their effect. Nearby attractors fight with each other which results in oddly shaped clumping, which is most likely a desirable outcome.
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'
);
}
}
The script above plots results using Tk and includes a little commented out code that was used while tuning the code. At present both the original points and the biased points are plotted.