Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl: the Markov chain saw
 
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 cooling their heels in the Monastery: (4)
As of 2014-11-23 04:03 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My preferred Perl binaries come from:














    Results (128 votes), past polls