Greetings fellow monks,
I present to you the program that made the fractal on my home node. It was inspired by the C Curve xscreensaver written by Rick Campbell. Right now it's set to generate the same fractal as on my home node, but you can change it around by messing with @Lines and @Points under Settings. $Epsilon is the minimum width/height a line must be to get processed in the next iteration (otherwise, it'd be wasting processing power on lines too small to see, which would be pointless).
#!/usr/bin/perl
use warnings;
use strict;
use Tk;
############
# Settings #
############
my $Epsilon = 6;
my $Delay = .5;
my @Lines = ([100, 240, 540, 240]);
my @Points = map $_/100, (
( 0, 0),
( 10, 20),
( 90, -20),
(100, 0),
);
# The expression that generates @Colors looks pretty ugly, but
# it's actually the shortest method I could think of for generating
# a rainbow in RGB.
my @Colors = map sprintf('#%02x%02x%02x', @$_), map [
$_<=256 ? 255 :
$_<512 ? 512 - $_ :
$_<768 ? 0 :
$_<1024 ? 0 :
$_<1280 ? $_ - 1024 :
255,
$_<256 ? $_ :
$_<512 ? 255 :
$_<=768 ? 255 :
$_<1024 ? 1024 - $_ :
$_<1280 ? 0 :
0,
$_<256 ? 0 :
$_<512 ? 0 :
$_<768 ? $_ - 512 :
$_<1024 ? 255 :
$_<=1280 ? 255 :
1536 - $_,
], (0..1536);
###########
# Widgets #
###########
my $Main = new Tk::MainWindow;
$Main->Label('-textvariable'=>\(my $Status="Initializing..."))->pack;
my $Canvas = $Main->Canvas(
'-width'=>640,
'-height'=>480,
'-background'=>'black'
)->pack;
my @LineItems = map $Canvas->createLine(@$_,'-fill'=>'white'), @Lines;
#############
# Main Loop #
#############
while (++our $i) {
$Status = "Iteration $i...";
my $LinesAffected = 0;
my $Color = 0;
my $ColorIncrement = (@Colors / @Lines) / (@Points/2 - 1);
for (my $Line=0;$Line<=@Lines-1;$Line++) {
my @Line = @{$Lines[$Line]};
$Canvas->Exists ? $Canvas->delete($LineItems[$Line]) : exit;
my $Size1 = abs($Line[2]-$Line[0]);
my $Size2 = abs($Line[3]-$Line[1]);
if ($Size1>$Epsilon or $Size2>$Epsilon) {
$LinesAffected++;
my @NewLines;
my @NewItems;
for (my $Point=0;$Point<$#Points-1;$Point+=2) {
my ($X1, $Y1, $X2, $Y2) = @Line;
push @NewLines, my $NewLine = [
$X1+($X2-$X1)*$Points[$Point+0] +
($Y2-$Y1)*$Points[$Point+1],
$Y1+($Y2-$Y1)*$Points[$Point+0] -
($X2-$X1)*$Points[$Point+1],
$X1+($X2-$X1)*$Points[$Point+2] +
($Y2-$Y1)*$Points[$Point+3],
$Y1+($Y2-$Y1)*$Points[$Point+2] -
($X2-$X1)*$Points[$Point+3]
];
push @NewItems, $Canvas->Exists ? $Canvas->createLine(
@$NewLine, '-fill' => $Colors[$Color]
) : exit;
$Color += $ColorIncrement;
}
splice(@Lines,$Line,1,@NewLines);
splice(@LineItems,$Line,1,@NewItems);
$Line += $#NewLines;
} else {
$LineItems[$Line] = $Canvas->Exists ? $Canvas->createLine(
@Line, '-fill' => $Colors[$Color]
) : exit;
$Color += $ColorIncrement * (@Points/2 - 1);
}
$Main->Exists ? $Main->update : exit;
}
$Main->Exists ? $Main->update : exit;
last unless $LinesAffected;
select(undef,undef,undef,$Delay); # (A cute idiom for hires sleep)
}
$Status = "Done.";
MainLoop;
For starters, try replacing @Points with one of these sets:
__END__
( 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),
-BronzeWing
Re: Linear Fractal Generator
by Aristotle (Chancellor) on Jan 25, 2003 at 20:34 UTC
|
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. | [reply] [Watch: Dir/Any] [d/l] |
|
i edited BronzeWing's code and made it faster so it still has a cool update effect(as long as line 72 is not commeted). it's faster than Aristotle's code when line 72 is commeted out and almost as fast when its not commeted out
#!/usr/bin/perl -w
use strict;
use Tk;
############
# Settings #
############
my $Epsilon = 8;
my @Lines = ([200, 300, 600, 300]);
my @Points = map $_/90, (
#my design best with 90 for @Points
(-20,20),
(20,10),
(90,-10),
(120,20),
#original design best with 96 for @Points
#( 0, 0),
#( 10, 20),
#( 90, -20),
#(100, 0),
);
#you can put your own colors here
sub randomc {
my $i = rand(2);
if ($i>=0 && $i<1) {return '#b10000';}
if ($i>=1 && $i<2) {return '#b15128';}
}
###########
# Widgets #
###########
my $Main = new Tk::MainWindow;
$Main->Label('-textvariable'=>\(my $Status="Initializing..."))->pack;
my $Canvas = $Main->Canvas(
'-width'=>900,
'-height'=>700,
'-background'=>'#000000'
)->pack;
my @LineItems = @Lines;
#############
# Main Loop #
#############
$Main->update;
while (++our $i<10) { # change 10 if u need more
$Status = "Iteration $i...";
for (my $Line=0;$Line<=@Lines-1;$Line++) {
my @Line = @{$Lines[$Line]};
if (abs($Line[2]-$Line[0])>$Epsilon or abs($Line[3]-$Line[1])>
+$Epsilon) {
my @NewLines;
my @NewItems;
for (my $Point=0;$Point<$#Points-1;$Point+=2) {
my ($X1, $Y1, $X2, $Y2) = @Line;
push @NewLines, my $NewLine = [
$Line[0]+($Line[2]-$Line[0])*$Points[$Point+0] +
($Line[3]-$Line[1])*$Points[$Point+1],
$Line[1]+($Line[3]-$Line[1])*$Points[$Point+0] -
($Line[2]-$Line[0])*$Points[$Point+1],
$Line[0]+($Line[2]-$Line[0])*$Points[$Point+2] +
($Line[3]-$Line[1])*$Points[$Point+3],
$Line[1]+($Line[3]-$Line[1])*$Points[$Point+2] -
($Line[2]-$Line[0])*$Points[$Point+3]
];
push @NewItems, $Canvas->createLine(@$NewLine, '-fill'
+ => randomc());
}
splice(@Lines,$Line,1,@NewLines);
#$Line += $#NewLines;#good for some fractals not for others wi
+thout commet you need more iterations and update effect isnt as good
}
$Main->Exists ? $Main->update : exit; #with this line commeted
+ out its like Aristotle's Code
}
$Main->Exists ? $Main->update : exit;
last unless 2;
}
$Status = "Done.";
MainLoop;
| [reply] [Watch: Dir/Any] [d/l] |
|
|