Beautiful (just like the original).
:) 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
RAINBOW_PAL and
calc_gradient()), 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
GD or any number of other output possibilities by just changing
init_and_make_updater() as well as
done().
#!/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_GRANULARI
+TY;
my $ginc = ($par{G}[$_ + 1] - $par{G}[$_]) / PALETTE_GRANULARI
+TY;
my $binc = ($par{B}[$_ + 1] - $par{B}[$_]) / PALETTE_GRANULARI
+TY;
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);
Makeshifts last the longest.
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.