Inseln auf ein Image malen

[sirius]

Zitat von Zerolith:

Die Zahl?

Projekt -> Optionen -> Linker ==> Maximale Stackgröße

[xZise]

So... Ich bins wieder Und zwar bekomme ich jetzt ein Problem mit dem Zeiger-Code... (AV):

Delphi-Quellcode:

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;

Der Fehler tritt je nach Zufall in den Zeilen 43, 44, 48 oder 49 auf.

[Hawkeye219]

Hallo Fabian,

ein mehrdimensionales, dynamisches Array belegt keinen zusammenhängenden Speicherbereich. Das Löschen solltest du also besser so durchführen:

Delphi-Quellcode:

for y := 0 to High(PGrid^) do
  for x := 0 to High(PGrid^[y]) do
    PGrid^[x, y] := 0;

In der letzten Ebene (x) könntest du prinzipiell auch mit FillChar arbeiten.

In Zeile 63 ist wahrscheinlich der Endwert der y-Schleife falsch:

FOR y := AHeight - 2 DOWNTO 12 DO // 1 statt 12? Bei der Schleife zum Einfärben der Bitmap solltest du die Schleifenparameter prüfen. Der Zugriff auf PGrid^[AWidth, AHeight] dürfte ebenfalls zu einem Fehler führen. Eine einfache Verschiebung beider Laufvariablen um 1 führt allerdings zu Problemen im ELSE-Zweig.

Gruß Hawkeye

[xZise]

Hallo Hawkeye !
Danke erstmal für den Report!

Zitat von Hawkeye219:

ein mehrdimensionales, dynamisches Array belegt keinen zusammenhängenden Speicherbereich. Das Löschen solltest du also besser so durchführen:

Delphi-Quellcode:

for y := 0 to High(PGrid^) do
  for x := 0 to High(PGrid^[y]) do
    PGrid^[x, y] := 0;

In der letzten Ebene (x) könntest du prinzipiell auch mit FillChar arbeiten.

Danke.... Wusste ich nicht! Aber daran wirds doch wohl kaum liegen oder

Zitat von Hawkeye219:

In Zeile 63 ist wahrscheinlich der Endwert der y-Schleife falsch:

FOR y := AHeight - 2 DOWNTO 12 DO // 1 statt 12?

OOPs... ja da hast du recht

Zitat von Hawkeye219:

Bei der Schleife zum Einfärben der Bitmap solltest du die Schleifenparameter prüfen. Der Zugriff auf PGrid^[AWidth, AHeight] dürfte ebenfalls zu einem Fehler führen. Eine einfache Verschiebung beider Laufvariablen um 1 führt allerdings zu Problemen im ELSE-Zweig.

Jo ^^ Da muss ich den Zugriff modifizieren (habe es da wohl vergessen).

Danke Aber ich glaube kaum, dass es daran liegt...

MfG, xZise

[Hawkeye219]

Zitat von xZise:

Aber daran wirds doch wohl kaum liegen oder?

Da bin ich anderer Meinung.

Delphi-Quellcode:

type
  TGrid = array of array of SmallInt;
var
  Grid : TGrid;
begin
  SetLength (Grid, 10, 20);
end;

Im obigen Beispiel ist Grid ein Zeiger auf ein Array mit 10 Zeigern auf jeweils ein Array mit 20 SmallInt-Elementen. In Wirklichkeit sind noch einige Verwaltungsdaten dabei, das tut aber nichts zur Sache. SizeOf(TGrid) wird immer den Wert 4 liefern - die Größe eines Zeigers.

Mit dem FillChar-Befehl in deinem Code löschst du nicht den Inhalt des Arrays, sondern einen Teil der Zeigerstruktur bzw. der Verwaltungsinformationen. Dies muß früher oder später zum Absturz führen.

Gruß Hawkeye

[xZise]

Jo Is mir auch aufgefallen! Funktioniert jetzt wunderbar! Danke!

[jmit]

Hallo,

Zitat von 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

Egal ob rund oder nicht rund, die Idee gefällt mir sehr gut.

Gruß Jörg

[grizzly]

Mittlerweile weiß ich wenigstens wieder, wo ich von diesem Verfahren gelesen hatte:
Benoît B. Mandelbrot, Die fraktale Geometrie der Natur, Birkhäuser Verlag, 1987.

Irgendwo in der Mitte des Buches gibt es ein Kapitel "Die Erzeugung eines Brown-Reliefs", in dem der Algorithmus beschrieben wird (allerdings ein klein wenig anders, als ich ihn in Erinnerung hatte: Der Höhenunterschied zwischen den durch einen Schnitt entstehenden Seiten kann zufällig gewählt werden, außerdem wird noch eine Normierung bzgl. der Anzahl der Durchläufe angewandt (Multiplikation mit der Wurzel aus der Anzahl der Durchläufe)).

Dieses Kapitel wiederum bezieht sich auf eine andere Veröffentlichung Mandelbrots: Fonctions aléatoires pluritemporelles: approximation poissonien ne du cas brownien et généralisations. Comptes Rendus (Paris), 280 A, 1075-1078, was mir nix nutzt, weil ich kein Französisch kann

Gruß
Michael

[xZise]

Übrigens hatte ich einmal eine verbesserte Variante mit Kreisen Dann stand nicht von anfang an fest, wo viel Land sein wird. (Weil bei der obigen ist das meißte Land dort, wo als erstes Land erzeugt wurde). Leider ist der Code regelrecht "verbruzelt"... Und ich hatte leider keine Sicherungskopie auf'm Rechner

Aber als Tipp (welche das ummodifizieren wollen):
Statt zu überprüfen, ob der Punkt im oder außerhalb des Kreises ist:

Delphi-Quellcode:

if Sqrt(Power(x, 2) + Power(y, 2)) >{=} r then
  // außerhalb

kann man das besser mit "a² + b² = c²" lösen:

Delphi-Quellcode:

if Power(x, 2) + Power(y, 2) >{=} Power(r, 2) then
  //außerhalb

wobei ich nicht weiß, ob "IntPower(x, 2)", "Power(x, 2)" oder "x * x" schneller ist.
Aber die obige Verbesserung mach den Algo um ein vielfaches Schneller (Mensch hatte ich da gestaunt xD)

[grizzly]

Falls doch mal jemand schnell mit dem Algorithmus von Herrn Mandelbrot ein wenig herumspielen will: Im Anhang ist der Source-Code zu meinem Testprogramm. (Testprogramm! d.h. keine Kommentare! )

Achtung: Wenn man Randseed nicht ändert, dann erhält man immer dieselbe Landkarte.

Ein AVI mit der Erschaffung einer Insel gibt es hier (2MB).

Gruß
Michael