Beefy Boxes and Bandwidth Generously Provided by pair Networks Cowboy Neal with Hat
Just another Perl shrine
 
PerlMonks  

Linear Fractal Generator

by BronzeWing (Monk)
on Jan 17, 2003 at 21:31 UTC ( #227805=CUFP: print w/ replies, xml ) Need Help??

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

Comment on Linear Fractal Generator
Select or Download Code
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.

      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: CUFP [id://227805]
Approved by gjb
Front-paged by Mr. Muskrat
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others about the Monastery: (12)
As of 2014-04-21 12:55 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    April first is:







    Results (495 votes), past polls