progress3

// Original algorithms by slacky, optimized by Janilabo

{ Given a TPA - This function will connect each point, from first to last }
function ConnectPts(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;

{------------------------------------------------------------------------------]
 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.
[------------------------------------------------------------------------------}
function InPoly(pt: TPoint; poly: TPointArray): Boolean;
var
  n, i: Integer;
  z: Extended;
  a, b: TPoint;
begin
  n := Length(poly);
  Result := False;
  if (n > -1) then
  begin
    for i := 0 to (n - 1) do
      if ((pt.X = poly[i].X) and (pt.Y = poly[i].Y)) then
        Break;
    Result := (i < n);
    if not Result then
    begin
      a := poly[0];
      for i := 0 to n do
      begin
        b := poly[(i mod n)];
        if (pt.Y > Min(a.Y, b.Y)) then
          if (pt.Y <= Max(a.Y, b.Y)) then
            if (pt.X <= Max(a.X, b.X)) then
            begin
              if (a.y <> b.y) then
                z := ((pt.Y - a.Y) * (b.X - a.X) / Extended((b.Y - a.Y)) + a.X);
              if ((a.X = b.X) or (pt.X < z)) then
                Result := not Result;
            end;
        a := b;
      end;
    end;
  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;

{ Fills an polygon by the given outlines }
function FillShape(shape: TPointArray): TPointArray;
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);
  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));
          for i := 0 to h do
            if ((d.X = shape[i].X) and (d.Y = shape[i].Y)) then
              Break;
          f := (i <= h);
          if not f then
          begin
            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;
        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;

{ Creates all the points needed to define a simple polygon }
function Xagon(sides: Integer; M, F: TPoint): TPointArray;
var
  x, y, a, b, v: Integer;
  s, c: Extended;
begin
  SetLength(Result, sides);
  x := F.x;
  y := F.y;
  s := Sin(Radians(360.0 / sides));
  c := Cos(Radians(360.0 / sides));
  for v := 0 to (sides - 1) do
  begin
    a := (x - M.x);
    b := (y - M.y);
    x := Round(((b * s) + (a * c) + M.x));
    y := Round(((b * c) - (a * s) + M.y));
    Result[v] := Point(x, y);
  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 := 1; //0 - 9
  ShowPoints := True;  //0 or 1
  case ShowExample of
    // Microshape ------//
    //           TOP            LEFT           BOTTOM         RIGHT
    0: shape := [Point(50, 50), Point(60, 50), Point(51, 51), Point(50, 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 := Xagon(15, Point(100,100), Point(60,100));
    // Xagon: 9 corners //
    7: shape := Xagon(9, Point(100,100), Point(60,50));
    // Xagon: 5 corners AKA Pentagon //
    8: shape := Xagon(5, Point(100,100), Point(74,50));
    // Xagon: 3 corners AKA Triangle //
    9: shape := Xagon(3, Point(100,100), Point(48,48));
  end;
  bmp := CreateBitmap(200, 200);
  t := GetSystemTime;
  TPA := FillShape(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.