procedure TForm1.TBitBtn1Click(Sender: TObject);
const
cWidth = 400;
cHeight= 400;
MaxLoop= 500;
var
i : integer;
Grid :
ARRAY[1..cWidth, 1..cHeight]
OF integer;
Step :
ARRAY[1..cWidth]
OF integer;
x, y : integer;
a, b : double;
Ma : integer;
UpDown: Boolean;
begin
Randomize;
Image1.Width := cWidth;
Image1.Height := cHeight;
Image1.Picture.Bitmap.PixelFormat := pf24bit;
Image1.Picture.Bitmap.Width := cWidth;
Image1.Picture.Bitmap.Height := cHeight;
// Grundstruktur
FillChar(Grid, SizeOf(Grid), #0);
FOR i := 1
TO MaxLoop
DO
BEGIN
// Gleichung für Schnittgerade durch Landschaft
a := random * cHeight*3 - cHeight;
b := random * 4 -2 ;
// Für Schnittgerade die x/y Punktepaare berechnen
FOR x := 1
TO cWidth
DO
Step[x] := round(a + b*x);
// Landschaft erhöhen/erniedrigen je nachdem, ob Punkt über unter unter Schnittgerade ist
UpDown := random < 0.5;
// Entscheidung Erhöhen/Erniedrigen pro Durchlauf variieren
FOR y := cHeight
DOWNTO 1
DO
FOR x := cWidth
downto 1
DO
IF UpDown
then
begin
IF Step[x] < y
then Inc(Grid[x, y])
else Dec(Grid[x, y]);
end
else begin
IF Step[x] >= y
then Inc(Grid[x, y])
else Dec(Grid[x, y]);
end;
Label1.Caption := IntToStr(Trunc(i/MaxLoop*100)) +'
%';
Application.ProcessMessages;
END;
// Landschaft glätten
// Filtern "vor Ort" (ohne zweites Grid) ist nicht ganz optimal, aber auf die Schnelle...
FOR i := 1
TO 4
do
begin
FOR y := cHeight-1
DOWNTO 2
DO
FOR x := cWidth-1
downto 2
DO
Grid[x, y] := (Grid[x, y] * 4+
(Grid[x+1, y]+Grid[x-1, y]+Grid[x, y+1]+Grid[x, y-1]) * 2+
Grid[x+1, y+1]+Grid[x-1, y+1]+Grid[x+1, y-1]+Grid[x-1, y-1] )
div 16;
end;
// Maximum bestimmen
Ma := 0;
FOR y := cHeight
DOWNTO 1
DO
FOR x := cWidth
downto 1
DO
IF Ma < Grid[x, y]
THEN
Ma := Grid[x, y];
// Bitmap einfärben
WITH Image1.Picture.Bitmap.Canvas
DO
FOR y := cHeight
DOWNTO 1
DO
FOR x := cWidth
downto 1
DO
IF Grid[x, y] <= 0
then Pixels[x, y] := clBlue
else begin
i := Trunc(Grid[x, y] * 160 / Ma);
Pixels[x, y] := $0020F020 + $00010001 * (i
div 4) - $00000100 * i;
end;
end;