Как добавить когерентный шум?
Материал из DRKB
{ Coherent noise function over 1, 2 or 3 dimensions by Ken Perlin }
unit perlin;
interface
function Noise1(arg: Double): Double;
function Noise2(vec0, vec1: Double): Double;
function Noise3(vec0, vec1, vec2: Double): Double;
function PNoise1(x, alpha, beta: Double; n: Integer): Double;
function PNoise2(x, y, alpha, beta: Double; n: Integer): Double;
function PNoise3(x, y, z, alpha, beta: Double; n: Integer): Double;
{ High Alpha: smoother intensity change, lower contrast
Low Alpha: rapid intensity change, higher contrast
High Beta: coarse, big spots
Low Beta: fine, small spots }
implementation
uses
SysUtils;
const
defB = $100;
defBM = $FF;
defN = $1000;
var
start: Boolean = True;
p: array[0..defB + defB + 2 - 1] of Integer;
g3: array[0..defB + defB + 2 - 1, 0..2] of Double;
g2: array[0..defB + defB + 2 - 1, 0..1] of Double;
g1: array[0..defB + defB + 2 - 1] of Double;
function s_curve(t: Double): Double;
begin
Result := t * t * (3.0 - 2.0 * t);
end;
function lerp(t, a, b: Double): Double;
begin
Result := a + t * (b - a);
end;
procedure Setup(veci: Double; var b0, b1: Integer; var r0, r1: Double);
var
t: Double;
begin
t := veci + defN;
b0 := Trunc(t) and defBM;
b1 := (b0 + 1) and defBM;
r0 := t - Int(t);
r1 := r0 - 1.0;
end;
procedure Normalize2(var v0, v1: Double);
var
s: Double;
begin
s := Sqrt(v0 * v0 + v1 * v1);
v0 := v0 / s;
v1 := v1 / s;
end;
procedure Normalize3(var v0, v1, v2: Double);
var
s: Double;
begin
s := Sqrt(v0 * v0 + v1 * v1 + v2 * v2);
v0 := v0 / s;
v1 := v1 / s;
v2 := v2 / s;
end;
procedure Init;
var
i, j, k: Integer;
begin
for i := 0 to defB - 1 do
begin
p[i] := i;
g1[i] := (Random(defB + defB) - defB) / defB;
for j := 0 to 1 do
g2[i, j] := (Random(defB + defB) - defB) / defB;
Normalize2(g2[i, 0], g2[i, 1]);
for j := 0 to 2 do
g3[i, j] := (Random(defB + defB) - defB) / defB;
Normalize3(g3[i, 0], g3[i, 1], g3[i, 2]);
end;
i := defB;
while i > 0 do
begin
k := p[i];
j := Random(defB);
p[i] := p[j];
p[j] := k;
Dec(i);
end;
for i := 0 to defB + 1 do
begin
p[defB + i] := p[i];
g1[defB + i] := g1[i];
for j := 0 to 1 do
g2[defB + i, j] := g2[i, j];
for j := 0 to 2 do
g3[defB + i, j] := g3[i, j];
end;
end;
function Noise1(arg: Double): Double;
var
bx0, bx1: Integer;
rx0, rx1, sx, u, v: Double;
begin
if start then
begin
Init();
start := False;
end;
bx0 := Trunc(arg + defN) and defBM;
bx1 := (bx0 + 1) and defBM;
rx0 := Frac(arg + defN);
rx1 := rx0 - 1.0;
sx := rx0 * rx0 * (3.0 - 2.0 * rx0);
u := rx0 * g1[p[bx0]];
v := rx1 * g1[p[bx1]];
Result := u + sx * (v - u);
end;
function Noise2(vec0, vec1: Double): Double;
var
i, j, bx0, bx1, by0, by1, b00, b10, b01, b11: Integer;
rx0, rx1, ry0, ry1, sx, sy, a, b, u, v: Double;
begin
if start then
begin
Init();
start := False;
end;
bx0 := Trunc(vec0 + defN) and defBM;
bx1 := (bx0 + 1) and defBM;
rx0 := Frac(vec0 + defN);
rx1 := rx0 - 1.0;
by0 := Trunc(vec1 + defN) and defBM;
by1 := (by0 + 1) and defBM;
ry0 := Frac(vec1 + defN);
ry1 := ry0 - 1.0;
i := p[bx0];
j := p[bx1];
b00 := p[i + by0];
b10 := p[j + by0];
b01 := p[i + by1];
b11 := p[j + by1];
sx := rx0 * rx0 * (3.0 - 2.0 * rx0);
sy := ry0 * ry0 * (3.0 - 2.0 * ry0);
u := rx0 * g2[b00, 0] + ry0 * g2[b00, 1];
v := rx1 * g2[b10, 0] + ry0 * g2[b10, 1];
a := u + sx * (v - u);
u := rx0 * g2[b01, 0] + ry1 * g2[b01, 1];
v := rx1 * g2[b11, 0] + ry1 * g2[b11, 1];
b := u + sx * (v - u);
Result := a + sy * (b - a);
end;
function Noise3Orig(vec0, vec1, vec2: Double): Double;
var
i, j, bx0, bx1, by0, by1, bz0, bz1, b00, b10, b01, b11: Integer;
rx0, rx1, ry0, ry1, rz0, rz1, sx, sy, sz, a, b, c, d, u, v: Double;
begin
if start then
begin
start := False;
Init();
end;
Setup(vec0, bx0, bx1, rx0, rx1);
Setup(vec1, by0, by1, ry0, ry1);
Setup(vec2, bz0, bz1, rz0, rz1);
i := p[bx0];
j := p[bx1];
b00 := p[i + by0];
b10 := p[j + by0];
b01 := p[i + by1];
b11 := p[j + by1];
sx := s_curve(rx0);
sy := s_curve(ry0);
sz := s_curve(rz0);
u := rx0 * g3[b00 + bz0, 0] + ry0 * g3[b00 + bz0, 1] + rz0 * g3[b00 + bz0, 2];
v := rx1 * g3[b10 + bz0, 0] + ry0 * g3[b10 + bz0, 1] + rz0 * g3[b10 + bz0, 2];
a := lerp(sx, u, v);
u := rx0 * g3[b01 + bz0, 0] + ry1 * g3[b01 + bz0, 1] + rz0 * g3[b01 + bz0, 2];
v := rx1 * g3[b11 + bz0, 0] + ry1 * g3[b11 + bz0, 1] + rz0 * g3[b11 + bz0, 2];
b := lerp(sx, u, v);
c := lerp(sy, a, b);
u := rx0 * g3[b00 + bz1, 0] + ry0 * g3[b00 + bz1, 1] + rz1 * g3[b00 + bz1, 2];
v := rx1 * g3[b10 + bz1, 0] + ry0 * g3[b10 + bz1, 1] + rz1 * g3[b10 + bz1, 2];
a := lerp(sx, u, v);
u := rx0 * g3[b01 + bz1, 0] + ry1 * g3[b01 + bz1, 1] + rz1 * g3[b01 + bz1, 2];
v := rx1 * g3[b11 + bz1, 0] + ry1 * g3[b11 + bz1, 1] + rz1 * g3[b11 + bz1, 2];
b := lerp(sx, u, v);
d := lerp(sy, a, b);
Result := lerp(sz, c, d);
end;
function Noise3(vec0, vec1, vec2: Double): Double;
var
i, j, bx0, bx1, by0, by1, bz0, bz1, b00, b10, b01, b11: Integer;
rx0, rx1, ry0, ry1, rz0, rz1, sx, sy, sz, a, b, c, d, u, v: Double;
begin
if start then
begin
start := False;
Init();
end;
bx0 := Trunc(vec0 + defN) and defBM;
bx1 := (bx0 + 1) and defBM;
rx0 := Frac(vec0 + defN);
rx1 := rx0 - 1.0;
by0 := Trunc(vec1 + defN) and defBM;
by1 := (by0 + 1) and defBM;
ry0 := Frac(vec1 + defN);
ry1 := ry0 - 1.0;
bz0 := Trunc(vec2 + defN) and defBM;
bz1 := (bz0 + 1) and defBM;
rz0 := Frac(vec2 + defN);
rz1 := rz0 - 1.0;
i := p[bx0];
j := p[bx1];
b00 := p[i + by0];
b10 := p[j + by0];
b01 := p[i + by1];
b11 := p[j + by1];
sx := rx0 * rx0 * (3.0 - 2.0 * rx0);
sy := ry0 * ry0 * (3.0 - 2.0 * ry0);
sz := rz0 * rz0 * (3.0 - 2.0 * rz0);
u := rx0 * g3[b00 + bz0, 0] + ry0 * g3[b00 + bz0, 1] + rz0 * g3[b00 + bz0, 2];
v := rx1 * g3[b10 + bz0, 0] + ry0 * g3[b10 + bz0, 1] + rz0 * g3[b10 + bz0, 2];
a := u + sx * (v - u);
u := rx0 * g3[b01 + bz0, 0] + ry1 * g3[b01 + bz0, 1] + rz0 * g3[b01 + bz0, 2];
v := rx1 * g3[b11 + bz0, 0] + ry1 * g3[b11 + bz0, 1] + rz0 * g3[b11 + bz0, 2];
b := u + sx * (v - u);
c := a + sy * (b - a);
u := rx0 * g3[b00 + bz1, 0] + ry0 * g3[b00 + bz1, 1] + rz1 * g3[b00 + bz1, 2];
v := rx1 * g3[b10 + bz1, 0] + ry0 * g3[b10 + bz1, 1] + rz1 * g3[b10 + bz1, 2];
a := u + sx * (v - u);
u := rx0 * g3[b01 + bz1, 0] + ry1 * g3[b01 + bz1, 1] + rz1 * g3[b01 + bz1, 2];
v := rx1 * g3[b11 + bz1, 0] + ry1 * g3[b11 + bz1, 1] + rz1 * g3[b11 + bz1, 2];
b := u + sx * (v - u);
d := a + sy * (b - a);
Result := c + sz * (d - c);
end;
{ Harmonic summing functions }
{ In what follows "alpha" is the weight when the sum is formed. Typically it is 2. As this
approaches 1 the function is noisier.
"beta" is the harmonic scaling/spacing, typically 2.
persistance = 1/alpha
beta = frequency
N = octaves }
function PNoise1(x, alpha, beta: Double; n: Integer): Double;
var
i: Integer;
val, sum, p, scale: Double;
begin
sum := 0;
scale := 1;
p := x;
for i := 0 to n - 1 do
begin
val := Noise1(p);
sum := sum + val / scale;
scale := scale * alpha;
p := p * beta;
end;
Result := sum;
end;
function PNoise2(x, y, alpha, beta: Double; n: Integer): Double;
var
i: Integer;
val, sum, px, py, scale: Double;
begin
sum := 0;
scale := 1;
px := x;
py := y;
for i := 0 to n - 1 do
begin
val := Noise2(px, py);
sum := sum + val / scale;
scale := scale * alpha;
px := px * beta;
py := py * beta;
end;
Result := sum;
end;
function PNoise3(x, y, z, alpha, beta: Double; n: Integer): Double;
var
i: Integer;
val, sum, px, py, pz, scale: Double;
begin
sum := 0;
scale := 1;
px := x;
py := y;
pz := z;
for i := 0 to n - 1 do
begin
val := Noise3(px, py, pz);
sum := sum + val / scale;
scale := scale * alpha;
px := px * beta;
py := py * beta;
pz := pz * beta;
end;
Result := sum;
end;
end.
Used like this:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
Image1: TImage;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
perlin;
procedure TForm1.Button1Click(Sender: TObject);
var
x, y, z, c: Integer;
begin
Image1.Canvas.Brush.Color := 0;
Image1.Canvas.FillRect(Image1.Canvas.ClipRect);
for x := 0 to 511 do
for y := 0 to 511 do
begin
z := Trunc(PNoise2(x / 100, y / 100, 2, 2, 10) * 128) + 128;
c := z + (z shl 8) + (z shl 16);
Image1.Canvas.Pixels[x, y] := c;
end;
c := 0;
repeat
Image1.Canvas.Pixels[519, c] := $FFFFFF;
c := c + 10;
until c > 510;
end;
end.
Source: http://www.baltsoft.com/
ID: 03861