package SimplexNoise;
# see __END__ for credits
use File::Compare;
use strict;
use warnings;
use Data::Dumper;
use Carp;
$|=1;

my @grad3 = (
[1, 1, 0], [-1, 1, 0], [1, -1, 0], [-1, -1, 0], 
[1, 0, 1], [-1, 0, 1], [1, 0, -1], [-1, 0, -1], 
[0, 1, 1], [0, -1, 1], [0, 1, -1], [0, -1, -1], 
);

my @grad4 = (
[0, 1, 1, 1],  [0, 1, 1, -1],  [0, 1, -1, 1],  [0, 1, -1, -1], 
[0, -1, 1, 1], [0, -1, 1, -1], [0, -1, -1, 1], [0, -1, -1, -1], 
[1, 0, 1, 1],  [1, 0, 1, -1],  [1, 0, -1, 1],  [1, 0, -1, -1], 
[-1, 0, 1, 1], [-1, 0, 1, -1], [-1, 0, -1, 1], [-1, 0, -1, -1], 
[1, 1, 0, 1],  [1, 1, 0, -1],  [1, -1, 0, 1],  [1, -1, 0, -1], 
[-1, 1, 0, 1], [-1, 1, 0, -1], [-1, -1, 0, 1], [-1, -1, 0, -1], 
[1, 1, 1, 0],  [1, 1, -1, 0],  [1, -1, 1, 0],  [1, -1, -1, 0], 
[-1, 1, 1, 0], [-1, 1, -1, 0], [-1, -1, 1, 0], [-1, -1, -1, 0], 
);


my @grads = ([],    # Noise doesn't make sense at zero dimensions
    [map{ [rand(2)-1] } (0..9) ],  # ten random slopes for 1D noise
    [map { [$_->[0], $_->[1]] }  @grad3],    # projection of cube's li
+ne midpoints
    #[map{  [$_->[0] / ($_->[2]?sqrt(2):1), $_->[1] / ($_->[2]?sqrt(2)
+:1)] } @grad3], #projection of cube's line midpoints, normalized
    [@grad3],    # cube's line midpoints
    [@grad4],    # hypercube line midpoints
    );
my @magicResultFactor = ( 1,    # Noise doesn't make sense at zero dim
+ensions
    1,    # TBD
    70, # Probably doesn't fit mystery value pattern due to gradients 
+with different magnitudes
    32, # Mystery value
    27, # Another Mystery value
    );
    
sub initializeGradVector
{
    my $dimensions = shift;
    die "Need to implement picking some gradient vectors for ${dimensi
+ons}th-dimensional noise space\n";
}
sub getGradVector
{
    my $dimensions = shift;
    my $index = shift;
    
    initializeGradVector($dimensions) unless defined $grads[$dimension
+s];
    $index %= scalar @{$grads[$dimensions]};
    return $grads[$dimensions][$index];
}

my @p = # map { ;rand(256); } 1..256;
qw(151 160 137 91 90 15 131 13 201 95 96 53 194 233 7 225
140 36 103 30 69 142 8 99 37 240 21 10 23 190 6 148 247 120 234 75 0 2
+6 197 62
94 252 219 203 117 35 11 32 57 177 33 88 237 149 56 87 174 20 125 136 
+171 168
68 175 74 165 71 134 139 48 27 166 77 146 158 231 83 111 229 122 60 21
+1 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 208 89 18 169 200 196 135 130 116 188 159 86 164 100 109 198 173 1
+86 3 64
52 217 226 250 124 123 5 202 38 147 118 126 255 82 85 212 207 206 59 2
+27 47 16
58 17 182 189 28 42 223 183 170 213 119 248 152 2 44 154 163 70 221 15
+3 101 155
167 43 172 9 129 22 39 253 19 98 108 110 79 113 224 232 178 185 112 10
+4 218 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);

my @perm = (@p, @p);
my @permMod12 = map { $_ % 12 } @perm;

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));
}

use constant 
{
    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
};

sub floor 
{
    my $x = shift;
    my $xi = int($x);
    return $x < $xi ? $xi - 1 : $xi;
}

sub dot 
{
    my @firstVec = @{shift()};
    my $sum = 0;
    $sum += $_ * shift @firstVec for @_;
    $sum;
}
sub ncdot 
{ #Non-consuming dot product, so we don't eat our gradients.
    my $firstVec = shift();
    my $secondVec = shift();
    my $sum = 0;
    $sum += $firstVec->[$_] * $secondVec->[$_] for (0..$#$secondVec);
    $sum;
}

sub noise 
{
    my @coords = @_;
    my $numDimensions = @coords;
    
    my $FFactor = FFactor($numDimensions);
    my $GFactor = GFactor($numDimensions);
    
    my $perlS = 0;
    $perlS += $_ for @coords;
    my @baseCoords = map{ floor($_+$perlS*$FFactor) & (255) } @coords;
    
    my $perlT = 0;
    $perlT += $_ for @baseCoords;
    $perlT *= $GFactor;
    my @cellOriginCoords = map { $_ - $perlT } @baseCoords;
    
    my @cornerOffsets;
    # Offset to first corner is needed early.  Others will be calculat
+ed later.
    push @cornerOffsets, [ map { $coords[$_] - $cellOriginCoords[$_] }
+ (0..$numDimensions-1)];
    # Identifies the bounding corners of the cell via what order coord
+s are incremented.  Original code used a lookup table.
    my @coordOrder = sort { $cornerOffsets[0][$b] <=> $cornerOffsets[0
+][$a]  } (0..$numDimensions-1);
    # Collect coordinates of all the corners
    my @point = ((0) x$numDimensions);
    my @corners = ([@point]);
    for (0 .. $numDimensions-1)
    {
        $point[$coordOrder[$_]]++;
        push @corners, [@point];
    }
    
    # Look up gradient for each corner, using the hash table
    my @cornerGradients = ();
    for my $corner (@corners)
    {
        my $temp = 0;
        $temp = (@perm)[$baseCoords[$_] + $corner->[$_] + $temp] for (
+reverse 0..$numDimensions-1);
        my $gvec = getGradVector($numDimensions, $temp);
        push @cornerGradients, $gvec;
    }
    
    # Find the offset from our point to all the remaining corners (fir
+st corner already done above)
    my $totalGfactor = $GFactor;
    for my $corner (@corners[1..$#corners])
    {
        my @coords;
        for (0..$numDimensions-1)
        {
            push @coords, ($cornerOffsets[0][$_] - $corner->[$_] + $to
+talGfactor);
        }
        push @cornerOffsets, \@coords;
        $totalGfactor += $GFactor;
    }
    
    #Sum up contributions from the corners
    my $result = 0;
    for my $cornerIdx (0..$numDimensions)
    {
        my $t = 0.5;
        $t -= $cornerOffsets[$cornerIdx][$_]*$cornerOffsets[$cornerIdx
+][$_] for (0..$numDimensions-1);
        if ($t > 0)
        {
            $t = $t ** 4;
            $result += $t * ncdot($cornerGradients[$cornerIdx], [@{$co
+rnerOffsets[$cornerIdx]}]);
        }
    }
    $result *= $magicResultFactor[$numDimensions];
    return $result;
}

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 = 1;
        
        $pixel *= (((noise( $x/$_, $y/$_))+ 1) / 2) ** .5 for reverse 
+(512, 128, 64, 32, );
        push @row, int($pixel*256);
    }
    print "Rendering...$i/$N\r";
    push @pic, \@row;
}
print "Rendering...Done      \n";
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]