Beefy Boxes and Bandwidth Generously Provided by pair Networks
Welcome to the Monastery
 
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.

Replies are listed 'Best First'.
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?
[marto]: LanX I'd rather commit sudoku :P
[marto]: trench humour folks, feeling rough.
[marto]: there is never a night when they sleep all the way through, but last night was something else
[marto]: gave in at 3:45 ish and let Charlie watch videos about spitfires, the battle of Britain. He's plane crazy
[1nickt]: marto soothing!
[marto]: Hiromi makes an appearance, let's hope Jools doesn't ruin it by joining in on the old Joanna
[1nickt]: karlgoethebier What is the issue with the semic-colon after the ellipsis? It's documented as proper syntax ...;
[karlgoethebier]: Crazy? What should i say? Son just started his third studies. Next week i have a session with my therapist ;-)
[marto]: and just as I type that, the boys begin playing the piano, the price I pay for using cockney slang :P

How do I use this? | Other CB clients
Other Users?
Others drinking their drinks and smoking their pipes about the Monastery: (6)
As of 2017-11-18 18:56 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    In order to be able to say "I know Perl", you must have:













    Results (277 votes). Check out past polls.

    Notices?