Fill a polygon

Problem/Question/Abstract:

How to fill a polygon

Answer:

Below is a demo application with all code inside for drawing and hit-testing polygons. It uses an algorithm which searches for intersections between each scanline (or Y coordinate) with polygon vertices. It is not optimized (though it's quite fast) and it's also universal. It fills all types of polygons, not just concave, or similar. Filling style is equivalent to WINDING comparing to GDI and cannot be changed so far. The slowest part of polygon filling is it's rasterization, also called the polygon scan conversion where polygon has to be transformed into regions that needs to be filled. This can be speed up by caching previously calculated fill ranges. You can do that yourself or you can use TPolygon object that is included. It caches ranges by itself. Note that caching will only work if points do not change (cache is discarded on each point change) but for hit-testing you don't need to use caching because ranges for only one scanline are calculates and not for whole polygon (except if you use TPolygon object where all ranges are precalculated).

unit Main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Spin;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Label1: TLabel;
    SpinEdit1: TSpinEdit;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure SpinEdit1Change(Sender: TObject);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

type
  {Stores a fill range which is equal to a scanline but there can be many fill ranges for one X coordinate}
  TRange = packed record
    X: Integer;
    Count: Word;
  end;
  TRangeList = array of TRange;
  TRangeListArray = array of TRangeList;

  {TPolygon class represents a polygon. It containes points that define a polygon and
  caches fill range list for fast polygon filling.}
  TPolygon = class
  private
    FPoints: array of TPoint;
    FStartY: Integer;
    FRangeList: TRangeListArray;

    function GetCount: Integer;
    procedure SetCount(AValue: Integer);
    function GetPoint(Index: Integer): TPoint;
    procedure SetPoint(Index: Integer; APoint: TPoint);
  protected
    {Initializes range list}
    procedure RangeListNeeded;
    function GetFillRange(Y: Integer): TRangeList;
  public
    constructor Create;
    destructor Destroy; override;
    procedure AssignPoints(APoints: array of TPoint);
    procedure Offset(dx, dy: Integer);
    property Count: Integer read GetCount write SetCount;
    property Points[Index: Integer]: TPoint read GetPoint write SetPoint;
  end;

  {Returns fill range list for specified Y coordinate. It calculates intersection
  points with specified scanline (at Y coordinates).}
procedure Polygon_GetFillRange(const Points: array of TPoint; Y: Integer;
  out ARangeList: TRangeList);
{Returns bounds of polygon}
function Polygon_GetBounds(const Points: array of TPoint): TRect;
{Returns True if point lies inside polygon}
function Polygon_PtInside(const Points: array of TPoint; Pt: TPoint): Boolean;

implementation

{$R *.dfm}

type
  pRangeItem = ^TRangeItem;
  TRangeItem = record
    X: Integer;
    Up: Boolean;
    Next: pRangeItem;
  end;

procedure Polygon_GetFillRange(const Points: array of TPoint; Y: Integer;
  out ARangeList: TRangeList);
var
  {first item in list}
  AItem: pRangeItem;

  procedure AddIntersection(X: Integer; Up: Boolean);
  var
    p, p2, Prev: pRangeItem;
  begin
    New(p);
    Prev := nil;
    p^.X := X;
    p^.Up := Up;
    p^.Next := nil;
    if Assigned(AItem) then
    begin
      {insert into sorted position}
      p2 := AItem;
      while Assigned(p2) do
      begin
        if p2^.X > X then
        begin
          if Assigned(Prev) then
          begin
            Prev^.Next := p;
            p^.Next := p2;
            Break;
          end
          else
          begin
            p^.Next := p2;
            AItem := p;
            Break;
          end;
        end;
        if p2^.Next = nil then
        begin
          {add to the end}
          p2^.Next := p;
          Break;
        end;
        Prev := p2;
        p2 := p2^.Next;
      end;
    end
    else
      AItem := p;
  end;

var
  i, X, X0, Cnt: Integer;
  LastDirection: Boolean;
  p: pRangeItem;
begin
  if Length(Points) = 0 then
    Exit;
  AItem := nil;
  Cnt := 0;
  for i := 0 to Length(Points) - 2 do
  begin
    if ((Points[i].Y > Y) and (Points[i + 1].Y <= Y)) or ((Points[i].Y <= Y) and
      (Points[i + 1].Y > Y)) then
      if Points[i + 1].Y <> points[i].Y then
      begin
        X := Round(Points[i].X + ((Points[i + 1].X - Points[i].X) *
          (Y - Points[i].Y) / (Points[i + 1].Y - points[i].Y)));
        AddIntersection(X, Points[i + 1].Y > Points[i].Y);
        Inc(Cnt);
      end;
  end;
  {close polygon}
  i := Length(Points) - 1;
  if ((Points[i].Y > Y) and (Points[0].Y <= Y)) or ((Points[i].Y <= Y) and (Points[0].Y
    > Y)) then
    if Points[0].Y <> points[i].Y then
    begin
      X := Round(Points[i].X + ((Points[0].X - Points[i].X) * (Y - Points[i].Y) /
        (Points[0].Y - points[i].Y)));
      AddIntersection(X, Points[0].Y > Points[i].Y);
      Inc(Cnt);
    end;
  p := AItem;
  {calculate fill ranges}
  i := 1; {use as acumulative direction counter}
  SetLength(ARangeList, Cnt);
  Cnt := 0; {number of range items in array}
  if Assigned(AItem) then
  begin
    LastDirection := AItem^.Up; {init last direction}
    X0 := AItem^.X;
    AItem := AItem^.Next;
  end;
  while Assigned(AItem) do
  begin
    if AItem^.Up = LastDirection then
    begin
      Inc(i);
      if i = 1 then
        X0 := AItem^.X; {init start position}
    end
    else
    begin
      Dec(i);
      if i = -1 then
        X0 := AItem^.X; {init start position}
    end;
    if i = 0 then
    begin
      ARangeList[Cnt].X := X0;
      ARangeList[Cnt].Count := AItem^.X - X0;
      Inc(Cnt);
      LastDirection := AItem^.Up;
    end;
    AItem := AItem^.Next;
  end;
  {shrink list}
  SetLength(ARangeList, Cnt);
  {delete internal range list}
  while Assigned(p) do
  begin
    AItem := p;
    p := p^.Next;
    Dispose(AItem);
  end;
end;

function Polygon_GetBounds(const Points: array of TPoint): TRect;
var
  i: Integer;
begin
  Result := Rect(0, 0, 0, 0);
  for i := 0 to Length(Points) - 1 do
  begin
    if i = 0 then
      Result := Rect(Points[i].X, Points[i].Y, Points[i].X, Points[i].Y)
    else
    begin
      if Points[i].X < Result.Left then
        Result.Left := Points[i].X;
      if Points[i].Y < Result.Top then
        Result.Top := Points[i].Y;
      if Points[i].X > Result.Right then
        Result.Right := Points[i].X;
      if Points[i].Y > Result.Bottom then
        Result.Bottom := Points[i].Y;
    end;
  end;
  Result.Right := Result.Right + 1;
  Result.Bottom := Result.Bottom + 1;
end;

function Polygon_PtInside(const Points: array of TPoint; Pt: TPoint): Boolean;
var
  RL: TRangeList;
  i: Integer;
begin
  Result := False;
  Polygon_GetFillRange(Points, Pt.Y, RL);
  for i := 0 to Length(RL) - 1 do
  begin
    Result := (Pt.X >= RL[i].X) and (Pt.X < RL[i].X + RL[i].Count);
    if Result then
      Exit;
  end;
end;

{TPolygon}

procedure TPolygon.AssignPoints(APoints: array of TPoint);
begin
  SetLength(FRangeList, 0);
  SetLength(FPoints, Length(APoints));
  Move(APoints, FPoints, Length(APoints) * SizeOf(TPoint));
  {clear cache}
  SetLength(FRangeList, 0);
end;

constructor TPolygon.Create;
begin
  SetLength(FPoints, 0);
  SetLength(FRangeList, 0);
  FStartY := 0;
end;

destructor TPolygon.Destroy;
begin
  SetLength(FPoints, 0);
  SetLength(FRangeList, 0);
end;

function TPolygon.GetCount: Integer;
begin
  Result := Length(FPoints);
end;

function TPolygon.GetFillRange(Y: Integer): TRangeList;
begin
  RangeListNeeded;
  SetLength(Result, 0);
  if (Y >= FStartY) and (Y < Length(FPoints) + FStartY) then
    Result := FRangeList[Y];
end;

function TPolygon.GetPoint(Index: Integer): TPoint;
begin
  Result := FPoints[Index];
end;

procedure TPolygon.Offset(dx, dy: Integer);
var
  i, j: Integer;
begin
  RangeListNeeded;
  FStartY := FStartY + dy;
  for i := 0 to Length(FRangeList) - 1 do
    for j := 0 to Length(FRangeList[i]) - 1 do
      Inc(FRangeList[i][j].X, dx);
end;

procedure TPolygon.RangeListNeeded;
var
  R: TRect;
  Y, i: Integer;
begin
  if Length(FPoints) <> Length(FRangeList) and Length(FPoints) then
  begin
    SetLength(FRangeList, Length(FPoints));
    R := Polygon_GetBounds(FPoints);
    i := 0;
    for Y := R.Top to R.Bottom do
    begin
      Polygon_GetFillRange(FPoints, Y, FRangeList[i]);
      Inc(i);
    end;
  end;
end;

procedure TPolygon.SetCount(AValue: Integer);
begin
  SetLength(FPoints, AValue);
  {Clear cache on point list change}
  SetLength(FRangeList, 0);
end;

procedure TPolygon.SetPoint(Index: Integer; APoint: TPoint);
begin
  FPoints[Index] := APoint;
  {Clear cache if a point changes}
  SetLength(FRangeList, 0);
end;

var
  APoints: array of TPoint;
  AColor: TColor = clBlack;
  APtInside: Boolean = False;

procedure FillPolygon(ACanvas: TCanvas; APoints: array of TPoint);
var
  i, j: Integer;
  R: TRect;
  ARangeList: TRangeList;
begin
  ACanvas.Pen.Color := AColor;
  {Find polygon bounds because we only need to calculate fill-ranges from
  top to bottom value of rectangle}
  R := Polygon_GetBounds(APoints);
  for i := R.Top to R.Bottom do
  begin
    Polygon_GetFillRange(APoints, i, ARangeList);
    {Since there can be many fill ranges for one Y, function returns a list of all}
    for j := 0 to Length(ARangeList) - 1 do
    begin
      {fill pixels inside range}
      {so far I'll just draw a line with GDI but this part can be substituted with your own draw function}
      ACanvas.MoveTo(ARangeList[j].X, i);
      ACanvas.LineTo(ARangeList[j].X + ARangeList[j].Count, i);
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to Length(APoints) - 1 do
    APoints[i] := Point(Random(ClientWidth), Random(ClientHeight));
  Repaint;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  i: Integer;
begin
  Randomize;
  SetLength(APoints, SpinEdit1.Value);
  for i := 0 to Length(APoints) - 1 do
    APoints[i] := Point(Random(ClientWidth), Random(ClientHeight));
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  FillPolygon(Canvas, APoints);
end;

procedure TForm1.SpinEdit1Change(Sender: TObject);
var
  i: Integer;
begin
  SetLength(APoints, SpinEdit1.Value);
  for i := 0 to Length(APoints) - 1 do
    APoints[i] := Point(Random(ClientWidth), Random(ClientHeight));
  Repaint;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  if Polygon_PtInside(APoints, Point(X, Y)) then
  begin
    if not APtInside then
    begin
      Caption := 'Inside: YES';
      AColor := clRed;
      APtInside := True;
      Repaint;
    end;
  end
  else
  begin
    if APtInside then
    begin
      Caption := 'Inside: NO';
      AColor := clBlack;
      APtInside := False;
      Repaint;
    end;
  end;
end;

end.

{main.dfm}

object Form1: TForm1
  Left = 290
    Top = 153
    Width = 783
    Height = 540
    Caption = 'Inside: NO'
    Color = clBtnFace
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    OldCreateOrder = False
    OnCreate = FormCreate
    OnMouseMove = FormMouseMove
    OnPaint = FormPaint
    PixelsPerInch = 96
    TextHeight = 13
    object Label1: TLabel
    Left = 168
      Top = 12
      Width = 54
      Height = 13
      Caption = 'Point count'
  end
  object Button1: TButton
    Left = 8
      Top = 8
      Width = 145
      Height = 25
      Caption = 'Randomize points'
      TabOrder = 0
      OnClick = Button1Click
  end
  object SpinEdit1: TSpinEdit
    Left = 232
      Top = 8
      Width = 73
      Height = 22
      MaxValue = 0
      MinValue = 0
      TabOrder = 1
      Value = 8
      OnChange = SpinEdit1Change
  end
end