GenerationAlgorithms.pas

unit GenerationAlgorithms;

interface
uses
  Windows, Graphics, Math;

procedure SimpleGenerator(var map: TBitmap; const Coef: Integer);
procedure HillGenerator(var map: TBitmap; const iters: Integer);
procedure MidPointDisplacment(var map: TBitmap; const R: Extended);
procedure DiamondSquareGenerator(var map: TBitmap; R: Extended);


implementation
type
  HeightMap = array of array of Extended;

procedure SimpleGenerator(var map: TBitmap; const Coef: Integer);
var
  X, Y, Z, I: Integer;
  Tmp: Integer;
begin
  Randomize;
  for X := 0 to map.Width do
  begin
    for Y := 0 to map.Height do
    begin
      Z := 127 + Random(2*Coef) - Coef;
      map.Canvas.Pixels[x, y] := rgb(z, z, z);
    end;
  end;
end;

function HillAntiAliasing(var map: HeightMap; const x, y: Integer): Extended;
var
  Z: Extended;
begin
  Result := 0;
  Result := Result + map[x - 1, y - 1];
  Result := Result + map[x - 1, y];
  Result := Result + map[x - 1, y + 1];
  Result := Result + map[x, y - 1];
  Result := Result + map[x, y + 1];
  Result := Result + map[x + 1, y - 1];
  Result := Result + map[x + 1, y];
  Result := Result + map[x + 1, y + 1];
  Result := Result / 8;
end;

function HillUpping(var map: TBitmap; const iteration: Integer): HeightMap;
var
  I, X, Y, R, MaxR, Z: Integer;
  X1, Y1, error, delta: Integer;
  dR:Extended;
begin
  Randomize;
  SetLength(Result, map.Width + 1, map.Height + 1);
  for I := 1 to iteration do
  begin
    X := Random(Round(map.Width * 1.1)) - Round(map.Width * 0.1);
    Y := Random(Round(map.Height * 1.1)) - Round(map.Height * 0.1);
    MaxR := Random(255) ;

    for R := 0 to MaxR do
    begin
      x1 := 0;
      y1 := R;
      delta := (2 - 2 * R);
      error := 0;
      dR := Sqrt(Sqr(MaxR) - Sqr(R));
      while y1 >= 0 do
      begin
        if (X + x1 >= 0) and (X+X1 <= map.Width) and (Y + Y1 >= 0) and (Y+Y1 <= map.Height) then
          Result[X + x1, Y + y1] := GetRValue(map.Canvas.Pixels[X + x1, Y + y1]) + dR;
        if (X + x1 >= 0) and (X+X1 <= map.Width) and (Y - Y1 >= 0) and (Y-Y1 <= map.Height) then
          Result[X + x1,Y - y1] := GetRValue(map.Canvas.Pixels[X + x1,Y - y1]) + dR;
        if (X - x1 >= 0) and (X-X1 <= map.Width) and (Y + Y1 >= 0) and (Y+Y1 <= map.Height) then
          Result[X - x1,Y + y1] := GetRValue(map.Canvas.Pixels[X - x1,Y + y1]) + dR;
        if (X - x1 >= 0) and (X-X1 <= map.Width) and (Y - Y1 >= 0) and (Y-Y1 <= map.Height) then
          Result[X - x1,Y - y1] := GetRValue(map.Canvas.Pixels[X - x1,Y - y1]) + dR;

        error := 2 * (delta + y1) - 1;
        if ((delta < 0) and (error <= 0)) then
        begin
          inc(x1);
          delta := delta + (2 * x1 + 1);
          continue;
        end;
        error := 2 * (delta - x1) - 1;
        if ((delta > 0) and (error > 0)) then
        begin
          dec(y1);
          delta := delta + (1 - 2 * y1);
          continue;
        end;
        inc(x1);
        delta := delta + (2 * (x1 - y1));
        dec(y1);
      end;
    end;
  end;

