Fill a polygon (Views: 27)
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 |