TPA FloodFill [Simba]

// Original algorithms by slacky, optimized by Janilabo

const
  POLYGON_EXAMPLE = 1; // 0-9.
  DISPLAY_MAINPOINTS = True; // True or False.
  OFFSET = 5; // Used for debug image..
  FLOODFILL_8WAY = False; // Fills TPA bounds (polygon outlines)
  FLOODFILL_COLOR = 65535; // ..with this color.

type
  TFloodFill = (ff4Way, ff8Way);

procedure __TPAFloodFill4Way(var store: array of TBoolArray; skip: array of TBoolArray; X, Y, W, H: Integer);
begin
  if ((X > -1) and (Y > -1) and (X < W) and (Y < H)) then
    if not skip[X][Y] then
      if not store[X][Y] then
      begin
        store[X][Y] := True;
        __TPAFloodFill4Way(store, skip, (X - 1), Y, W, H);
        __TPAFloodFill4Way(store, skip, (X + 1), Y, W, H);
        __TPAFloodFill4Way(store, skip, X, (Y - 1), W, H);
        __TPAFloodFill4Way(store, skip, X, (Y + 1), W, H);
      end;
end;

procedure __TPAFloodFill8Way(var store: array of TBoolArray; skip: array of TBoolArray; X, Y, W, H: Integer);
begin
  if ((X > -1) and (Y > -1) and (X < W) and (Y < H)) then
    if not skip[X][Y] then
      if not store[X][Y] then
      begin
        store[X][Y] := True;
        __TPAFloodFill8Way(store, skip, (X - 1), Y, W, H);
        __TPAFloodFill8Way(store, skip, (X + 1), Y, W, H);
        __TPAFloodFill8Way(store, skip, X, (Y - 1), W, H);
        __TPAFloodFill8Way(store, skip, X, (Y + 1), W, H);
        __TPAFloodFill8Way(store, skip, (X - 1), (Y - 1), W, H);
        __TPAFloodFill8Way(store, skip, (X + 1), (Y + 1), W, H);
        __TPAFloodFill8Way(store, skip, (X + 1), (Y - 1), W, H);
        __TPAFloodFill8Way(store, skip, (X - 1), (Y + 1), W, H);
      end;
end;

procedure TPAFloodFill(var TPA: TPointArray; start: TPoint; method: TFloodFill);
var
  i, l, r, X, Y, W, H: Integer;
  b: TBox;
  store, skip: array of TBoolArray;
begin
  l := Length(TPA);
  if (l > 0) then
  begin
    b := IntToBox(TPA[0].X, TPA[0].Y, TPA[0].X, TPA[0].Y);
    if (l > 1) then
    for i := 1 to (l - 1) do
    begin
      if (TPA[i].X < b.X1) then
        b.X1 := TPA[i].X
      else
        if (TPA[i].X > b.X2) then
          b.X2 := TPA[i].X;
      if (TPA[i].Y < b.Y1) then
        b.Y1 := TPA[i].Y
      else
        if (TPA[i].Y > b.Y2) then
          b.Y2 := TPA[i].Y;
    end;
    if ((start.X >= b.X1) and (start.Y >= b.Y1) and (start.X <= b.X2) and (start.Y <= b.Y2)) then
    begin
      W := ((b.X2 - b.X1) + 1);
      H := ((b.Y2 - b.Y1) + 1);
      SetLength(store, W);
      SetLength(skip, W);
      for i := 0 to (W - 1) do
      begin
        SetLength(skip[i], H);
        SetLength(store[i], H);
      end;
      for i := 0 to (l - 1) do
        skip[(TPA[i].X - b.X1)][(TPA[i].Y - b.Y1)] := True;
      case method of
        ff4Way: __TPAFloodFill4Way(store, skip, (start.X - b.X1), (start.Y - b.Y1), W, H);
        ff8Way: __TPAFloodFill8Way(store, skip, (start.X - b.X1), (start.Y - b.Y1), W, H);
      end;
      SetLength(skip, 0);
      SetLength(TPA, (W * H));
      for Y := 0 to (H - 1) do
        for X := 0 to (W - 1) do
          if store[X][Y] then
          begin
            TPA[r] := Point((X + b.X1), (Y + b.Y1));
            Inc(r);
          end;
      SetLength(TPA, r);
    end;
  end;
