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/
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/
| [reply] [Watch: Dir/Any] [d/l] |
|
Works nice and fast. I get an errorDeep 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
| [reply] [Watch: Dir/Any] |
|
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.
| [reply] [Watch: Dir/Any] [d/l] |
|
Excellent! :-) This also appears to make it run slightly faster.
| [reply] [Watch: Dir/Any] |
|
|