Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked
 
PerlMonks  

Spleenwort Fern Fractal viewer in Tk

by terra incognita (Pilgrim)
on Oct 29, 2004 at 21:11 UTC ( [id://403910]=CUFP: print w/replies, xml ) Need Help??

After reading 392785 I undertook the challenge to create a fern fractal (although it is not a obfu). I was quite unhappy with my initial version using ASCII text so I took the plunge into my first Tk project and re-wrote it. After discovering how easy it is to create graphics in Tk I added the ability for colours and Sierpinski's Gasket and Carpet fractals.

Comments on where I can improve this code and what practices I should stay away from are appreciated. I am sure there are lots of optimizations or improvements that can be done.

Strict is turned off, because it prevents the subroutine reference on line 104. :-( I will be searching the site for a way to enable this with strict and if I can't find it I will post a cut down quesiton on SOPW.
use warnings; #use strict; use Tk; use Tk::BrowseEntry; use Tk::Optionmenu; use Tk::Dialog; # references srand (time); my $max_x = 500; my $max_y = 500; my $subname; my $main = new MainWindow(-title => 'Fractal Generator', -height => $m +ax_y + 25, -width => $max_x ); my $canvas = $main->Canvas(-height => $max_y, -width => $max_x, -backg +round=>'black' )->pack(-side =>'bottom'); my $frame = $main->Frame(-height => 1, -width => 500)->pack(-side =>'t +op'); my $frac_type; my $interations = $main->Optionmenu( -options => ["Spleenwort Fern","Sierpinski's Gasket","Sierpinski's + Carpet"], -variable => \$frac_type, )->pack(-side=> "left",); my $int_num; $interations = $main->Optionmenu( -options => [qw/5000 10000 20000 30000 40000 50000 75000 100000/], -variable => \$int_num, )->pack(-side=> "left",); my $colour; my $randflag; my @colourarray = ("grey","red", "orange", "yellow", "green", "blue", +"violet", "purple", "random"); my $colourlist = $main->Optionmenu( -options => \@colourarray, -command => sub { $randflag = 0; if ($colour eq "random") {$randflag = 1}}, -variable => \$colour, )->pack(-side=> "left",); $main->Button( -text => " Exit ", -command => \&exit )->pack(-side =>" +right"); $main->Button(-text => 'Create', -command=> sub{ $canvas->delete ("all"); create($canvas); })->pack(-side => 'right',-padx => 25); #$main->waitVisibility; MainLoop; # SUB LAND sub create { my( $canvas) = @_; my $count = 1; my $x; my $y; my $scaleby = 1; my $makexpos = $max_x; my $makeypos = $max_y; my $xlinevalue = 1; my $ylinevalue = 1; if ($int_num >= 30000) { my $dialog = $main->Dialog(-bitmap => 'question', -title => 'C +onfirm Iterations',-text => "$int_num Iterations may take a while to +complete. Would you like to continue?",-default_button => 'Yes', -but +tons => [qw/Yes No/]); my $answer = $dialog->Show; if ($answer eq "No") { return; } } $main->Busy(-recurse => 1); if ($frac_type eq "Spleenwort Fern") { $x = 1; $y = 1; $subname = "s_fern"; $scaleby = 10; # reduce it by 10 times $makexpos = 2; # shift the image to middle of canvas }elsif($frac_type eq "Sierpinski's Gasket"){ $x = 40; $y = 400; $subname = "sier_gasket"; }elsif($frac_type eq "Sierpinski's Carpet"){ $x = 40; $y = 400; $subname = "sier_carpet"; } create_dot($canvas, $x, $y, $count, $scaleby, $makexpos, $makeypos +, $xlinevalue, $ylinevalue); } sub create_dot { my( $canvas, $x, $y, $count,$scaleby, $makexpos, $makeypos, $xline +value, $ylinevalue) = @_; $count ++; if ($count > $int_num){ $main->Unbusy; if ($randflag == 1) { $colour = "random"; } return; } ($x, $y) = $subname ->($x , $y ); my $newx = ($x * ($max_x/$scaleby)) + ($max_x/$makexpos); my $newy = ($y * ($max_y/$scaleby)) + ($max_y/$makeypos); if ($randflag == 1) { my $currentcolour = int rand (7); $colour = $colourarray[$currentcolour]; } $canvas->createLine($newx,$newy ,($newx + $xlinevalue),($newy + $y +linevalue),-fill=> $colour); create_dot($canvas, $x, $y, $count, $scaleby, $makexpos, $makeypos +, $xlinevalue, $ylinevalue); } sub s_fern { my( $x, $y) = @_; my $x1; my $y1; my $c; my ($v1, $v2, $v3, $v4, $v5, $v6); $c = int(rand(100)); if ($c < 85) { $v1 = 0.85, $v2 = 0.04, $v3 = 0; $v4 = -0.04, $v5 = 0.85, $v6 = 1.60; }elsif ($c < 91){ $v1 = 0.20, $v2 = -0.26, $v3 = 0; $v4 = 0.23, $v5 = 0.22, $v6 = 1.60; }elsif ($c < 98){ $v1 = -0.15, $v2 = 0.28, $v3 = 0; $v4 = 0.26, $v5 = 0.24, $v6 = 0.44; }else{ $v1 = 0, $v2 = 0, $v3 = 0; $v4 = 0, $v5 = 0.16, $v6 = 0; } $x1 = $v1 * $x + $v2 * $y + $v3; $y1 = $v4 * $x + $v5 * $y + $v6; return $x1, $y1; } sub sier_gasket { my( $x, $y) = @_; my $x1; my $y1; my $c = 0; my @iterative_set = ( sub{ my @pt = (0,0); return( ($pt[0] + $_[0] )/2, ( $pt[1] + $_[1] )/2 ) }, sub{ my @pt = (1,0); return( ($pt[0] + $_[0] )/2, ( $pt[1] + $_[1] )/2 ) }, sub{ my @pt = (.5,1); return( ($pt[0] + $_[0] )/2, ( $pt[1] + $_[1] )/2 ) }, ); # weed out transients while( $c++ != 100 ) { ( $x1, $y1 ) = $iterative_set[ int rand 3 ]->( $x, $y ); return $x1, $y1; } } sub sier_carpet { my( $x, $y) = @_; my $x1; my $y1; my $c = 0; my @iterative_set = ( sub{ my @pt = (0,0); return( ($pt[0] + $_[0] )/3, ( $pt[1] + $_[1] )/3 ) }, sub{ my @pt = (2,0); return( ($pt[0] + $_[0] )/3, ( $pt[1] + $_[1] )/3 ) }, sub{ my @pt = (2,2); return( ($pt[0] + $_[0] )/3, ( $pt[1] + $_[1] )/3 ) }, sub{ my @pt = (0,2); return( ($pt[0] + $_[0] )/3, ( $pt[1] + $_[1] )/3 ) }, sub{ my @pt = (1,0); return( ($pt[0] + $_[0] )/3, ( $pt[1] + $_[1] )/3 ) }, sub{ my @pt = (1,2); return( ($pt[0] + $_[0] )/3, ( $pt[1] + $_[1] )/3 ) }, sub{ my @pt = (2,1); return( ($pt[0] + $_[0] )/3, ( $pt[1] + $_[1] )/3 ) }, sub{ my @pt = (0,1); return( ($pt[0] + $_[0] )/3, ( $pt[1] + $_[1] )/3 ) }, ); # weed out transients while( $c++ != 100 ) { ( $x1, $y1 ) = $iterative_set[ int rand 8 ]->( $x, $y ); return $x1, $y1; } } # References # # Sierpinski fractal algorithms copied from # http://www.perlmonks.com/?node_id=337175 # # Other fractal algorithms and all values copied from # http://www.cs.wisc.edu/~richm/cs302s00/applets/

Replies are listed 'Best First'.
Re: Spleenwort Fern Fractal viewer in Tk
by Chady (Priest) on Oct 30, 2004 at 09:03 UTC

    I didn't look at all the code, but I made it pass use strict by using a dispatch table that holds references to the subroutines to call. I tried to keep my change as minimal as possible.

    use warnings; use strict; use Tk; use Tk::BrowseEntry; use Tk::Optionmenu; use Tk::Dialog; # references srand (time); my $max_x = 500; my $max_y = 500; my $subname; my %subs = ( s_fern => \&s_fern, sier_gasket => \&sier_gasket, sier_carpet => \&sier_carpet ); my $main = new MainWindow(-title => 'Fractal Generator', -height => $m +ax_y + 25, -width => $max_x ); my $canvas = $main->Canvas(-height => $max_y, -width => $max_x, -backg +round=>'black' )->pack(-side =>'bottom'); my $frame = $main->Frame(-height => 1, -width => 500)->pack(-side =>'t +op'); my $frac_type; my $interations = $main->Optionmenu( -options => ["Spleenwort Fern","Sierpinski's Gasket","Sierpinski's + Carpet"], -variable => \$frac_type, )->pack(-side=> "left",); my $int_num; $interations = $main->Optionmenu( -options => [qw/5000 10000 20000 30000 40000 50000 75000 100000/], -variable => \$int_num, )->pack(-side=> "left",); my $colour; my $randflag; my @colourarray = ("grey","red", "orange", "yellow", "green", "blue", +"violet", "purple", "random"); my $colourlist = $main->Optionmenu( -options => \@colourarray, -command => sub { $randflag = 0; if ($colour eq "random") {$randflag = 1}}, -variable => \$colour, )->pack(-side=> "left",); $main->Button( -text => " Exit ", -command => \&exit )->pack(-side =>" +right"); $main->Button(-text => 'Create', -command=> sub{ $canvas->delete ("all"); create($canvas); })->pack(-side => 'right',-padx => 25); #$main->waitVisibility; MainLoop; # SUB LAND sub create { my( $canvas) = @_; my $count = 1; my $x; my $y; my $scaleby = 1; my $makexpos = $max_x; my $makeypos = $max_y; my $xlinevalue = 1; my $ylinevalue = 1; if ($int_num >= 30000) { my $dialog = $main->Dialog(-bitmap => 'question', -title => 'C +onfirm Iterations',-text => "$int_num Iterations may take a while to +complete. Would you like to continue?",-default_button => 'Yes', -but +tons => [qw/Yes No/]); my $answer = $dialog->Show; if ($answer eq "No") { return; } } $main->Busy(-recurse => 1); if ($frac_type eq "Spleenwort Fern") { $x = 1; $y = 1; $subname = "s_fern"; $scaleby = 10; # reduce it by 10 times $makexpos = 2; # shift the image to middle of canvas }elsif($frac_type eq "Sierpinski's Gasket"){ $x = 40; $y = 400; $subname = "sier_gasket"; }elsif($frac_type eq "Sierpinski's Carpet"){ $x = 40; $y = 400; $subname = "sier_carpet"; } create_dot($canvas, $x, $y, $count, $scaleby, $makexpos, $makeypos +, $xlinevalue, $ylinevalue); } sub create_dot { my( $canvas, $x, $y, $count,$scaleby, $makexpos, $makeypos, $xline +value, $ylinevalue) = @_; $count ++; if ($count > $int_num){ $main->Unbusy; if ($randflag == 1) { $colour = "random"; } return; } ($x, $y) = $subs{$subname}->($x , $y ); my $newx = ($x * ($max_x/$scaleby)) + ($max_x/$makexpos); my $newy = ($y * ($max_y/$scaleby)) + ($max_y/$makeypos); if ($randflag == 1) { my $currentcolour = int rand (7); $colour = $colourarray[$currentcolour]; } $canvas->createLine($newx,$newy ,($newx + $xlinevalue),($newy + $y +linevalue),-fill=> $colour); create_dot($canvas, $x, $y, $count, $scaleby, $makexpos, $makeypos +, $xlinevalue, $ylinevalue); } sub s_fern { my( $x, $y) = @_; my $x1; my $y1; my $c; my ($v1, $v2, $v3, $v4, $v5, $v6); $c = int(rand(100)); if ($c < 85) { $v1 = 0.85, $v2 = 0.04, $v3 = 0; $v4 = -0.04, $v5 = 0.85, $v6 = 1.60; }elsif ($c < 91){ $v1 = 0.20, $v2 = -0.26, $v3 = 0; $v4 = 0.23, $v5 = 0.22, $v6 = 1.60; }elsif ($c < 98){ $v1 = -0.15, $v2 = 0.28, $v3 = 0; $v4 = 0.26, $v5 = 0.24, $v6 = 0.44; }else{ $v1 = 0, $v2 = 0, $v3 = 0; $v4 = 0, $v5 = 0.16, $v6 = 0; } $x1 = $v1 * $x + $v2 * $y + $v3; $y1 = $v4 * $x + $v5 * $y + $v6; return $x1, $y1; } sub sier_gasket { my( $x, $y) = @_; my $x1; my $y1; my $c = 0; my @iterative_set = ( sub{ my @pt = (0,0); return( ($pt[0] + $_[0] )/2, ( $pt[1] + $_[1] )/2 ) }, sub{ my @pt = (1,0); return( ($pt[0] + $_[0] )/2, ( $pt[1] + $_[1] )/2 ) }, sub{ my @pt = (.5,1); return( ($pt[0] + $_[0] )/2, ( $pt[1] + $_[1] )/2 ) }, ); # weed out transients while( $c++ != 100 ) { ( $x1, $y1 ) = $iterative_set[ int rand 3 ]->( $x, $y ); return $x1, $y1; } } sub sier_carpet { my( $x, $y) = @_; my $x1; my $y1; my $c = 0; my @iterative_set = ( sub{ my @pt = (0,0); return( ($pt[0] + $_[0] )/3, ( $pt[1] + $_[1] )/3 ) }, sub{ my @pt = (2,0); return( ($pt[0] + $_[0] )/3, ( $pt[1] + $_[1] )/3 ) }, sub{ my @pt = (2,2); return( ($pt[0] + $_[0] )/3, ( $pt[1] + $_[1] )/3 ) }, sub{ my @pt = (0,2); return( ($pt[0] + $_[0] )/3, ( $pt[1] + $_[1] )/3 ) }, sub{ my @pt = (1,0); return( ($pt[0] + $_[0] )/3, ( $pt[1] + $_[1] )/3 ) }, sub{ my @pt = (1,2); return( ($pt[0] + $_[0] )/3, ( $pt[1] + $_[1] )/3 ) }, sub{ my @pt = (2,1); return( ($pt[0] + $_[0] )/3, ( $pt[1] + $_[1] )/3 ) }, sub{ my @pt = (0,1); return( ($pt[0] + $_[0] )/3, ( $pt[1] + $_[1] )/3 ) }, ); # weed out transients while( $c++ != 100 ) { ( $x1, $y1 ) = $iterative_set[ int rand 8 ]->( $x, $y ); return $x1, $y1; } } # References # # Sierpinski fractal algorithms copied from # http://www.perlmonks.com/?node_id=337175 # # Other fractal algorithms and all values copied from # http://www.cs.wisc.edu/~richm/cs302s00/applets/

    He who asks will be a fool for five minutes, but he who doesn't ask will remain a fool for life.
    Chady | http://chady.net/
    Are you a Linux user in Lebanon? join the Lebanese Linux User Group.
      Works nice and fast. I get an error

      Deep recursion on subroutine "main::create_dot" at ./tk-fern-fractal line 119.

      when I create any sample. I don't know if it's serious, just mentioning it. I don't mind seeing warnings myself.


      I'm not really a human, but I play one on earth. flash japh
        Opps. I accidentally posted the version with warnings enabled. Thanks for pointing it out, and motivating me to actually check that it is not an issue (Whew). :-)

        Here is an excerpt from perldiag that explains the warning, and why it is surfaced.

        Deep recursion on subroutine ``%s'' (W recursion) This subroutine has called itself (directly or indirectly) 100 times more than it has returned. This probably indicates an infinite recursion, unless you're writing strange benchmark programs, in which case it indicates something else.
      Excellent! :-) This also appears to make it run slightly faster.

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: CUFP [id://403910]
Approved by kvale
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others chanting in the Monastery: (3)
As of 2024-03-29 02:04 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found