note
Aristotle
Beautiful (just like the original). <tt>:)</tt> I had a few idle moments, so I sat down and cleaned it up a bit. It started out mainly as a cleanup of the rainbow palette generation (which is now in <tt>RAINBOW_PAL</tt> and <tt>calc_gradient()</tt>), but grew to a complete reorganization. It does not, I'm afraid, have the neat update-as-you-calculate effect anymore, but the upside is faster runtime - and it is pretty easy to port to a different windowing system, a console-only version that outputs a PNG via [cpan://GD] or any number of other output possibilities by just changing <tt>init_and_make_updater()</tt> as well as <tt>done()</tt>.
<code>
#!/usr/bin/perl -w
use strict;
use Tk;
###### SETTINGS ######
use constant EPSILON => 6;
use constant SET_NR => 0;
use constant INITIAL_LINE => ([100, 240, 540, 240]);
use constant POINT_SET => (
[
[ 0, 0],
[ 10, 20],
[ 90, -20],
[100, 0],
],
[
[ 0, 0],
[ 50, 29],
[ 50, -29],
[100, 0],
],
[
[ 0, 0],
[ 50, 0],
[ 50, 50],
[ 50, 0],
[100, 0],
],
[
[ 0, 0],
[ 30, 0],
[ 50, 30],
[ 70, 0],
[100, 0],
],
);
use constant RAINBOW_PAL => (
R => [255 => 255 => 0 => 0 => 255 => 255],
G => [ 0 => 255 => 255 => 255 => 0 => 0],
B => [ 0 => 0 => 255 => 255 => 255 => 0],
);
###### FUNCTIONS ######
use constant X => 0;
use constant Y => 1;
use constant PALETTE_GRANULARITY => 255;
sub calc_gradient {
my %par = @_;
my @pal;
for(0 .. $#{$par{R}}-1) {
my $rlum = $par{R}[$_];
my $glum = $par{G}[$_];
my $blum = $par{B}[$_];
my $rinc = ($par{R}[$_ + 1] - $par{R}[$_]) / PALETTE_GRANULARITY;
my $ginc = ($par{G}[$_ + 1] - $par{G}[$_]) / PALETTE_GRANULARITY;
my $binc = ($par{B}[$_ + 1] - $par{B}[$_]) / PALETTE_GRANULARITY;
push @pal, map sprintf('#%02x%02x%02x',
$rlum + $rinc * $_,
$glum + $ginc * $_,
$blum + $binc * $_,
), 0 .. PALETTE_GRANULARITY;
}
return \@pal;
}
my @pt = map [ map $_/100, @$_], @{(POINT_SET)[SET_NR]};
sub iterate_lines { map {
my ($X1, $Y1, $X2, $Y2) = @$_;
(abs($Y2 - $Y1)>EPSILON or abs($X2 - $X1)>EPSILON)
? map [
$X1+($X2-$X1)*$pt[$_][X]
+($Y2-$Y1)*$pt[$_][Y],
$Y1+($Y2-$Y1)*$pt[$_][X]
-($X2-$X1)*$pt[$_][Y],
$X1+($X2-$X1)*$pt[$_+1][X]
+($Y2-$Y1)*$pt[$_+1][Y],
$Y1+($Y2-$Y1)*$pt[$_+1][X]
-($X2-$X1)*$pt[$_+1][Y],
], 0 .. $#pt - 1
: $_;
} @_ }
sub init_and_make_updater {
my @pal = @{+shift};
my $window = Tk::MainWindow->new;
my $label = "";
$window->Label(-textvariable => \$label)->pack;
my $canvas = $window->Canvas(
-width => 640,
-height => 480,
-background => 'black',
)->pack;
my $lines;
return sub {
($label, $lines) = @_;
if(defined $lines) {
my $inc = @pal / @$lines;
my $idx = -$inc;
$canvas->delete('all');
$canvas->createLine(@$_, -fill => $pal[$idx += $inc]) for @$lines;
}
$window->update;
}
}
sub done {
MainLoop;
}
###### MAIN PROGRAM ######
my $update = init_and_make_updater(calc_gradient(RAINBOW_PAL));
$update->("Initializing...");
my @lines = INITIAL_LINE;
my $lines_previously = 0;
my $iter = 0;
until($lines_previously == @lines) {
$lines_previously = @lines;
$iter++;
@lines = iterate_lines @lines;
$update->("Iteration $iter...", \@lines);
}
$update->("Done.");
done(\@lines);
</code>
<p align="right"><em>Makeshifts last the longest.</em></p>
227805
227805