Beefy Boxes and Bandwidth Generously Provided by pair Networks
No such thing as a small change
 
PerlMonks  

Re: Spleenwort Fern Fractal viewer in Tk

by Chady (Priest)
on Oct 30, 2004 at 09:03 UTC ( #403985=note: print w/ replies, xml ) Need Help??


in reply to Spleenwort Fern Fractal viewer in Tk

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.


Comment on Re: Spleenwort Fern Fractal viewer in Tk
Download Code
Re^2: Spleenwort Fern Fractal viewer in Tk
by zentara (Archbishop) on Oct 30, 2004 at 11:03 UTC
    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.
Re^2: Spleenwort Fern Fractal viewer in Tk
by terra incognita (Pilgrim) on Nov 01, 2004 at 16:15 UTC
    Excellent! :-) This also appears to make it run slightly faster.

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://403985]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others exploiting the Monastery: (8)
As of 2014-11-23 02:38 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My preferred Perl binaries come from:














    Results (127 votes), past polls