Re: Spleenwort Fern Fractal viewer in Tk

[Chady]

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/

[zentara]

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.

[terra incognita]

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.

[terra incognita]

Excellent! :-) This also appears to make it run slightly faster.