1 {$INCLUDE "options.inc"}

     2 

     3 unit uLandGenPerlin;

     4 interface

     5 

     6 procedure GenPerlin;

     7 

     8 implementation

     9 uses uVariables, uConsts, math; // for min()

    10 

    11 var fadear: array[byte] of LongInt;

    12     p: array[0..511] of LongInt;

    13 

    14 function fade(t: LongInt) : LongInt;

    15 var t0, t1: LongInt;

    16 begin

    17     t0:= fadear[t shr 8];

    18     t1:= fadear[min(255, t shr 8 + 1)];

    19 

    20     fade:= t0 + ((t and 255) * (t1 - t0) shr 8)

    21 end;

    22 

    23 

    24 function lerp(t, a, b: LongInt) : LongInt;

    25 begin

    26     lerp:= a + (t * (b - a) shr 12)

    27 end;

    28 

    29 

    30 function grad(hash, x, y, z: LongInt) : LongInt;

    31 var h, v, u: LongInt;

    32 begin

    33     h:= hash and 15;

    34     if h < 8 then u:= x else u:= y;

    35     if h < 4 then v:= y else

    36         if (h = 12) or (h = 14) then v:= x else v:= z;

    37 

    38     if odd(h) then u:= -u;

    39     if odd(h shr 1) then v:= -v;

    40 

    41     grad:= u + v

    42 end;

    43 

    44 

    45 function inoise(x, y, z: LongInt) : LongInt;

    46 const N = $10000;

    47 var xx, yy, zz, u, v, w, A, AA, AB, B, BA, BB: LongInt;

    48 begin

    49     xx:= (x shr 16) and 255;

    50     yy:= (y shr 16) and 255;

    51     zz:= (z shr 16) and 255;

    52 

    53     x:= x and $FFFF;

    54     y:= y and $FFFF;

    55     z:= z and $FFFF;

    56 

    57     u:= fade(x);

    58     v:= fade(y);

    59     w:= fade(z);

    60 

    61     A:= p[xx    ] + yy; AA:= p[A] + zz; AB:= p[A + 1] + zz;

    62     B:= p[xx + 1] + yy; BA:= p[B] + zz; BB:= p[B + 1] + zz;

    63 

    64     inoise:=

    65  lerp(w, lerp(v, lerp(u, grad(p[AA  ], x   , y   , z   ),

    66                                      grad(p[BA  ], x-N , y   , z   )),

    67                              lerp(u, grad(p[AB  ], x   , y-N , z   ),

    68                                      grad(p[BB  ], x-N , y-N , z   ))),

    69                      lerp(v, lerp(u, grad(p[AA+1], x   , y   , z-N ),

    70                                      grad(p[BA+1], x-N , y   , z-N )),

    71                              lerp(u, grad(p[AB+1], x   , y-N , z-N ),

    72                                      grad(p[BB+1], x-N , y-N , z-N ))));

    73 end;

    74 

    75 function f(t: double): double;

    76 begin

    77     f:= t * t * t * (t * (t * 6 - 15) + 10);

    78 end;

    79 

    80 const permutation: array[byte] of LongInt = ( 151,160,137,91,90,15,

    81    131,13,201,95,96,53,194,233,7,225,140,36,103,30,69,142,8,99,37,240,21,10,23,

    82    190, 6,148,247,120,234,75,0,26,197,62,94,252,219,203,117,35,11,32,57,177,33,

    83    88,237,149,56,87,174,20,125,136,171,168, 68,175,74,165,71,134,139,48,27,166,

    84    77,146,158,231,83,111,229,122,60,211,133,230,220,105,92,41,55,46,245,40,244,

    85    102,143,54, 65,25,63,161, 1,216,80,73,209,76,132,187,208, 89,18,169,200,196,

    86    135,130,116,188,159,86,164,100,109,198,173,186, 3,64,52,217,226,250,124,123,

    87    5,202,38,147,118,126,255,82,85,212,207,206,59,227,47,16,58,17,182,189,28,42,

    88    223,183,170,213,119,248,152, 2,44,154,163, 70,221,153,101,155,167, 43,172,9,

    89    129,22,39,253, 19,98,108,110,79,113,224,232,178,185, 112,104,218,246,97,228,

    90    251,34,242,193,238,210,144,12,191,179,162,241, 81,51,145,235,249,14,239,107,

    91    49,192,214, 31,181,199,106,157,184, 84,204,176,115,121,50,45,127, 4,150,254,

    92    138,236,205,93,222,114,67,29,24,72,243,141,128,195,78,66,215,61,156,180

    93    );

    94 

    95 procedure inoise_setup();

    96 var i: LongInt;

    97 begin

    98     for i:= 0 to 255 do

    99         begin

   100         p[256 + i]:= permutation[i];

   101         p[i]:= permutation[i]

   102         end;

   103 

   104     for i:= 0 to 255 do

   105         fadear[i]:= trunc($1000 * f(i / 256));

   106 end;

   107 

   108 const detail = 120000*3;

   109     field = 3;

   110     width = 4096;

   111     height = 2048;

   112 

   113 procedure GenPerlin;

   114 var y, x, di, dj, r: LongInt;

   115 begin

   116     inoise_setup();

   117 

   118     for y:= 0 to pred(height) do

   119     begin

   120         di:= detail * field * y div height;

   121         for x:= 0 to pred(width) do

   122         begin

   123             dj:= detail * field * x div width;

   124             r:= (abs(inoise(di, dj, detail*field)) + y*4) mod 65536 div 256;

   125             r:= r - max(0, abs(x - width div 2) - width * 45 div 100);

   126             //r:= r - max(0, - abs(x - width div 2) + width * 2 div 100);

   127 

   128 

   129             r:= r + (trunc(1000 - sqrt(sqr(x - (width div 2)) * 4 + sqr(y - height * 5 div 4) * 22))) div 600 * 20;

   130 

   131             if r < 0 then Land[y, x]:= 0 else Land[y, x]:= lfBasic;

   132 

   133         end;

   134     end;

   135 end;

   136 

   137 end.