end;

procedure TPAFloodFill4Way(var TPA: TPointArray; start: TPoint);
var
  i, l, r, X, Y, W, H: Integer;
  b: TBox;
  store, skip: array of TBoolArray;
begin
  l := Length(TPA);
  if (l > 0) then
  begin
    b := IntToBox(TPA[0].X, TPA[0].Y, TPA[0].X, TPA[0].Y);
    if (l > 1) then
    for i := 1 to (l - 1) do
    begin
      if (TPA[i].X < b.X1) then
        b.X1 := TPA[i].X
      else
        if (TPA[i].X > b.X2) then
          b.X2 := TPA[i].X;
      if (TPA[i].Y < b.Y1) then
        b.Y1 := TPA[i].Y
      else
        if (TPA[i].Y > b.Y2) then
          b.Y2 := TPA[i].Y;
    end;
    if ((start.X >= b.X1) and (start.Y >= b.Y1) and (start.X <= b.X2) and (start.Y <= b.Y2)) then
    begin
      W := ((b.X2 - b.X1) + 1);
      H := ((b.Y2 - b.Y1) + 1);
      SetLength(store, W);
      SetLength(skip, W);
      for i := 0 to (W - 1) do
      begin
        SetLength(skip[i], H);
        SetLength(store[i], H);
      end;
      for i := 0 to (l - 1) do
        skip[(TPA[i].X - b.X1)][(TPA[i].Y - b.Y1)] := True;
      __TPAFloodFill4Way(store, skip, (start.X - b.X1), (start.Y - b.Y1), W, H);
      SetLength(skip, 0);
      SetLength(TPA, (W * H));
      for Y := 0 to (H - 1) do
        for X := 0 to (W - 1) do
          if store[X][Y] then
          begin
            TPA[r] := Point((X + b.X1), (Y + b.Y1));
            Inc(r);
          end;
      SetLength(TPA, r);
    end;
  end;
end;

procedure FloodFillBitmap8WayEx(var bmp: Integer; start: TPoint; oldColor, newColor, tol: Integer);
begin
  try
    if SimilarColors(FastGetPixel(bmp, start.x, start.y), oldColor, tol) then
    begin
      FastSetPixel(bmp, start.x, start.y, newColor);
      FloodFillBitmap8WayEx(bmp, Point((start.x - 1), start.y), oldColor, newColor, tol);
      FloodFillBitmap8WayEx(bmp, Point((start.x + 1), start.y), oldColor, newColor, tol);
      FloodFillBitmap8WayEx(bmp, Point(start.x, (start.y - 1)), oldColor, newColor, tol);
      FloodFillBitmap8WayEx(bmp, Point(start.x, (start.y + 1)), oldColor, newColor, tol);
      FloodFillBitmap8WayEx(bmp, Point((start.x - 1), (start.y - 1)), oldColor, newColor, tol);
      FloodFillBitmap8WayEx(bmp, Point((start.x + 1), (start.y + 1)), oldColor, newColor, tol);
      FloodFillBitmap8WayEx(bmp, Point((start.x + 1), (start.y - 1)), oldColor, newColor, tol);
      FloodFillBitmap8WayEx(bmp, Point((start.x - 1), (start.y + 1)), oldColor, newColor, tol);
    end;
  except
  end;
end;

{==============================================================================]
  Explanation: Returns polygon by given outlines (shape)
  NOTE: Original algorithm by slacky (warpie)
[==============================================================================}
function TPAFromPolygon(shape: TPointArray): TPointArray;
var
  b: TBox;
  x, y, h, i, l, r, z: Integer;
  o: TPointArray;
  f: Boolean;
  t: array of TBoolArray;
  e: Extended;
  q, p, d: TPoint;
