in reply to Translating simplex noise code from java to perl

I've looked at this a bit, with an eye to making it handle higher dimensions, and one of the easy changes is that the F and G constants can be simplified and extended:

# Skewing and unskewing factors for 2, 3, and 4 dimensions
use constant {
   F2 => 0.5 * (sqrt(3.0) - 1.0),
   F3 => 1.0 / 3.0,
   F4 => (sqrt(5.0) - 1.0) / 4.0,
   G2 => (3.0 - sqrt(3.0)) / 6.0,
   G3 => 1.0 / 6.0,
   G4 => (5.0 - sqrt(5.0)) / 20.0,
};

[download]
to 
    F2 => (sqrt(3.0) - 1.0) / 2.0,
    F3 => (sqrt(4.0) - 1.0) / 3.0,
    F4 => (sqrt(5.0) - 1.0) / 4.0,
    G2 => (3.0 - sqrt(3.0)) / 6.0,  #/3*2
    G3 => (4.0 - sqrt(4.0)) / 12.0, #/4*3   #1.0 / 6.0,
    G4 => (5.0 - sqrt(5.0)) / 20.0, #/5*4

[download]
and thus to: 
sub FFactor
{
    my $numDimensions = shift;
    return sqrt($numDimensions+1) -1 / $numDimensions;
}
sub GFactor
{
    my $numDimensions = shift;
    return ($numDimensions+1 -sqrt($numDimensions+1))/($numDimensions*
+$numDimensions+1);
}

[download]

Playing around with 2D noise, stacking noise on multiple scales makes for really interesting pictures. I've tacked on a BMP output function to keep it all self-contained.

Example picture: http://imgur.com/aD6cQZ9

Image generation and BMP saving code below: 

my $N = 256;

my @pic = ();
for my $i (1 .. $N) 
{
    my $x = $i / 1;
    my @row = ();
    for my $j (1 .. $N) 
    {
        my $y = $j / 1;
        my $pixel;
        #$pixel = (((noise $x/$_, $y/$_)+ 1) / 2 * 256) for (512);
        $pixel = 1;
        
        #my $decay = .25;
        #$pixel = $pixel*(1-$decay) + (((noise $x/$_, $y/$_)+ 1) / 2 *
+ 256*$decay) for reverse (512, 128, 64, 16, );#4);
        $pixel *= (((noise $x/$_, $y/$_)+ 1) / 2) ** .5 for reverse (5
+12, 128, 64, 32, );#4);
        push @row, int($pixel*256);
    }
    push @pic, \@row;
}
BMP32bit('test.bmp', [0,$N-1,0,$N-1], \@pic, \@pic, \@pic);

