|
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. |