Inseln auf ein Image malen

[grizzly]

Für mein Beispiel oben wollte ich kein komplettes Programm posten. Deshalb habe ich alles in die Prozedur selbst reingeworfen. Natürlich sollte man so eine Struktur nicht auf dem Stack allokieren. Aber um den Algorithmus zu illustrieren schien mir das vertretbar. Tut mir leid, wenn deswegen jemand seinen Stack eingerannt hat - hoffentlich erholt er sich wieder...

Hier die Stack-sichere Variante. Wollte ja eigentlich den obigen Beitrag editieren, aber das geht scheinbar nur innerhalb 24 Stunden. Wußte ich bisher auch noch nicht (entschuldigt also bitte diesen zweiten Riesen-Eintrag)...

Delphi-Quellcode:

procedure TForm1.BitBtn1Click(Sender: TObject);
const
  cWidth = 400;
  cHeight= 400;
  MaxLoop= 500;
type
  TGrid= ARRAY[1..cWidth, 1..cHeight] OF integer;  // Wenn man eh nur 500 Zyklen macht, reicht hier auch ein smallint
var
  i    : integer;
  PGrid: ^TGrid;
  Step : ARRAY[1..cWidth] OF integer;
  x, y : integer;
  a, b : double;
  Ma   : integer;
  UpDown: Boolean;
begin
  Randomize;

  try
    New(PGrid);
  except
    exit;  // Not enough memory
  end;

  Image1.Width  := cWidth;
  Image1.Height := cHeight;
  Image1.Picture.Bitmap.PixelFormat := pf24bit;
  Image1.Picture.Bitmap.Width := cWidth;
  Image1.Picture.Bitmap.Height := cHeight;

  // Grundstruktur
  FillChar(PGrid^, SizeOf(TGrid), #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(PGrid^[x, y])
                else Dec(PGrid^[x, y]);
            end
            else begin
              IF Step[x] >= y
                then Inc(PGrid^[x, y])
                else Dec(PGrid^[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
          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 := cHeight DOWNTO 1 DO
    FOR x := cWidth downto 1 DO
      IF Ma < PGrid^[x, y] THEN
        Ma := PGrid^[x, y];

  // Bitmap einfärben
  WITH Image1.Picture.Bitmap.Canvas DO
    FOR y := cHeight DOWNTO 1 DO
      FOR x := cWidth downto 1 DO
        IF PGrid^[x, y] <= 0
          then Pixels[x, y] := clBlue
          else begin
            i := Trunc(PGrid^[x, y] * 160 / Ma);
            Pixels[x, y] := $0020F020 + $00010001 * (i div 4) - $00000100 * i;
          end;

  Dispose(PGrid);
end;

Gruß
Michael