end;

procedure HillCopy(var map: TBitmap; const tmpMap: HeightMap);
var
  X: Integer;
  Y: Integer;
  Z: Integer;
begin
  for X := 0 to map.Width do
  begin
    for Y := 0 to map.Height do
    begin
      Z := Round(tmpMap[x, y]);
      map.Canvas.Pixels[X, Y] := rgb(z, z, z);
    end;
  end;
end;

procedure HillNormalizationAndLiniaization(var map: HeightMap);
const
  criticalLevel = 14;
var
  Max, Min, Z: Extended;
  X, Y: Integer;
  aliased: boolean;
begin
  Max := Low(Integer);
  Min := High(Integer);
  for X := 0 to High(map) do
  begin
    for Y := 0 to High(map[x]) do
    begin
      if map[x, y] > max then
      begin
        max := map[x, y];
      end;
      if map[x, y] < min then
      begin
        min := map[x, y];
      end;
    end;
  end;

  for X := 0 to High(map) do
  begin
    for Y := 0 to High(map[x]) do
    begin
      if Max < 255 then
        map[x, y] := sqr(sqr((map[x, y] - min)/(max - min)))*Max
      else
        map[x, y] := sqr(((map[x, y] - min)/(max - min)))*255;
    end;
  end;

  aliased := true;
  while aliased do
  begin
    for X := 1 to High(map) - 1 do
    begin
      for Y := 1 to High(map[0]) - 1 do
      begin
        while true do
        begin
          aliased := false;
          if (map[x - 1, y - 1] - map[x, y] > criticalLevel)then
          begin
            aliased := true;
            map[x, y] := HillAntiAliasing(map, x, y);
            break;
          end;
          if (map[x - 1, y] - map[x, y] > criticalLevel) then
          begin
            aliased := true;
            map[x, y] := HillAntiAliasing(map, x, y);
            break;
          end;
          if (map[x - 1, y + 1] - map[x, y] > criticalLevel) then
          begin
            aliased := true;
            map[x, y] := HillAntiAliasing(map, x, y);
            break;
          end;
          if (map[x, y - 1] - map[x, y] > criticalLevel) then
          begin
            aliased := true;
            map[x, y] := HillAntiAliasing(map, x, y);
            break;
          end;
          if (map[x, y + 1] - map[x, y] > criticalLevel) then
          begin
            aliased := true;
            map[x, y] := HillAntiAliasing(map, x, y);
            break;
          end;
          if (map[x + 1, y - 1] - map[x, y] > criticalLevel) then
          begin
            aliased := true;
            map[x, y] := HillAntiAliasing(map, x, y);
            break;
          end;
          if (map[x + 1, y] - map[x, y] > criticalLevel)then
          begin
            aliased := true;
            map[x, y] := HillAntiAliasing(map, x, y);
            break;
          end;
          if (map[x + 1, y + 1] - map[x, y] > criticalLevel) then
          begin
            aliased := true;
            map[x, y] := HillAntiAliasing(map, x, y);
            break;
          end;
          break;
        end;
      end;
    end;
  end;
end;

procedure HillGenerator(var map: TBitmap; const iters: Integer);
var
  tmpMap: HeightMap;
begin
  if (map.Width = 0) and (map.Height = 0) then
    exit;

  tmpMap := HillUpping(map, iters);
  HillNormalizationAndLiniaization(tmpMap);
  HillCopy(map, tmpMap);
end;

procedure MidPointRec(var map: TBitmap; const X1, Y1, X2, Y2: Integer; const R: Extended);
var
  TopLeft: Integer;
  TopRight: Integer;
  BottomLeft: Integer;
  BottomRight: Integer;
  col: Integer;
  LeftMove: Integer;
  TopMove: Integer;