begin
  h := High(shape);
  if (h > -1) then
  begin
    b := IntToBox(shape[0].X, shape[0].Y, shape[0].X, shape[0].Y);
    for i := 0 to h do
    begin
      q := shape[i];
      if (i < h) then
        p := shape[(i + 1)]
      else
        p := shape[0];
      r := Length(o);
      if ((q.X <> p.X) or (q.Y <> p.Y)) then
      begin
        l := Max(Round(Abs(q.X - p.X)), Round(Abs(q.Y - p.Y)));
        SetLength(o, ((r + l) + 1));
        for z := 0 to l do
          o[(r + z)] := Point((q.X + Round((p.X - q.X) * (z / Extended(l)))), (q.Y + Round((p.Y - q.Y) * (z / Extended(l)))));
      end else
      begin
        SetLength(o, (r + 1));
        o[r] := q;
      end;
      if (shape[i].X < b.X1) then
        b.X1 := shape[i].X
      else
        if (shape[i].X > b.X2) then
          b.X2 := shape[i].X;
      if (shape[i].Y < b.Y1) then
        b.Y1 := shape[i].Y
      else
        if (shape[i].Y > b.Y2) then
          b.Y2 := shape[i].Y;
    end;
    SetLength(t, ((b.X2 - b.X1) + 1));
    for i := 0 to (b.X2 - b.X1) do
      SetLength(t[i], ((b.Y2 - b.Y1) + 1));
    l := Length(o);
    for i := 0 to (l - 1) do
      if not t[(o[i].X - b.X1)][(o[i].Y - b.Y1)] then
        t[(o[i].X - b.X1)][(o[i].Y - b.Y1)] := True;
    SetLength(o, 0);
    for y := 0 to (b.Y2 - b.Y1) do
      for x := 0 to (b.X2 - b.X1) do
      begin
        f := t[x][y];
        if not f then
        begin
          d := Point((x + b.X1), (y + b.Y1));
          q := shape[0];
          for i := 0 to (h + 1) do
          begin
            p := shape[(i mod (h + 1))];
            if (d.Y > Min(q.Y, p.Y)) then
              if (d.Y <= Max(q.Y, p.Y)) then
                if (d.X <= Max(q.X, p.X)) then
                begin
                  if (q.y <> p.y) then
                    e := ((d.Y - q.Y) * (p.X - q.X) / Extended((p.Y - q.Y)) + q.X);
                  if ((q.X = p.X) or (d.X < e)) then
                    f := not f;
                end;
            q := p;
          end;
        end;
        if f then
        begin
          l := Length(Result);
          SetLength(Result, (l + 1));
          Result[l] := Point((x + b.X1), (y + b.Y1));
        end;
      end;
    SetLength(t, 0);
  end else
    SetLength(Result, 0);
end;

{==============================================================================]
  Explanation: Given a TPA - this function will connect each point, from first to last.
  NOTE: Original algorithm by slacky (warpie)
[==============================================================================}
function TPAConnect(pts: TPointArray): TPointArray;
var
  i, j, h, l, r, a: Integer;
  q, p: TPoint;
begin
  if (High(pts) > -1) then
  begin
    h := High(pts);
    for i := 0 to h do
    begin
      j := (i + 1);
      if (i = h) then
        j := 0;
      q := pts[i];
      p := pts[j];
      r := Length(Result);
      if ((q.X <> p.X) or (q.Y <> p.Y)) then
      begin
        l := Max(Round(Abs(q.X - p.X)), Round(Abs(q.Y - p.Y)));
        SetLength(Result, ((r + l) + 1));
        for a := 0 to l do
          Result[(r + a)] := Point((q.X + Round((p.X - q.X) * (a / Extended(l)))), (q.Y + Round((p.Y - q.Y) * (a / Extended(l)))));
      end else
      begin
        SetLength(Result, (r + 1));
        Result[r] := q;
      end;
    end;
  end else
    SetLength(Result, 0);
end;

{==============================================================================]
  Explanation: Check if a point is within a polygon/shape by the given outline points (shape)
               The points MUST be in order, as if you would draw a line trough each point.
  NOTE: Original algorithm by slacky (warpie)
