Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

Как добавить когерентный шум?

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

Взято с Delphi Knowledge Base: https://www.baltsoft.com/