begin
  if (X2 - X1 <= 1) and (Y2 - Y1 <= 1) then
    exit;

  LeftMove := Random(((X2 - X1) div 4));
  TopMove := Random(((Y2 - Y1) div 4));

  TopLeft := GetRValue(map.Canvas.Pixels[X1, Y1]);
  TopRight := GetRValue(map.Canvas.Pixels[X1, Y2]);
  BottomLeft := GetRValue(map.Canvas.Pixels[X2, Y1]);
  BottomRight := GetRValue(map.Canvas.Pixels[X2, Y2]);

  //col := (TopLeft + BottomLeft) div 2 + Random(Round(((Y2 - Y1)*R*2))) - Round((Y2 - Y1)*R);
  col := (TopLeft + BottomLeft) div 2 + Random(Round((((Y1 + Y2) div 2 + TopMove - Y1)*R*2))) - Round(((Y1 + Y2) div 2 + TopMove - Y1)*R);
  if col > 255 then
    col := 255
  else if col < 0 then
       col := 0;
  if map.Canvas.Pixels[X1, (Y1 + Y2) div 2 + TopMove] = clBlack then
    map.Canvas.Pixels[X1, (Y1 + Y2) div 2 + TopMove] := rgb(col, col, col);

  col := (TopRight + BottomRight) div 2 + Random(Round((Y1 + Y2) div 2 + TopMove - Y1)) - Round(((Y1 + Y2) div 2 + TopMove - Y1)*R);
  if col > 255 then
    col := 255
  else if col < 0 then
       col := 0;
  if map.Canvas.Pixels[X1, (Y1 + Y2) div 2 + TopMove] = clBlack then
    map.Canvas.Pixels[X1, (Y1 + Y2) div 2 + TopMove] := rgb(col, col, col);

  col := (TopLeft + TopRight) div 2 + Random(Round((((X1 + X2) div 2 + LeftMove - X1)*R*2))) - Round(((X1 + X2) div 2 + LeftMove - X1)*R);
  if col > 255 then
    col := 255
  else if col < 0 then
       col := 0;
  if map.Canvas.Pixels[(X1 + X2) div 2 + LeftMove, Y1] = clBlack then
    map.Canvas.Pixels[(X1 + X2) div 2 + LeftMove, Y1] := rgb(col, col, col);

  col := (BottomLeft + BottomRight) div 2 + Random(Round(((X1 + X2) div 2 + LeftMove - X1)*R*2)) - Round(((X1 + X2) div 2 + LeftMove - X1)*R);
  if col > 255 then
    col := 255
  else if col < 0 then
       col := 0;
  if map.Canvas.Pixels[(X1 + X2) div 2 + LeftMove, Y2] = clBlack then
    map.Canvas.Pixels[(X1 + X2) div 2 + LeftMove, Y2] := rgb(col, col, col);

  col := (BottomLeft + BottomRight + TopLeft + TopRight) div 4 +
    Random(Round(sqrt(Sqr((X1 + X2) div 2 + LeftMove - X1) + Sqr((Y1 + Y2) div 2 + TopMove - Y1))*R*2)) - Round(sqrt(Sqr((X1 + X2) div 2 + LeftMove - X1) + Sqr((Y1 + Y2) div 2 + TopMove - Y1))*R);
  if col > 255 then
    col := 255
  else if col < 0 then
       col := 0;
  if map.Canvas.Pixels[(X1 + X2) div 2 + LeftMove, (Y1 + Y2) div 2 + TopMove] = clBlack then
    map.Canvas.Pixels[(X1 + X2) div 2 + LeftMove, (Y1 + Y2) div 2 + TopMove] := rgb(col, col, col);

  MidPointRec(map, X1, Y1, (X1 + X2) div 2 + LeftMove, (Y1 + Y2) div 2 + TopMove, R);
  MidPointRec(map, (X1 + X2) div 2 + LeftMove, (Y1 + Y2) div 2 + TopMove, X2, Y2, R);
  MidPointRec(map, X1, (Y1 + Y2) div 2 + TopMove, (X1 + X2) div 2 + LeftMove, Y2, R);
  MidPointRec(map, (X1 + X2) div 2 + LeftMove, Y1, X2, (Y1 + Y2) div 2 + TopMove, R);