[==============================================================================}
function InPolygon(pt: TPoint; shape: TPointArray): Boolean;
var
  b: TBox;
  x, y, h, i, v, l, r, z: Integer;
  o: TPointArray;
  f: Boolean;
  t: array of TBoolArray;
  e: Extended;
  q, p, d: TPoint;
begin
  h := High(shape);
  Result := False;
  if (h > -1) then
  begin
    b := IntToBox(shape[0].X, shape[0].Y, shape[0].X, shape[0].Y);
    for i := 0 to h do
    begin
      if (shape[i].X < b.X1) then
        b.X1 := shape[i].X
      else
        if (shape[i].X > b.X2) then
          b.X2 := shape[i].X;
      if (shape[i].Y < b.Y1) then
        b.Y1 := shape[i].Y
      else
        if (shape[i].Y > b.Y2) then
          b.Y2 := shape[i].Y;
    end;
    if ((pt.X >= b.X1) and (pt.Y >= b.Y1) and (pt.X <= b.X2) and (pt.Y <= b.Y2)) then
    begin
      SetLength(t, ((b.X2 - b.X1) + 1));
      for i := 0 to (b.X2 - b.X1) do
        SetLength(t[i], ((b.Y2 - b.Y1) + 1));
      for i := 0 to h do
      begin
        v := (i + 1);
        if (i = h) then
          v := 0;
        q := shape[i];
        p := shape[v];
        r := Length(o);
        if ((q.X <> p.X) or (q.Y <> p.Y)) then
        begin
          l := Max(Round(Abs(q.X - p.X)), Round(Abs(q.Y - p.Y)));
          SetLength(o, ((r + l) + 1));
          for z := 0 to l do
            o[(r + z)] := Point((q.X + Round((p.X - q.X) * (z / Extended(l)))), (q.Y + Round((p.Y - q.Y) * (z / Extended(l)))));
        end else
        begin
          SetLength(o, (r + 1));
          o[r] := q;
        end;
      end;
      l := Length(o);
      for i := 0 to (l - 1) do
        if not t[(o[i].X - b.X1)][(o[i].Y - b.Y1)] then
           t[(o[i].X - b.X1)][(o[i].Y - b.Y1)] := True;
      for y := 0 to (b.Y2 - b.Y1) do
      begin
        for x := 0 to (b.X2 - b.X1) do
        begin
          f := t[x][y];
          if not f then
          begin
            d := Point((x + b.X1), (y + b.Y1));
            q := shape[0];
            for i := 0 to (h + 1) do
            begin
              p := shape[(i mod (h + 1))];
              if (d.Y > Min(q.Y, p.Y)) then
                if (d.Y <= Max(q.Y, p.Y)) then
                  if (d.X <= Max(q.X, p.X)) then
                  begin
                    if (q.y <> p.y) then
                      e := ((d.Y - q.Y) * (p.X - q.X) / Extended((p.Y - q.Y)) + q.X);
                    if ((q.X = p.X) or (d.X < e)) then
                      f := not f;
                  end;
              q := p;
            end;
          end;
          if f then
          begin
            t[x][y] := True;
            Result := t[(pt.X - b.X1)][(pt.Y - b.Y1)];
          end;
        end;
        if Result then
          Break;
      end;
      SetLength(t, 0);
    end;
  end;
end;

{==============================================================================]
  Explanation: Creates all the points needed to define a simple polygon
  NOTE: Original algorithm by slacky (warpie)
[==============================================================================}
function TPAXagon(sides: Integer; C, S: TPoint): TPointArray;
var
  x, y, a, b, v: Integer;
  n, m: Extended;
begin
  if (sides > 2) then
  begin
    SetLength(Result, sides);
    x := S.x;
    y := S.y;
    n := Sin(Radians(360.0 / sides));
    m := Cos(Radians(360.0 / sides));
    for v := 0 to (sides - 1) do
    begin
      a := (x - C.x);
      b := (y - C.y);
      x := Round(((b * n) + (a * m) + C.x));
      y := Round(((b * m) - (a * n) + C.y));
      Result[v] := Point(x, y);
    end;
  end else
    SetLength(Result, 0);
end;