sub BMP32bit
{
    my $filename = shift;
    my $coords = shift // [0,0,0,0];
    my @channels = @_[0..3];
    
    open my $outFH, '>', $filename or die "Can't open $filename for wr
+ite: $!\n";
    binmode $outFH;
    
    my ($top, $bottom, $left, $right) = (map {$_ // 0} @$coords);
    my ($width, $height) = (abs($left-$right)+1, abs($top-$bottom)+1);
    
    print "Image size ($width, $height)\n";
    
    my $filesize = 0x36 + $height*4 * $width; #scalar $image->{channel
+s}{red_top};
    # BMP Header
    print $outFH pack('A2LSSL', 'BM', $filesize, 0,0, 0x36);
    # DIB header
    print $outFH pack('LLLSSLLLLLL', 40, $width, $height , 1, 32, 0, $
+filesize-0x36, 7874, 7874, 0, 0); #7874 pixels per meter == 200 dpi
    
    for (0..3)
    {
        $channels[$_] = [] unless ref($channels[$_]) eq 'ARRAY';
    }
    
    
    for my $row ($top > $bottom ? ($bottom..$top) : (reverse $top..$bo
+ttom))
    {
        for my $col ( $left > $right ? ($right..$left) : (reverse $lef
+t..$right))
        {
            print $outFH  pack('C4',
                 $channels[0][$col][$row]//0,
                 $channels[1][$col][$row]//0,
                 $channels[2][$col][$row]//0,
                 $channels[3][$col][$row]//0xff,
                );
        }
    }
}

[download]

Replies are listed 'Best First'.
Re^2: Translating simplex noise code from java to perl
by SuicideJunkie (Vicar) on Apr 05, 2014 at 22:44 UTC

    Finally got it all working the same as the original!

    It works at multiple dimensions, although I don't know what the magic scaling factors should be for 1 dimension or 5+

    Read more... (11 kB)
[reply]
[d/l]

      Here's the code I wrote (as a result of the discussion in my thread: Randomly biased, random numbers.), to implement the Improved Perlin Noise algorithm. It also runs it with various scales to produce finer and finer detail:

      #! perl -slw
use strict;
use Data::Dump qw[ pp ]; $Data::Dump::WIDTH = 1e3;
use List::Util qw[ min max ];
use GD;
use constant { X => 0, Y=> 1, R => 2 };
use constant P => [
151,160,137,91,90,15,131,13,201,95,96,53,194,233,7,225,140,36,103,30,6
+9,142,
8,99,37,240,21,10,23,190,6,148,247,120,234,75,0,26,197,62,94,252,219,2
+03,117,
35,11,32,57,177,33,88,237,149,56,87,174,20,125,136,171,168,68,175,74,1
+65,71,
134,139,48,27,166,77,146,158,231,83,111,229,122,60,211,133,230,220,105
+,92,41,
55,46,245,40,244,102,143,54,65,25,63,161,1,216,80,73,209,76,132,187,20
+8,89,
18,169,200,196,135,130,116,188,159,86,164,100,109,198,173,186,3,64,52,
+217,
226,250,124,123,5,202,38,147,118,126,255,82,85,212,207,206,59,227,47,1
+6,58,17,
182,189,28,42,223,183,170,213,119,248,152,2,44,154,163,70,221,153,101,
+155,167,
43,172,9,129,22,39,253,19,98,108,110,79,113,224,232,178,185,112,104,21
+8,246,
97,228,251,34,242,193,238,210,144,12,191,179,162,241,81,51,145,235,249
+,14,239,
107,49,192,214,31,181,199,106,157,184,84,204,176,115,121,50,45,127,4,1
+50,254,
138,236,205,93,222,114,67,29,24,72,243,141,128,195,78,66,215,61,156,18
+0,
151,160,137,91,90,15,131,13,201,95,96,53,194,233,7,225,140,36,103,30,6
+9,142,
8,99,37,240,21,10,23,190,6,148,247,120,234,75,0,26,197,62,94,252,219,2
+03,117,
35,11,32,57,177,33,88,237,149,56,87,174,20,125,136,171,168,68,175,74,1
+65,71,
134,139,48,27,166,77,146,158,231,83,111,229,122,60,211,133,230,220,105
+,92,41,
55,46,245,40,244,102,143,54,65,25,63,161,1,216,80,73,209,76,132,187,20
+8,89,
18,169,200,196,135,130,116,188,159,86,164,100,109,198,173,186,3,64,52,
+217,
226,250,124,123,5,202,38,147,118,126,255,82,85,212,207,206,59,227,47,1
+6,58,17,
182,189,28,42,223,183,170,213,119,248,152,2,44,154,163,70,221,153,101,
+155,167,
43,172,9,129,22,39,253,19,98,108,110,79,113,224,232,178,185,112,104,21
+8,246,
97,228,251,34,242,193,238,210,144,12,191,179,162,241,81,51,145,235,249
+,14,239,
107,49,192,214,31,181,199,106,157,184,84,204,176,115,121,50,45,127,4,1
+50,254,
138,236,205,93,222,114,67,29,24,72,243,141,128,195,78,66,215,61,156,18
+0,
];

sub rgb2n{ local $^W; unpack 'N', pack 'CCCC', 0, @_ }

my $RED     = rgb2n( 255, 0, 0 );
my $GREEN   = rgb2n( 0, 255, 0 );
my $BLUE    = rgb2n( 0, 0, 255 );
my $YELLOW  = rgb2n( 255, 255, 0 );
my $MAGENTA = rgb2n( 255, 0, 255 );
my $CYAN    = rgb2n( 0, 255, 255 );
my $WHITE   = rgb2n( 255,255,255 );

sub r2pd {
    my( $x, $y, $cx, $cy ) = @_;
    return sqrt( ( $x - $cx )**2 + ( $y - $cy )**2 );
}

sub fade{ $_[0]**3 * ( $_[0] * ($_[0] * 6 - 15) + 10 ) }
sub lerp{ $_[1] + $_[0] * ($_[2] - $_[1]) }
sub grad{
    my( $hash, $x, $y, $z ) = @_;
    my $h = $hash & 15;
    my $u = $h < 8 ? $x : $y;
    my $v = $h < 4 ? $y : $h == 12 || $h ==14 ? $x : $z;
    return (( $h & 1 ) == 0 ? $u : -$u ) + (( $h & 2 ) == 0 ? $v : -$v
+ );
}
sub noise {
    my( $x, $y, $z ) = @_;
    my $X = int( $x ) & 255; $x -= int $x; my $u = fade( $x );
    my $Y = int( $y ) & 255; $y -= int $y; my $v = fade( $y );
    my $Z = int( $z ) & 255; $z -= int $z; my $w = fade( $z );

    my $A  = P->[$X  ]+$Y;
    my $AA = P->[$A  ]+$Z;
    my $AB = P->[$A+1]+$Z;
    my $B  = P->[$X+1]+$Y;
    my $BA = P->[$B  ]+$Z;
    my $BB = P->[$B+1]+$Z;

    return lerp( $w,
        lerp( $v,
            lerp( $u, grad( P->[$AA  ], $x, $y  , $z   ), grad( P->[$B
+A  ], $x-1, $y  , $z   ) ),
            lerp( $u, grad( P->[$AB  ], $x, $y-1, $z   ), grad( P->[$B
+B  ], $x-1, $y-1, $z   ) )
        ),
        lerp( $v,
            lerp( $u, grad( P->[$AA+1], $x, $y  , $z-1 ), grad( P->[$B
+A+1], $x-1, $y  , $z-1 ) ),
            lerp( $u, grad( P->[$AB+1], $x, $y-1, $z-1 ), grad( P->[$B
+B+1], $x-1, $y-1, $z-1 ) )
        )
    );
}

our $F //= 5;
our $X //= 1024; our $Y //= 512;

my @pix = map[ (0) x $X ], 1 .. $Y;

for my $f ( 2,3,5,7,11,13,17,19 ) {
    my $yoff = 0;
    for my $y ( 0 .. $Y-1 ) {
        my $xoff = 0;
        for my $x ( 0 .. $X-1 ) {
            ( $pix[$y][$x] += ( (1+noise( $xoff, $yoff, 1 )) /2 ) ) /=
+ 2;
            $xoff += 0.01 * $f;
        }
        $yoff += 0.01 * $f;
    }
    my $im = GD::Image->new( $X, $Y, 1 );
    for my $y ( 0 .. $Y-1 ) {
        for my $x ( 0 .. $X-1 ) {
            $im->setPixel( $x, $y, rgb2n( ( $pix[$y][$x] * ( 512 / $f 
+) ) x 3 ) );
        }
    }
    open PNG, '>:raw', "$0.png" or die $!;
    print PNG $im->png;
    close PNG;
    system "$0.png";
}

print min( map min( @$_ ), @pix );
print max( map max( @$_ ), @pix );

      [download]

      The next step to producing good texture maps is to pick sets of scales and combine them to produce variable textures across the surface. I never got around to that as it wasn't my goal for the code.

      With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
      Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
      "Science is about questioning the status quo. Questioning authority".
      In the absence of evidence, opinion is indistinguishable from prejudice.
[reply]
[d/l]

In Section Cool Uses for Perl