end;

procedure MidPointDisplacment(var map: TBitmap; const R: Extended);
const
  Zero: Integer = 0;
var
  Col: Integer;
begin
  map.Canvas.Pen.Color := clBlack;
  map.Canvas.Rectangle(-2, -2, map.Width+2, map.Height+2);
  Randomize;
  Col := Random(256);
  map.Canvas.Pixels[0, 0] := rgb(Col, Col, Col);
  Col := Random(256);
  map.Canvas.Pixels[map.Width - 1, 0] := rgb(Col, Col, Col);
  Col := Random(256);
  map.Canvas.Pixels[0, map.Height - 1] := rgb(Col, Col, Col);
  Col := Random(256);
  map.Canvas.Pixels[map.Width - 1, map.Height - 1] := rgb(Col, Col, Col);
  MidPointRec(map, Zero, Zero, map.Width - 1, map.Height - 1, R);
end;

function Sample(const map: TBitmap; const x, y: Integer): Integer;
begin
  result := GetRValue(map.Canvas.Pixels[(x AND (map.Width - 1)), (y AND (map.height - 1))]);
end;

procedure setSample(var map: TBitmap; const x, y: Integer; const value: Integer);
begin
    map.Canvas.Pixels[(x AND (map.Width - 1)), (y AND (map.height - 1))] := rgb(value, value, value);
end;

procedure sampleSquare(var map: TBitmap; x, y, size, value: Integer);
var
  hs: Integer;
  a, b, c, d: Integer;
begin
  hs := size div 2;
  a := sample(map, x - hs, y - hs);
  b := sample(map, x + hs, y - hs);
  c := sample(map, x - hs, y + hs);
  d := sample(map, x + hs, Y + hs);

  SetSample(map, x, y, (a + b + c + d) div 4 + value);
end;

procedure sampleDiamond(var map: TBitmap; x, y, size, value: Integer);
var
  hs: Integer;
  a, b, c, d: Integer;
begin
  hs := size div 2;
  a := sample(map, x - hs, y);
  b := sample(map, x + hs, y);
  c := sample(map, x, y - hs);
  d := sample(map, x, Y + hs);

  SetSample(map, x, y, (a + b + c + d) div 4 + value);
end;

procedure DiamondSquare(var map: TBitmap; stepsize: integer; scale: double);
var
  halfstep: integer;
  x, y: integer;
begin
  halfstep := stepsize div 2;

  y := halfstep;
  while y < map.Height + halfstep do
  begin
    x := halfstep;
    while x < map.Width + halfstep do
    begin
      sampleSquare(map, x, y, stepsize, Round((random(60) - 30) * scale));
      x := x + stepsize;
    end;
    y := y + stepsize;
  end;

  y := 0;
  while y < map.Height do
  begin
    x := 0;
    while x < map.Width do
    begin
      sampleDiamond(map, x + halfstep, y, stepsize, Round((random(60) - 30) * scale));
      sampleDiamond(map, x, y + halfstep, stepsize, Round((random(60) - 30) * scale));
      x := x + stepsize;
    end;
    y := y + stepsize;
  end;
end;

procedure DiamondSquareGenerator(var map: TBitmap; R: Extended);
var
  Col: Integer;
  SampleSize, YStep: Integer;
begin
  Randomize;
  map.Canvas.Brush.Color := clBlack;
  map.Canvas.Brush.Style := bsSolid;
  map.Canvas.Rectangle(-2, -2, map.Width + 2, map.Height + 2);

  sampleSize := map.Width;
  while SampleSize >= 1 do
  begin
    DiamondSquare(map, SampleSize, R);
    R := R / 2;
    SampleSize := SampleSize div 2;
  end;

end;
end.