TPA Polygon Development

// Original algorithms by slacky, optimized by Janilabo

{==============================================================================]
  Explanation: Returns polygon by given outlines (shape)
  NOTE: Original algorithm by slacky (warpie)
[==============================================================================}
function TPAPolygon(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 (i > 0) then
      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;
    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 (poly)
               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
    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;
      if (i > 0) then
      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 else
        b := IntToBox(shape[0].X, shape[0].Y, shape[0].X, shape[0].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
          t[x][y] := True;
      end;
    Result := t[(pt.X - b.X1)][(pt.Y - b.Y1)];
    SetLength(t, 0);
  end else
    Result := False;
end;

{ Creates all the points needed to define a simple polygon }
function TPAXagon(sides: Integer; C, S: TPoint): TPointArray;
var
  x, y, a, b, v: Integer;
  n, m: Extended;
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;

//******* 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;

//******* Plot a few shapes using this algorithm *******//
var
  shape, TPA: TPointArray;
  bmp, t: Integer;
  ShowExample: Integer;
  ShowPoints: Boolean;

begin
  //Dynamic shapes from Example 6 and down:
  ShowExample := 4; //0 - 9
  ShowPoints := True;  //0 or 1
  case ShowExample of
    // Microshape ------//
    //           TOP            LEFT           BOTTOM         RIGHT
    0: shape := [Point(50, 50), Point(50, 51), Point(51, 50), Point(51, 51)];
    // 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));
  end;
  bmp := CreateBitmap(200, 200);
  t := GetSystemTime;
  TPA := TPAPolygon(shape);
  WriteLn(IntToStr(GetSystemTime - t) + ' ms.');
  SetPixels(bmp, TPA, 357435);
  if ShowPoints then
    SetPixelsMP(bmp, shape, 16777215);
  DisplayDebugImgWindow(200, 200);
  DrawBitmapDebugImg(bmp);
  FreeBitmap(bmp);
  SetLength(TPA, 0);
end.