Was heißt "schön rund"?
Ich habe vor Jahren mal von einen ganz simplen Ansatz gelesen, solche Karten zu erstellen:
1. Du beginnst mit einer leeren Karte (Alles 0)
2. Du erzeugst Dir eine zufällige Trennlinie durch Deine Karte
3. Alle Punkte auf der einen Seite der Karte erhöhst Du um eins, die anderen verminderst Du um eins.
Die Schritte 2 und 3 ein paar hundert mal wiederholen...
Weil ich das schon seit Jahren mal ausprobieren wollte, hier mal schnell eine Quick and Dirty Umsetzung:
Der Source benötigt eine Form mit einem TBitBtn, einem TImage und einem TLabel.
Den Button öfters mal betätigen. Manchmal kommt nur Wasser oder nur Land raus...
Delphi-Quellcode:
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;
Zugegeben, rund ist das nicht.
Gruß
Michael