Inseln auf ein Image malen

[grizzly]

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