Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl-Sensitive Sunglasses
 
PerlMonks  

Re: Linear Fractal Generator

by Aristotle (Chancellor)
on Jan 25, 2003 at 20:34 UTC ( #229880=note: print w/ replies, xml ) Need Help??


in reply to Linear Fractal Generator

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.


Comment on Re: Linear Fractal Generator
Download Code
Re: Re: Linear Fractal Generator
by Monkey_Sc (Initiate) on Mar 14, 2003 at 05:02 UTC
    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;

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://229880]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others having an uproarious good time at the Monastery: (8)
As of 2015-07-02 23:34 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (47 votes), past polls