1 {$INCLUDE "options.inc"}

     2 

     3 unit uLandGenPerlin;

     4 interface

     5 

     6 procedure GenPerlin;

     7 

     8 implementation

     9 uses uVariables

    10     , uConsts

    11     , uRandom

    12     , uLandOutline // FillLand

    13     , uUtils

    14     ;

    15 

    16 var p: array[0..511] of LongInt;

    17 

    18 const fadear: array[byte] of LongInt =

    19 (0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 2, 3, 3, 4, 6, 7, 9, 10, 12,

    20 14, 17, 19, 22, 25, 29, 32, 36, 40, 45, 49, 54, 60, 65, 71,

    21 77, 84, 91, 98, 105, 113, 121, 130, 139, 148, 158, 167, 178,

    22 188, 199, 211, 222, 234, 247, 259, 273, 286, 300, 314, 329, 344,

    23 359, 374, 390, 407, 424, 441, 458, 476, 494, 512, 531, 550,

    24 570, 589, 609, 630, 651, 672, 693, 715, 737, 759, 782, 805, 828,

    25 851, 875, 899, 923, 948, 973, 998, 1023, 1049, 1074, 1100, 1127,

    26 1153, 1180, 1207, 1234, 1261, 1289, 1316, 1344, 1372, 1400, 1429,

    27 1457, 1486, 1515, 1543, 1572, 1602, 1631, 1660, 1690, 1719, 1749,

    28 1778, 1808, 1838, 1868, 1898, 1928, 1958, 1988, 2018, 2048, 2077,

    29 2107, 2137, 2167, 2197, 2227, 2257, 2287, 2317, 2346, 2376, 2405,

    30 2435, 2464, 2493, 2523, 2552, 2580, 2609, 2638, 2666, 2695, 2723,

    31 2751, 2779, 2806, 2834, 2861, 2888, 2915, 2942, 2968, 2995, 3021,

    32 3046, 3072, 3097, 3122, 3147, 3172, 3196, 3220, 3244, 3267, 3290,

    33 3313, 3336, 3358, 3380, 3402, 3423, 3444, 3465, 3486, 3506, 3525,

    34 3545, 3564, 3583, 3601, 3619, 3637, 3654, 3672, 3688, 3705, 3721,

    35 3736, 3751, 3766, 3781, 3795, 3809, 3822, 3836, 3848, 3861, 3873,

    36 3884, 3896, 3907, 3917, 3928, 3937, 3947, 3956, 3965, 3974, 3982,

    37 3990, 3997, 4004, 4011, 4018, 4024, 4030, 4035, 4041, 4046, 4050,

    38 4055, 4059, 4063, 4066, 4070, 4073, 4076, 4078, 4081, 4083, 4085,

    39 4086, 4088, 4089, 4091, 4092, 4092, 4093, 4094, 4094, 4095, 4095,

    40 4095, 4095, 4095, 4095, 4095);

    41 

    42 function fade(t: LongInt) : LongInt; inline;

    43 var t0, t1: LongInt;

    44 begin

    45     t0:= fadear[t shr 8];

    46 

    47     if t0 = fadear[255] then

    48         t1:= t0

    49     else

    50         t1:= fadear[t shr 8 + 1];

    51 

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

    53 end;

    54 

    55 

    56 function lerp(t, a, b: LongInt) : LongInt; inline;

    57 begin

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

    59 end;

    60 

    61 

    62 function grad(hash, x, y: LongInt) : LongInt; inline;

    63 var h, v, u: LongInt;

    64 begin

    65     h:= hash and 15;

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

    67     if h < 4 then v:= y else

    68         if (h = 12) or (h = 14) then v:= x else v:= 0;

    69 

    70     if (h and 1) <> 0 then u:= -u;

    71     if (h and 2) <> 0 then v:= -v;

    72 

    73     grad:= u + v

    74 end;

    75 

    76 

    77 function inoise(x, y: LongInt) : LongInt; inline;

    78 const N = $10000;

    79 var xx, yy, u, v, A, AA, AB, B, BA, BB: LongInt;

    80 begin

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

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

    83 

    84     x:= x and $FFFF;

    85     y:= y and $FFFF;

    86 

    87     u:= fade(x);

    88     v:= fade(y);

    89 

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

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

    92 

    93     inoise:=

    94             lerp(v, lerp(u, grad(p[AA  ], x   , y  ),

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

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

    97                             grad(p[BB  ], x-N , y-N)));

    98 end;

    99 

   100 procedure inoise_setup();

   101 var i, ii, t: Longword;

   102 begin

   103     for i:= 0 to 254 do

   104         p[i]:= i + 1;

   105     p[255]:= 0;

   106 

   107     for i:= 0 to 254 do

   108     begin

   109         ii:= GetRandom(256 - i) + i;

   110         t:= p[i];

   111         p[i]:= p[ii];

   112         p[ii]:= t

   113     end;

   114 

   115     for i:= 0 to 255 do

   116         p[256 + i]:= p[i];

   117 end;

   118 

   119 const width = 4096;

   120       height = 2048;

   121       minY = 500;

   122 

   123     //bottomPlateHeight = 90;

   124     //bottomPlateMargin = 1200;

   125     margin = 200;

   126 

   127 procedure GenPerlin;

   128 var y, x, di, dj, r, param1, param2, rCutoff, detail: LongInt;

   129 var df: Int64;

   130 begin

   131     param1:= cTemplateFilter div 3;

   132     param2:= cTemplateFilter mod 3;

   133     rCutoff:= min(max((26-cFeatureSize)*4,15),85);

   134     detail:= (26-cFeatureSize)*16000+50000; // feature size is a slider from 1-25 at present. flip it for perlin

   135 

   136     df:= detail * (6 - param2 * 2);

   137 

   138     inoise_setup();

   139 

   140     for y:= minY to pred(height) do

   141     begin

   142         di:= df * y div height;

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

   144         begin

   145             dj:= df * x div width;

   146 

   147             r:= ((abs(inoise(di, dj)) + y*4) mod 65536 - (height - y) * 8) div 256;

   148 

   149             //r:= (abs(inoise(di, dj))) shr 8 and $ff;

   150             if (x < margin) or (x > width - margin) then r:= r - abs(x - width div 2) + width div 2 - margin; // fade on edges

   151 

   152             //r:= r - max(0, - abs(x - width div 2) + width * 2 div 100); // split vertically in the middle

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

   154             //r:= r + 1 - ((abs(x - (width div 2)) + abs(y - height) * 2)) div 32; // manhattan length ellipse

   155 

   156             {

   157             if (y > height - bottomPlateHeight) and (x > bottomPlateMargin) and (x + bottomPlateMargin < width) then

   158             begin

   159                 dy:= (y - height + bottomPlateHeight);

   160                 r:= r + dy;

   161 

   162                 if x < bottomPlateMargin + bottomPlateHeight then

   163                     r:= r + (x - bottomPlateMargin - bottomPlateHeight)

   164                 else

   165                 if x + bottomPlateMargin + bottomPlateHeight > width then

   166                     r:= r - (x - width + bottomPlateMargin + bottomPlateHeight);

   167             end;

   168             }

   169 

   170             if r < rCutoff then

   171                 Land[y, x]:= 0

   172             else if param1 = 0 then

   173                 Land[y, x]:= lfObjMask

   174             else

   175                 Land[y, x]:= lfBasic

   176         end;

   177     end;

   178 

   179     if param1 = 0 then

   180         begin

   181         for x:= 0 to width do

   182             if Land[height - 1, x] = lfObjMask then FillLand(x, height - 1, 0, lfBasic);

   183 

   184         // strip all lfObjMask pixels

   185         for y:= minY to LAND_HEIGHT - 1 do

   186             for x:= 0 to LAND_WIDTH - 1 do

   187                 if Land[y, x] = lfObjMask then

   188                     Land[y, x]:= 0;

   189         end;

   190 

   191     leftX:= 0;

   192     rightX:= 4095;

   193     topY:= 0;

   194     hasBorder:= false;

   195 end;

   196 

   197 end.