//******* DIRTY EXAMPLE BELLOW: *******//
procedure SetPixels(bmp: Integer; TPA: TPointArray; color: Integer);
var
  a, z, w, h: Integer;
begin
  z := High(TPA);
  if (z > -1) then
  begin
    GetBitmapSize(bmp, w, h);
    for a := 0 to z do
      if ((TPA[a].X >= 0) and (TPA[a].Y >= 0) and (TPA[a].X < w) and (TPA[a].Y < h)) then
        FastSetPixel(bmp, TPA[a].X, TPA[a].Y, color);
  end;
end;

procedure SetPixelsMP(bmp: Integer; TPA: TPointArray; color: Integer);
var
  a, z, w, h: Integer;
begin
  z := High(TPA);
  if (z > -1) then
  begin
    GetBitmapSize(bmp, w, h);
    for a := 0 to z do
      if ((TPA[a].X > 0) and (TPA[a].Y > 0) and (TPA[a].X < (w - 1)) and (TPA[a].Y < (h - 1))) then
      begin
        FastSetPixel(bmp, (TPA[a].X - 1), TPA[a].Y, color);
        FastSetPixel(bmp, (TPA[a].X + 1), TPA[a].Y, color);
        FastSetPixel(bmp, TPA[a].X, (TPA[a].Y + 1), color);
        FastSetPixel(bmp, TPA[a].X, (TPA[a].Y - 1), color);
      end;
  end;
end;

function GetPixels(bmp: Integer; TPA: TPointArray): TIntegerArray;
var
  w, h, i, l: Integer;
begin
  l := Length(TPA);
  try
    GetBitmapSize(bmp, w, h);
  except
  end;
  SetLength(Result, l);
  for i := 0 to (l - 1) do
    if ((TPA[i].X > -1) and (TPA[i].Y > -1) and (TPA[i].X < w) and (TPA[i].Y < h)) then
      Result[i] := FastGetPixel(bmp, TPA[i].X, TPA[i].Y)
    else
      Result[i] := -1;
end;

function GetBitmapColorTPA(bmp: Integer; color: Integer): TPointArray;
var
  w, h, x, y, r: Integer;
begin
  try
    GetBitmapSize(bmp, w, h);
  except
  end;
  if ((w > 0) and (h > 0)) then
  begin
    SetLength(Result, (w * h));
    for y := 0 to (h - 1) do
      for x := 0 to (w - 1) do
        if (FastGetPixel(bmp, x, y) = color) then
        begin
          Result[r] := Point(x, y);
          Inc(r);
        end;
  end;
  SetLength(Result, r);
end;

{==============================================================================]
  Explanation: Replaces TPA with all the edge-points from TPA.
               Edge-points are points that are on the edge of the TPA, not completely surrounded by other points.
[==============================================================================}
procedure TPAEdge(var TPA: TPointArray);
var
  v, x, y, h, r: Integer;
  B: array of TBoolArray;
  bx: TBox;
begin;
  h := High(TPA);
  if (h > 3) then
  begin
    bx := IntToBox(TPA[0].X, TPA[0].Y, TPA[0].X, TPA[0].Y);
    for v := 1 to h do
    begin
      if (TPA[v].X < bx.X1) then
        bx.X1 := TPA[v].X
      else
        if (TPA[v].X > bx.X2) then
          bx.X2 := TPA[v].X;
      if (TPA[v].Y < bx.Y1) then
        bx.Y1 := TPA[v].Y
      else
        if (TPA[v].Y > bx.Y2) then
          bx.Y2 := TPA[v].Y;
    end;
    bx := IntToBox((bx.X1 - 1), (bx.Y1 - 1), (bx.X2 + 1), (bx.Y2 + 1));
    SetLength(B, ((bx.X2 - bx.X1) + 1));
    for v := 0 to (bx.X2 - bx.X1) do
      SetLength(B[v], ((bx.Y2 - bx.Y1) + 1));
    for v := 0 to h do
      if not B[(TPA[v].X - bx.X1)][(TPA[v].Y - bx.Y1)] then
        B[(TPA[v].X - bx.X1)][(TPA[v].Y - bx.Y1)] := True;
    for y := 1 to ((bx.Y2 - bx.Y1) - 1) do
      for x := 1 to ((bx.X2 - bx.X1) - 1) do
        if B[x][y] then
          if not (B[(x - 1)][y] and B[x][(y - 1)] and B[(x + 1)][y] and B[x][(y + 1)]) then
          begin
            TPA[r].X := (x + bx.X1);
            TPA[r].Y := (y + bx.Y1);
            Inc(r);
          end;
    SetLength(TPA, r);
    SetLength(B, 0);
  end;
