Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
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 drinking their drinks and smoking their pipes about the Monastery: (7)
As of 2014-09-20 06:23 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    How do you remember the number of days in each month?











    Results (155 votes), past polls