procedure TForm1.DrawMap(
const AWidth, AHeight : Word);
const
MaxLoop = 500;
type
TGrid =
array of array of SmallInt;
var
progress : Byte;
i : integer;
PGrid : ^TGrid;
Step :
array of integer;
x, y : integer;
a, b : double;
Ma : integer;
UpDown: Boolean;
begin
try
New(PGrid);
except
MessageBox(
Handle, PChar('
Not enough memory' + #13#10 + '
Error: 1'), PChar('
Error - 1'), MB_OK
or MB_ICONERROR);
exit;
end;
SetLength(PGrid^, AWidth, AHeight);
SetLength(Step, AWidth);
// Grundstruktur
FillChar(PGrid^, SizeOf(TGrid), #0);
FOR i := 1
TO MaxLoop
DO
BEGIN
// Gleichung für Schnittgerade durch Landschaft
a := Random * AHeight * 3 - AHeight;
b := Random * 4 -2 ;
// Für Schnittgerade die x/y Punktepaare berechnen
FOR x := 1
TO AWidth
DO
Step[x - 1] := 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 := AHeight
DOWNTO 1
DO
FOR x := AWidth
downto 1
DO
IF UpDown
then
begin
IF Step[x - 1] < y
then Inc(PGrid^[x - 1, y - 1])
else Dec(PGrid^[x - 1, y - 1]);
end
else begin
IF Step[x - 1] >= y
then Inc(PGrid^[x - 1, y - 1])
else Dec(PGrid^[x - 1, y - 1]);
end;
progress := Trunc(i/MaxLoop*100);
lProgress.Caption := '
Progress: ' + IntToStr(progress) +'
%';
pbProgress.Position := progress;
lProgress.Repaint;
pbProgress.Repaint;
END;
// Landschaft glätten
// Filtern "vor Ort" (ohne zweites PGrid^) ist nicht ganz optimal, aber auf die Schnelle...
FOR i := 1
TO 4
do
begin
FOR y := AHeight - 2
DOWNTO 12
DO
FOR x := AWidth - 2
downto 1
DO
PGrid^[x, y] := (PGrid^[x, y] * 4+
(PGrid^[x+1, y]+PGrid^[x-1, y]+PGrid^[x, y+1]+PGrid^[x, y-1]) * 2+
PGrid^[x+1, y+1]+PGrid^[x-1, y+1]+PGrid^[x+1, y-1]+PGrid^[x-1, y-1] )
div 16;
end;
// Maximum bestimmen
Ma := 0;
FOR y := AHeight - 1
DOWNTO 0
DO
FOR x := AWidth - 1
downto 0
DO
IF Ma < PGrid^[x, y]
THEN
Ma := PGrid^[x, y];
// Bitmap einfärben
WITH iMap.Picture.Bitmap.Canvas
DO
FOR y := AHeight
DOWNTO 1
DO
FOR x := AWidth
downto 1
DO
IF PGrid^[x, y] <= 0
then Pixels[x, y] := clBlue
else begin
i := Trunc(PGrid^[x - 1, y - 1] * 160 / Ma);
Pixels[x, y] := $0020F020 + $00010001 * (i
div 4) - $00000100 * i;
end;
Dispose(PGrid);
end;