end;

procedure Setup;
var
  shape, TPA: TPointArray;
  bmp, t, o: Integer;
  v: Boolean;
  a: TBox;
begin
  //Dynamic shapes from Example 6 and down:
  v := True;
  case POLYGON_EXAMPLE of
    // Microshape ------//
    //           TOP           LEFT           BOTTOM          RIGHT
    0: shape := [Point(20,20), Point(20,120), Point(120,120), Point(120,20)];
    // Arrow like shape //
    1: shape := [Point(70,90),Point(185,90),Point(185,116), Point(70,116), //Square +
                 Point(70,140),Point(35,105),Point(70,70)];                //Triangle
    // Triangle --------//
    2: shape := [Point(50,50),Point(0,100),Point(100,150)];
    // Raped pentagon --//
    3: shape := [Point(10,25),Point(35,5),Point(82,22),Point(50,90),Point(4,60)];
    // Octagon ---------//
    4: shape := [Point(100,30), Point(155,50),  //Top-Right
                 Point(180,110),Point(155,160), //Right-Bottom
                 Point(100,180),Point(45,160),  //Bottom-Left
                 Point(20,100), Point(45,50)];  //Left-Top
    // S-shape ---------//
    5: shape := [Point(135,50),Point(123,70),Point(103,58),Point(85,70),Point(85,85),
                 Point(122,105),Point(132,125),Point(120,155),Point(78,164),Point(55,147),
                 Point(64,128),Point(80,140),Point(100,140),Point(96,116),Point(62,98),
                 Point(60,55),Point(111,35)];
    // Xagon: 15 corners //
    6: shape := TPAXagon(15, Point(100,100), Point(60,100));
    // Xagon: 9 corners //
    7: shape := TPAXagon(9, Point(100,100), Point(60,50));
    // Xagon: 5 corners AKA Pentagon //
    8: shape := TPAXagon(5, Point(100,100), Point(74,50));
    // Xagon: 3 corners AKA Triangle //
    9: shape := TPAXagon(3, Point(100,100), Point(48,48));
  else
    v := False;
  end;
  if v then
  begin
    if ((a.X1 > -1) and (a.Y1 > -1)) then
    begin
      if (OFFSET > 0) then
        o := OFFSET;
      t := GetSystemTime;
      if (o > 0) then
        OffsetTPA(shape, Point(o, o));
      TPA := TPAFromPolygon(shape);
      WriteLn('Polygon created in ' + IntToStr(GetSystemTime - t) + ' ms.');
      a := GetTPABounds(TPA);
      bmp := CreateBitmap((a.X2 + o), (a.Y2 + o));
      TPAEdge(TPA);
      t := GetSystemTime;
      if FLOODFILL_8WAY then
        TPAFloodFill(TPA, MiddleTPA(TPA), ff8Way)
      else
        TPAFloodFill(TPA, MiddleTPA(TPA), ff4Way);
      WriteLn('Polygon area floodfilled in ' + IntToStr(GetSystemTime - t) + ' ms.');
      SetPixels(bmp, TPA, FLOODFILL_COLOR);
      if DISPLAY_MAINPOINTS then
        SetPixelsMP(bmp, shape, 16777215);
      DisplayDebugImgWindow((a.X2 + a.X1), (a.Y2 + a.Y1));
      DrawBitmapDebugImg(bmp);
      FreeBitmap(bmp);
      SetLength(TPA, 0);
    end else
      WriteLn('Invalid TPA! Negative points found...');
  end else
    WriteLn('Invalid polygon ID!');
end;

begin
  Setup;
end.