1 // SPDX-License-Identifier: LGPL-3.0-linking-exception
2 unit BGRAFillInfo;
3
4 {$mode objfpc}{$H+}
5
6 interface
7
8 uses
9 BGRAClasses, SysUtils, BGRABitmapTypes;
10
11 const
12 AntialiasPrecision = 16;
13 AntialiasPrecisionShift = 4;
14
15 type
16 TDensity = word;
17 PDensity = ^TDensity;
18
19 type
20 { TFillShapeInfo }
21
22 TFillShapeInfo = class(TBGRACustomFillInfo)
23 protected
24 FPointInsideInter : ArrayOfTIntersectionInfo;
25 //compute intersections. the array must be big enough
26 procedure ComputeIntersection(cury: single; var inter: ArrayOfTIntersectionInfo; var nbInter: integer); virtual;
27 //sort from left to right
28 procedure SortIntersection(var inter: ArrayOfTIntersectionInfo; nbInter: integer); virtual;
29 procedure InternalQuickSortIntersection(inter0: pointer; idxL, idxH: Integer); virtual;
30 //apply non-zero winding rule. it can change the number of intersections
31 procedure ConvertFromNonZeroWinding(var inter: ArrayOfTIntersectionInfo; var nbInter: integer); virtual;
32 //returns maximum of intersection per line
NbMaxIntersectionnull33 function NbMaxIntersection: integer; virtual;
34
35 public
36 destructor Destroy; override;
37
38 //returns true if the same segment number can be curved
SegmentsCurvednull39 function SegmentsCurved: boolean; override;
40
41 //returns integer bounds
GetBoundsnull42 function GetBounds: TRect; override;
43
44 //check if the point is inside the filling zone
IsPointInsidenull45 function IsPointInside(x,y: single; windingMode: boolean): boolean; override;
46
47 //create an array that will contain computed intersections.
48 //you may augment, in this case, use CreateIntersectionInfo for new items
CreateIntersectionArraynull49 function CreateIntersectionArray: ArrayOfTIntersectionInfo; override;
CreateIntersectionInfonull50 function CreateIntersectionInfo: TIntersectionInfo; override; //creates a single info
51 procedure FreeIntersectionArray(var inter: ArrayOfTIntersectionInfo); override;
52
53 //fill a previously created array of intersections with actual intersections at the current y coordinate.
54 //nbInter gets the number of computed intersections
55 procedure ComputeAndSort(cury: single; var inter: ArrayOfTIntersectionInfo; out nbInter: integer; windingMode: boolean); override;
56
57 //can be called after ComputeAndSort or ComputeIntersection to determine the current horizontal slice
58 //so that it can be checked if the intermediates scanlines can be skipped
GetSliceIndexnull59 function GetSliceIndex: integer; override;
60
61 end;
62
63 { TFillEllipseInfo }
64
65 TFillEllipseInfo = class(TFillShapeInfo)
66 private
67 FX, FY, FRX, FRY: single;
68 FSliceIndex: integer;
GetCenternull69 function GetCenter: TPointF;
70 protected
NbMaxIntersectionnull71 function NbMaxIntersection: integer; override;
72 procedure ComputeIntersection(cury: single;
73 var inter: ArrayOfTIntersectionInfo; var nbInter: integer); override;
74 public
75 WindingFactor: integer;
76 constructor Create(x, y, rx, ry: single);
GetBoundsnull77 function GetBounds: TRect; override;
SegmentsCurvednull78 function SegmentsCurved: boolean; override;
GetSliceIndexnull79 function GetSliceIndex: integer; override;
80 property Center: TPointF read GetCenter;
81 property RadiusX: single read FRX;
82 property RadiusY: single read FRY;
83 end;
84
85 { TFillBorderEllipseInfo }
86
87 TFillBorderEllipseInfo = class(TFillShapeInfo)
88 private
89 FInnerBorder, FOuterBorder: TFillEllipseInfo;
90 protected
NbMaxIntersectionnull91 function NbMaxIntersection: integer; override;
92 procedure ComputeIntersection(cury: single;
93 var inter: ArrayOfTIntersectionInfo; var nbInter: integer); override;
94 public
95 constructor Create(x, y, rx, ry, w: single);
GetBoundsnull96 function GetBounds: TRect; override;
SegmentsCurvednull97 function SegmentsCurved: boolean; override;
98 destructor Destroy; override;
GetSliceIndexnull99 function GetSliceIndex: integer; override;
100 property InnerBorder: TFillEllipseInfo read FInnerBorder;
101 property OuterBorder: TFillEllipseInfo read FOuterBorder;
102 end;
103
104 { TFillRoundRectangleInfo }
105
106 TFillRoundRectangleInfo = class(TFillShapeInfo)
107 private
108 FX1, FY1, FX2, FY2, FRX, FRY: single;
109 FOptions: TRoundRectangleOptions;
GetBottomRightnull110 function GetBottomRight: TPointF;
GetTopLeftnull111 function GetTopLeft: TPointF;
112 protected
NbMaxIntersectionnull113 function NbMaxIntersection: integer; override;
114 procedure ComputeIntersection(cury: single;
115 var inter: ArrayOfTIntersectionInfo; var nbInter: integer); override;
116 public
117 WindingFactor: integer;
118 constructor Create(x1, y1, x2, y2, rx, ry: single; options: TRoundRectangleOptions; APixelCenteredCoordinates: boolean = true);
SegmentsCurvednull119 function SegmentsCurved: boolean; override;
GetBoundsnull120 function GetBounds: TRect; override;
121 property TopLeft: TPointF read GetTopLeft;
122 property BottomRight: TPointF read GetBottomRight;
123 property RadiusX: single read FRX;
124 property RadiusY: single read FRY;
125 end;
126
127 { TFillRectangleInfo }
128
129 TFillRectangleInfo = class(TFillShapeInfo)
130 private
131 FX1, FY1, FX2, FY2: single;
GetBottomRightnull132 function GetBottomRight: TPointF;
GetTopLeftnull133 function GetTopLeft: TPointF;
134 protected
NbMaxIntersectionnull135 function NbMaxIntersection: integer; override;
136 procedure ComputeIntersection(cury: single;
137 var inter: ArrayOfTIntersectionInfo; var nbInter: integer); override;
138 public
139 WindingFactor: integer;
140 constructor Create(x1, y1, x2, y2: single; APixelCenteredCoordinates: boolean = true);
GetBoundsnull141 function GetBounds: TRect; override;
142 property TopLeft: TPointF read GetTopLeft;
143 property BottomRight: TPointF read GetBottomRight;
144 end;
145
146 { TFillBorderRoundRectInfo }
147
148 TFillBorderRoundRectInfo = class(TFillShapeInfo)
149 protected
150 FInnerBorder, FOuterBorder: TFillRoundRectangleInfo;
NbMaxIntersectionnull151 function NbMaxIntersection: integer; override;
152 procedure ComputeIntersection(cury: single;
153 var inter: ArrayOfTIntersectionInfo; var nbInter: integer); override;
154 public
155 constructor Create(x1, y1, x2, y2, rx, ry, w: single; options: TRoundRectangleOptions; APixelCenteredCoordinates: boolean = true);
GetBoundsnull156 function GetBounds: TRect; override;
SegmentsCurvednull157 function SegmentsCurved: boolean; override;
158 destructor Destroy; override;
159 property InnerBorder: TFillRoundRectangleInfo read FInnerBorder;
160 property OuterBorder: TFillRoundRectangleInfo read FOuterBorder;
161 end;
162
163 PCustomPointRecord = ^TCustomPointRecord;
164 TCustomPointRecord = record
165 originalIndex: integer;
166 slope: single;
167 empty: boolean;
168 next: integer;
169 winding: integer;
170 includeStartingPoint,includeEndingPoint: boolean;
171 data: pointer;
172 case boolean of
173 false: (x,y,x2,y2: single);
174 true: (coord,coord2: TPointF);
175 end;
176
177 { TCustomFillPolyInfo }
178
179 TCustomFillPolyInfo = class(TFillShapeInfo)
180 private
GetNbPointsnull181 function GetNbPoints: integer;
182 protected
183 FPoints: array of TCustomPointRecord;
184 FSegmentsDataCreated: boolean;
185 FBoundsF: TRectF;
NbMaxIntersectionnull186 function NbMaxIntersection: integer; override;
187 procedure SetIntersectionValues(AInter: TIntersectionInfo; AInterX: Single; AWinding, ANumSegment: integer; {%H-}dy: single; {%H-}AData: pointer); virtual;
188 procedure InitPoints(const points: array of TPointF);
189 procedure CreateSegmentsData; virtual;
190 public
191 constructor Create(const points: array of TPointF; APixelCenteredCoordinates: boolean = true);
192 destructor Destroy; override;
CreateIntersectionArraynull193 function CreateIntersectionArray: ArrayOfTIntersectionInfo; override;
CreateSegmentDatanull194 function CreateSegmentData({%H-}numPt, {%H-}nextPt: integer; {%H-}ASeg: PCustomPointRecord): pointer; virtual;
195 procedure FreeSegmentData(data: pointer); virtual;
GetBoundsnull196 function GetBounds: TRect; override;
GetBoundsFnull197 function GetBoundsF: TRectF;
198 property NbPoints: integer read GetNbPoints;
199 end;
200
201 TPolySlice = record
202 y1,y2: single;
203 segments: array of record
204 id: integer;
205 custom: PCustomPointRecord;
206 end;
207 nbSegments: integer;
208 end;
209
210 { TFillPolyInfo }
211
212 TFillPolyInfo = class(TCustomFillPolyInfo)
213 protected
214 FSlices: array of TPolySlice;
215 FCurSlice: integer;
216 FMaxIntersection: integer;
NbMaxIntersectionnull217 function NbMaxIntersection: integer; override;
218 procedure ComputeIntersection(cury: single;
219 var inter: ArrayOfTIntersectionInfo; var nbInter: integer); override;
220 public
221 constructor Create(const points: array of TPointF; APixelCenteredCoordinates: boolean = true);
GetSliceIndexnull222 function GetSliceIndex: integer; override;
223 end;
224
225 POnePassRecord = ^TOnePassRecord;
226 TOnePassRecord = record
227 id: integer;
228 custom: PCustomPointRecord;
229 next: POnePassRecord;
230 nextWaiting: POnePassRecord;
231 nextDrawing: POnePassRecord;
232 end;
233
234 { TOnePassFillPolyInfo }
235
236 TOnePassFillPolyInfo = class(TCustomFillPolyInfo)
237 private
238 procedure InsertionSortByY;
PartitionByYnull239 function PartitionByY(left, right: integer): integer;
240 procedure QuickSortByY(left, right: integer);
241 procedure SortByY;
242 protected
243 FOnePass: array of TOnePassRecord;
244 FSortedByY: array of POnePassRecord;
245 FFirstWaiting, FFirstDrawing: POnePassRecord;
246 FShouldInitializeDrawing: boolean;
247 FSliceIndex: integer;
248 procedure ComputeIntersection(cury: single;
249 var inter: ArrayOfTIntersectionInfo; var nbInter: integer); override;
250 public
251 constructor Create(const points: array of TPointF; APixelCenteredCoordinates: boolean = true);
CreateIntersectionArraynull252 function CreateIntersectionArray: ArrayOfTIntersectionInfo; override;
GetSliceIndexnull253 function GetSliceIndex: integer; override;
254 end;
255
256 { TSimpleFillPolyInfo }
257
258 TSimpleFillPolyInfo = class(TCustomFillPolyInfo)
259 protected
260 procedure ComputeIntersection(cury: single; var inter: ArrayOfTIntersectionInfo;
261 var nbInter: integer); override;
262 public
263 constructor Create(const points: array of TPointF; APixelCenteredCoordinates: boolean = true);
264 end;
265
266 procedure AddDensity(dest: PDensity; start,count: integer; value : word); inline;
DivByAntialiasPrecisionnull267 function DivByAntialiasPrecision(value: UInt32or64): UInt32or64; inline;
DivByAntialiasPrecision256null268 function DivByAntialiasPrecision256(value: UInt32or64): UInt32or64; inline;
DivByAntialiasPrecision65536null269 function DivByAntialiasPrecision65536(value: UInt32or64): UInt32or64; inline;
270 procedure ComputeAliasedRowBounds(x1,x2: single; minx,maxx: integer; out ix1,ix2: integer);
271
IsPointInPolygonnull272 function IsPointInPolygon(const points: ArrayOfTPointF; point: TPointF; windingMode: boolean): boolean;
IsPointInEllipsenull273 function IsPointInEllipse(x,y,rx,ry: single; point: TPointF): boolean;
IsPointInRoundRectanglenull274 function IsPointInRoundRectangle(x1, y1, x2, y2, rx, ry: single; point: TPointF): boolean;
IsPointInRectanglenull275 function IsPointInRectangle(x1, y1, x2, y2: single; point: TPointF): boolean;
276
BGRAShapeComputeMinMaxnull277 function BGRAShapeComputeMinMax(AShape: TBGRACustomFillInfo; out minx, miny, maxx, maxy: integer;
278 bmpDest: TBGRACustomBitmap): boolean; overload;
BGRAShapeComputeMinMaxnull279 function BGRAShapeComputeMinMax(AShape: TBGRACustomFillInfo; out minx, miny, maxx, maxy: integer;
280 clip: TRect): boolean; overload;
281
282 implementation
283
284 uses Math;
285
BGRAShapeComputeMinMaxnull286 function BGRAShapeComputeMinMax(AShape: TBGRACustomFillInfo; out minx, miny, maxx, maxy: integer;
287 bmpDest: TBGRACustomBitmap): boolean;
288 begin
289 result := BGRAShapeComputeMinMax(AShape, minx,miny,maxx,maxy, bmpDest.ClipRect);
290 end;
291
BGRAShapeComputeMinMaxnull292 function BGRAShapeComputeMinMax(AShape: TBGRACustomFillInfo; out minx, miny, maxx, maxy: integer;
293 clip: TRect): boolean;
294 var bounds: TRect;
295 begin
296 result := true;
297 bounds := AShape.GetBounds;
298
299 if (bounds.Right <= bounds.left) or (bounds.bottom <= bounds.top) then
300 begin
301 result := false;
302 exit;
303 end;
304
305 miny := bounds.top;
306 maxy := bounds.bottom - 1;
307 minx := bounds.left;
308 maxx := bounds.right - 1;
309
310 if minx < clip.Left then
311 minx := clip.Left;
312 if maxx < clip.Left then
313 result := false;
314
315 if maxx > clip.Right - 1 then
316 maxx := clip.Right- 1;
317 if minx > clip.Right - 1 then
318 result := false;
319
320 if miny < clip.Top then
321 miny := clip.Top;
322 if maxy < clip.Top then
323 result := false;
324
325 if maxy > clip.Bottom - 1 then
326 maxy := clip.Bottom - 1;
327 if miny > clip.Bottom - 1 then
328 result := false;
329 end;
330
331 procedure ComputeAliasedRowBounds(x1,x2: single; minx,maxx: integer; out ix1,ix2: integer);
332 begin
333 ix1 := trunc(x1);
334 if frac(x1)>0.5 then inc(ix1)
335 else if frac(x1)<=-0.5 then dec(ix1);
336 ix2 := trunc(x2)-1;
337 if frac(x2)>0.5 then inc(ix2)
338 else if frac(x2)<=-0.5 then dec(ix2);
339 if ix1 < minx then ix1 := minx;
340 if ix2 >= maxx then ix2 := maxx;
341 end;
342
IsPointInPolygonnull343 function IsPointInPolygon(const points: ArrayOfTPointF; point: TPointF
344 ; windingMode: boolean): boolean;
345 var info: TBGRACustomFillInfo;
346 begin
347 info := TSimpleFillPolyInfo.Create(points);
348 result := info.IsPointInside(point.x+0.5,point.y+0.5,windingMode);
349 info.free;
350 end;
351
IsPointInEllipsenull352 function IsPointInEllipse(x, y, rx, ry: single; point: TPointF): boolean;
353 var info: TBGRACustomFillInfo;
354 begin
355 info := TFillEllipseInfo.Create(x,y,rx,ry);
356 result := info.IsPointInside(point.x+0.5,point.y+0.5,false);
357 info.free;
358 end;
359
IsPointInRoundRectanglenull360 function IsPointInRoundRectangle(x1, y1, x2, y2, rx, ry: single; point: TPointF
361 ): boolean;
362 var info: TBGRACustomFillInfo;
363 begin
364 info := TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry,[]);
365 result := info.IsPointInside(point.x+0.5,point.y+0.5,false);
366 info.free;
367 end;
368
IsPointInRectanglenull369 function IsPointInRectangle(x1, y1, x2, y2: single; point: TPointF): boolean;
370 begin
371 with point do
372 result := (((x1<x) and (x2>x)) or ((x1>x) and (x2<x))) and
373 (((y1<y) and (y2>y)) or ((y1>y) and (y2<y)));
374 end;
375
376 procedure AddDensity(dest: PDensity; start,count: integer; value: word);
377 var valueValue: LongWord;
378 lastAdd: integer;
379 begin
380 if count=0 then exit;
381 inc(dest,start);
382 if start and 1 = 1 then
383 begin
384 inc(dest^, value);
385 inc(dest);
386 dec(count);
387 end;
388 lastAdd := count and 1;
389 count := count shr 1;
390 if count > 0 then
391 begin
392 valueValue := value+(value shl 16);
393 while count > 0 do
394 begin
395 inc(plongword(dest)^, valueValue);
396 inc(dest,2);
397 dec(count);
398 end;
399 end;
400 if lastAdd <> 0 then
401 inc(dest^, value);
402 end;
403
DivByAntialiasPrecisionnull404 function DivByAntialiasPrecision(value: UInt32or64): UInt32or64;
405 begin //
406 result := value shr AntialiasPrecisionShift;// div AntialiasPrecision;
407 end;
408
DivByAntialiasPrecision256null409 function DivByAntialiasPrecision256(value: UInt32or64): UInt32or64;
410 begin //
411 result := value shr (AntialiasPrecisionShift+8);// div (256*AntialiasPrecision);
412 end;
413
DivByAntialiasPrecision65536null414 function DivByAntialiasPrecision65536(value: UInt32or64): UInt32or64;
415 begin //
416 result := value shr (AntialiasPrecisionShift+16);//div (65536*AntialiasPrecision);
417 end;
418
419 { TFillRectangleInfo }
420
TFillRectangleInfo.GetBottomRightnull421 function TFillRectangleInfo.GetBottomRight: TPointF;
422 begin
423 result := PointF(FX2-0.5,FY2-0.5);
424 end;
425
GetTopLeftnull426 function TFillRectangleInfo.GetTopLeft: TPointF;
427 begin
428 result := PointF(FX1-0.5,FY1-0.5);
429 end;
430
TFillRectangleInfo.NbMaxIntersectionnull431 function TFillRectangleInfo.NbMaxIntersection: integer;
432 begin
433 Result:= 2;
434 end;
435
436 procedure TFillRectangleInfo.ComputeIntersection(cury: single;
437 var inter: ArrayOfTIntersectionInfo; var nbInter: integer);
438 begin
439 if (cury >= FY1) and (cury <= FY2) then
440 begin
441 inter[nbinter].interX := FX1;
442 inter[nbinter].winding := -windingFactor;
443 inter[nbinter].numSegment := 0;
444 Inc(nbinter);
445 inter[nbinter].interX := FX2;
446 inter[nbinter].winding := +windingFactor;
447 inter[nbinter].numSegment := 1;
448 Inc(nbinter);
449 end;
450 end;
451
452 constructor TFillRectangleInfo.Create(x1, y1, x2, y2: single;
453 APixelCenteredCoordinates: boolean);
454 var
455 temp: Single;
456 begin
457 if y1 > y2 then
458 begin
459 temp := y1;
460 y1 := y2;
461 y2 := temp;
462 end;
463 if x1 > x2 then
464 begin
465 temp := x1;
466 x1 := x2;
467 x2 := temp;
468 end;
469 if APixelCenteredCoordinates then
470 begin
471 FX1 := x1 + 0.5;
472 FY1 := y1 + 0.5;
473 FX2 := x2 + 0.5;
474 FY2 := y2 + 0.5;
475 end else
476 begin
477 FX1 := x1;
478 FY1 := y1;
479 FX2 := x2;
480 FY2 := y2;
481 end;
482 WindingFactor := 1;
483 end;
484
TFillRectangleInfo.GetBoundsnull485 function TFillRectangleInfo.GetBounds: TRect;
486 begin
487 result := rect(floor(fx1),floor(fy1),floor(fx2)+1,floor(fy2)+1);
488 end;
489
490 { TFillShapeInfo }
491
TFillShapeInfo.GetBoundsnull492 function TFillShapeInfo.GetBounds: TRect;
493 begin
494 Result := rect(0, 0, 0, 0);
495 end;
496
497
TFillShapeInfo.IsPointInsidenull498 function TFillShapeInfo.IsPointInside(x, y: single; windingMode: boolean
499 ): boolean;
500 var
501 i,nbInter: integer;
502 begin
503 if FPointInsideInter = nil then
504 FPointInsideInter := CreateIntersectionArray;
505 ComputeAndSort(y,FPointInsideInter,nbInter,windingMode);
506 i := 0;
507 while i+1 < nbInter do
508 begin
509 if (FPointInsideInter[i].interX < x) and (FPointInsideInter[i+1].interX > x) then
510 begin
511 result := true;
512 FreeIntersectionArray(FPointInsideInter);
513 exit;
514 end;
515 inc(i,2);
516 end;
517 result := false;
518 end;
519
TFillShapeInfo.NbMaxIntersectionnull520 function TFillShapeInfo.NbMaxIntersection: integer;
521 begin
522 Result := 0;
523 end;
524
525 destructor TFillShapeInfo.Destroy;
526 begin
527 FreeIntersectionArray(FPointInsideInter);
528 inherited Destroy;
529 end;
530
TFillShapeInfo.SegmentsCurvednull531 function TFillShapeInfo.SegmentsCurved: boolean;
532 begin
533 result := false;
534 end;
535
TFillShapeInfo.CreateIntersectionInfonull536 function TFillShapeInfo.CreateIntersectionInfo: TIntersectionInfo;
537 begin
538 result := TIntersectionInfo.Create;
539 end;
540
541 procedure TFillShapeInfo.FreeIntersectionArray(
542 var inter: ArrayOfTIntersectionInfo);
543 var
544 i: Integer;
545 begin
546 for i := 0 to high(inter) do
547 inter[i].free;
548 inter := nil;
549 end;
550
551 {$hints off}
552 procedure TFillShapeInfo.ComputeIntersection(cury: single;
553 var inter: ArrayOfTIntersectionInfo; var nbInter: integer);
554 begin
555
556 end;
557 {$hints on}
558
559 procedure TFillShapeInfo.SortIntersection(var inter: ArrayOfTIntersectionInfo; nbInter: integer);
560 var
561 i,j,k: Integer;
562 tempInter: TIntersectionInfo;
563 begin
564 if nbInter > 10 then
565 InternalQuickSortIntersection(@inter[0], 0, nbInter-1);
566 for i := 1 to nbinter - 1 do
567 begin
568 j := i;
569 while (j > 0) and (inter[i].interX < inter[j-1].interX) do dec(j);
570 if j <> i then
571 begin
572 tempInter := inter[i];
573 for k := i-1 downto j do
574 inter[k+1] := inter[k];
575 inter[j] := tempInter;
576 end;
577 end;
578 end;
579
580 procedure TFillShapeInfo.InternalQuickSortIntersection(inter0: pointer;
581 idxL, idxH: Integer);
582 const Stride = sizeof(pointer);
583 MinSub = 10;
584 type PIntersectionInfo = ^TIntersectionInfo;
585 var
586 ls,hs : Integer;
587 li,hi : Integer;
588 mi : Integer;
589 ms : Integer;
590 pb : PByte;
591 tempInfo: TIntersectionInfo;
592 m: Single;
593 begin
594 pb:=PByte(inter0);
595 li:=idxL;
596 hi:=idxH;
597 mi:=(li+hi) div 2;
598 ls:=li*Stride;
599 hs:=hi*Stride;
600 ms:=mi*Stride;
601 m := PIntersectionInfo(pb+ms)^.interX;
602 repeat
603 while PIntersectionInfo(pb+ls)^.interX < m do begin
604 inc(ls, Stride);
605 inc(li);
606 end;
607 while m < PIntersectionInfo(pb+hs)^.interX do begin
608 dec(hs, Stride);
609 dec(hi);
610 end;
611 if ls <= hs then begin
612 tempInfo := PIntersectionInfo(pb+ls)^;
613 PIntersectionInfo(pb+ls)^ := PIntersectionInfo(pb+hs)^;
614 PIntersectionInfo(pb+hs)^ := tempInfo;
615 inc(ls, Stride); inc(li);
616 dec(hs, Stride); dec(hi);
617 end;
618 until ls>hs;
619 if hi>=idxL+MinSub-1 then InternalQuickSortIntersection(inter0, idxL, hi);
620 if li+MinSub-1<=idxH then InternalQuickSortIntersection(inter0, li, idxH);
621 end;
622
623 procedure TFillShapeInfo.ConvertFromNonZeroWinding(var inter: ArrayOfTIntersectionInfo; var nbInter: integer);
624 var windingSum,prevSum,i,nbAlternate: integer;
625 tempInfo: TIntersectionInfo;
626 begin
627 windingSum := 0;
628 nbAlternate := 0;
629 for i := 0 to nbInter-1 do
630 begin
631 prevSum := windingSum;
632 inc(windingSum, inter[i].winding);
633 if (windingSum = 0) xor (prevSum = 0) then
634 begin
635 if nbAlternate<>i then
636 begin
637 tempInfo := inter[nbAlternate];
638 inter[nbAlternate] := inter[i];
639 inter[i] := tempInfo;
640 end;
641 inc(nbAlternate);
642 end;
643 end;
644 nbInter := nbAlternate;
645 end;
646
647 procedure TFillShapeInfo.ComputeAndSort(cury: single;
648 var inter: ArrayOfTIntersectionInfo; out nbInter: integer; windingMode: boolean);
649 begin
650 nbInter := 0;
651 ComputeIntersection(cury,inter,nbInter);
652 if nbInter < 2 then exit;
653 SortIntersection(inter,nbInter);
654 if windingMode then ConvertFromNonZeroWinding(inter,nbInter);
655 end;
656
GetSliceIndexnull657 function TFillShapeInfo.GetSliceIndex: integer;
658 begin
659 result := 0;
660 end;
661
CreateIntersectionArraynull662 function TFillShapeInfo.CreateIntersectionArray: ArrayOfTIntersectionInfo;
663 var
664 i: Integer;
665 begin
666 setlength(result, NbMaxIntersection);
667 for i := 0 to high(result) do
668 result[i] := CreateIntersectionInfo;
669 end;
670
ComputeWindingnull671 function ComputeWinding(y1,y2: single): integer;
672 begin
673 if y2 > y1 then result := 1 else
674 if y2 < y1 then result := -1 else
675 result := 0;
676 end;
677
678 type
679 arrayOfSingle = array of single;
680
681 procedure InsertionSortSingles(var a: arrayOfSingle);
682 var i,j: integer;
683 temp: single;
684 begin
685 for i := 1 to high(a) do
686 begin
687 Temp := a[i];
688 j := i;
689 while (j>0) and (a[j-1]> Temp) do
690 begin
691 a[j] := a[j-1];
692 dec(j);
693 end;
694 a[j] := Temp;
695 end;
696 end;
697
PartitionSinglesnull698 function PartitionSingles(var a: arrayOfSingle; left,right: integer): integer;
699
700 procedure Swap(idx1,idx2: integer); inline;
701 var temp: single;
702 begin
703 temp := a[idx1];
704 a[idx1] := a[idx2];
705 a[idx2] := temp;
706 end;
707
708 var pivotIndex: integer;
709 pivotValue: single;
710 storeIndex: integer;
711 i: integer;
712
713 begin
714 pivotIndex := left + random(right-left+1);
715 pivotValue := a[pivotIndex];
716 swap(pivotIndex,right);
717 storeIndex := left;
718 for i := left to right-1 do
719 if a[i] <= pivotValue then
720 begin
721 swap(i,storeIndex);
722 inc(storeIndex);
723 end;
724 swap(storeIndex,right);
725 result := storeIndex;
726 end;
727
728 procedure QuickSortSingles(var a: arrayOfSingle; left,right: integer);
729 var pivotNewIndex: integer;
730 begin
731 if right > left+9 then
732 begin
733 pivotNewIndex := PartitionSingles(a,left,right);
734 QuickSortSingles(a,left,pivotNewIndex-1);
735 QuickSortSingles(a,pivotNewIndex+1,right);
736 end;
737 end;
738
739 procedure SortSingles(var a: arrayOfSingle);
740 begin
741 if length(a) < 10 then InsertionSortSingles(a) else
742 begin
743 QuickSortSingles(a,0,high(a));
744 InsertionSortSingles(a);
745 end;
746 end;
747
748 procedure RemoveSingleDuplicates(var a: arrayOfSingle; var nb: integer);
749 var i,idx: integer;
750 begin
751 idx := 0;
752 for i := 1 to nb-1 do
753 begin
754 if a[i] <> a[idx] then
755 begin
756 inc(idx);
757 a[idx] := a[i];
758 end;
759 end;
760 nb := idx+1;
761 end;
762
BinarySearchSinglenull763 function BinarySearchSingle(value: single; var a: arrayOfSingle; left,right: integer): integer;
764 var pivotIndex: integer;
765 pivotValue: single;
766 begin
767 pivotIndex := (left+right) div 2;
768 pivotValue := a[pivotIndex];
769 if value = pivotValue then
770 result := pivotIndex else
771 if value < pivotValue then
772 begin
773 if pivotIndex = left then result := left else
774 result := BinarySearchSingle(value, a, left,pivotIndex-1);
775 end else
776 begin
777 if pivotIndex = right then result := right+1 else
778 result := BinarySearchSingle(value, a, pivotIndex+1, right);
779 end;
780 end;
781
782 { TCustomFillPolyInfo }
783
784 constructor TCustomFillPolyInfo.Create(const points: array of TPointF; APixelCenteredCoordinates: boolean);
785 var
786 cur, first, i, j: integer;
787 p, pNext: PCustomPointRecord;
788 tempCoord: TPointF;
789 tempBool: Boolean;
790
791 begin
792 InitPoints(points);
793 FSegmentsDataCreated:= false;
794 if FPoints=nil then
795 begin
796 FBoundsF := EmptyRectF;
797 exit;
798 end;
799
800 //look for empty points, correct coordinate and successors
801 cur := -1;
802 first := -1;
803 p := @FPoints[0];
804 for i := 0 to high(FPoints) do
805 begin
806 if not isEmptyPointF(p^.coord) then
807 begin
808 p^.empty := False;
809 if APixelCenteredCoordinates then
810 p^.coord.Offset(0.5,0.5);
811 if cur <> -1 then
812 FPoints[cur].next := i;
813 if first = -1 then
814 first := i;
815 cur := i;
816 end
817 else
818 begin
819 if (first <> -1) and (cur <> first) then
820 FPoints[cur].next := first;
821
822 p^.empty := True;
823 p^.next := -1;
824 cur := -1;
825 first := -1;
826 end;
827 inc(p);
828 end;
829 if (first <> -1) and (cur <> first) then
830 FPoints[cur].next := first;
831
832 FBoundsF := RectF(FPoints[0].coord,FPoints[0].coord);
833
834 p := @FPoints[0];
835 for i := 0 to high(FPoints) do
836 begin
837 if not p^.empty then
838 begin
839 if p^.x < FBoundsF.Left then FBoundsF.Left := p^.x else
840 if p^.x > FBoundsF.Right then FBoundsF.Right := p^.x;
841 if p^.y < FBoundsF.Top then FBoundsF.Top := p^.y else
842 if p^.y > FBoundsF.Bottom then FBoundsF.Bottom := p^.y;
843 end;
844 if p^.next <> -1 then
845 begin
846 pNext := @FPoints[p^.next];
847 p^.coord2 := pNext^.coord;
848 end;
849 inc(p);
850 end;
851
852 //compute slopes
853 p := @FPoints[0];
854 for i := 0 to high(FPoints) do
855 begin
856 if not p^.empty then
857 begin
858 p^.winding := ComputeWinding(p^.y, p^.y2);
859 if p^.winding<>0 then
860 p^.slope := (p^.x2 - p^.x) / (p^.y2 - p^.y)
861 else
862 p^.slope := EmptySingle;
863 end
864 else
865 p^.slope := EmptySingle;
866 inc(p);
867 end;
868
869 //check if end points are included
870 p := @FPoints[0];
871 for i := 0 to high(FPoints) do
872 begin
873 if not p^.empty then
874 begin
875 j := p^.next;
876 pNext := @FPoints[j];
877 if p^.winding > 0 then
878 p^.includeEndingPoint := pNext^.winding < 0
879 else if p^.winding < 0 then
880 p^.includeEndingPoint := pNext^.winding >= 0
881 else
882 p^.includeStartingPoint := false;
883
884 if pNext^.winding > 0 then
885 pNext^.includeStartingPoint := true
886 else if pNext^.winding < 0 then
887 pNext^.includeStartingPoint := p^.winding <> 0;
888 end;
889 inc(p);
890 end;
891
892 //flip vertically to have always top to bottom
893 p := @FPoints[0];
894 for i := 0 to high(FPoints) do
895 begin
896 if p^.winding < 0 then
897 begin
898 tempCoord := p^.coord;
899 p^.coord := p^.coord2;
900 p^.coord2 := tempCoord;
901 tempBool := p^.includeStartingPoint;
902 p^.includeStartingPoint := p^.includeEndingPoint;
903 p^.includeEndingPoint := tempBool;
904 end;
905 inc(p);
906 end;
907 end;
908
909 destructor TCustomFillPolyInfo.Destroy;
910 var
911 i: Integer;
912 begin
913 for i := 0 to high(FPoints) do
914 freemem(FPoints[i].data);
915 inherited Destroy;
916 end;
917
CreateIntersectionArraynull918 function TCustomFillPolyInfo.CreateIntersectionArray: ArrayOfTIntersectionInfo;
919 var
920 i: Integer;
921 begin
922 CreateSegmentsData;
923 setlength(result, NbMaxIntersection);
924 for i := 0 to high(result) do
925 result[i] := nil;
926 end;
927
TCustomFillPolyInfo.CreateSegmentDatanull928 function TCustomFillPolyInfo.CreateSegmentData(numPt, nextPt: integer;
929 ASeg: PCustomPointRecord): pointer;
930 begin
931 result := nil;
932 end;
933
934 procedure TCustomFillPolyInfo.FreeSegmentData(data: pointer);
935 begin
936 freemem(data);
937 end;
938
TCustomFillPolyInfo.GetBoundsnull939 function TCustomFillPolyInfo.GetBounds: TRect;
940 begin
941 with FBoundsF do
942 result := Rect(floor(Left),floor(Top),ceil(Right),ceil(Bottom));
943 end;
944
GetBoundsFnull945 function TCustomFillPolyInfo.GetBoundsF: TRectF;
946 begin
947 result := FBoundsF;
948 end;
949
GetNbPointsnull950 function TCustomFillPolyInfo.GetNbPoints: integer;
951 begin
952 result := length(FPoints);
953 end;
954
NbMaxIntersectionnull955 function TCustomFillPolyInfo.NbMaxIntersection: integer;
956 begin
957 Result := length(FPoints);
958 end;
959
960 procedure TCustomFillPolyInfo.SetIntersectionValues(AInter: TIntersectionInfo;
961 AInterX: Single; AWinding, ANumSegment: integer; dy: single; AData: pointer);
962 begin
963 AInter.SetValues( AInterX, AWinding, ANumSegment );
964 end;
965
966 procedure TCustomFillPolyInfo.InitPoints(const points: array of TPointF);
967 const
968 minDist = 0.00390625; //1 over 256
969
970 var
971 i, first, nbP: integer;
972
PointAlmostEqualnull973 function PointAlmostEqual(const p1,p2: TPointF): boolean;
974 begin
975 result := (abs(p1.x-p2.x) < minDist) and (abs(p1.y-p2.y) < minDist);
976 end;
977
978 procedure EndOfSubPolygon;
979 begin
980 //if there is a subpolygon
981 if first<>-1 then
982 begin
983 //last point is the same as first point?
984 if (nbP >= first+2) and PointAlmostEqual(FPoints[nbP-1].coord,FPoints[first].coord) then
985 dec(nbP); //remove superfluous looping point
986
987 if (nbP <= first+2) then //are there only one or two points?
988 begin
989 //remove subpolygon because we need at least a triangle
990 nbP := first;
991 first := -1;
992 end;
993
994 end;
995 end;
996
997 begin
998 setlength(FPoints, length(points));
999 nbP := 0;
1000 first := -1;
1001 for i := 0 to high(points) do
1002 if isEmptyPointF(points[i]) then
1003 begin
1004 EndOfSubPolygon;
1005 if first<>-1 then
1006 begin
1007 FPoints[nbP].originalIndex := i;
1008 FPoints[nbP].coord := EmptyPointF;
1009 inc(nbP);
1010 first := -1;
1011 end;
1012 end else
1013 if (first=-1) or not PointAlmostEqual(FPoints[nbP-1].coord,points[i]) then
1014 begin
1015 if first = -1 then first := nbP;
1016 FPoints[nbP].originalIndex := i;
1017 FPoints[nbP].coord := points[i];
1018 inc(nbP);
1019 end;
1020 EndOfSubPolygon;
1021 //if last point was a subpolygon delimiter (EmptyPointF) then removes it
1022 if (nbP > 0) and isEmptyPointF(FPoints[nbP-1].coord) then dec(nbP);
1023
1024 setlength(FPoints, nbP);
1025 end;
1026
1027 procedure TCustomFillPolyInfo.CreateSegmentsData;
1028 var
1029 i: Integer;
1030 p: PCustomPointRecord;
1031 begin
1032 if FSegmentsDataCreated then exit;
1033 FSegmentsDataCreated := true;
1034 if FPoints<>nil then
1035 begin
1036 p := @FPoints[0];
1037 for i := 0 to high(FPoints) do
1038 begin
1039 if not p^.empty and (p^.slope <> EmptySingle) then
1040 begin
1041 if p^.winding < 0 then
1042 p^.data := CreateSegmentData(p^.next,i, p)
1043 else
1044 p^.data := CreateSegmentData(i,p^.next, p);
1045 end;
1046 inc(p);
1047 end;
1048 end;
1049 end;
1050
1051 { TFillPolyInfo }
1052
TFillPolyInfo.NbMaxIntersectionnull1053 function TFillPolyInfo.NbMaxIntersection: integer;
1054 begin
1055 Result:= FMaxIntersection;
1056 end;
1057
1058 procedure TFillPolyInfo.ComputeIntersection(cury: single;
1059 var inter: ArrayOfTIntersectionInfo; var nbInter: integer);
1060 var
1061 j: integer;
1062 cust: PCustomPointRecord;
1063 pInter: PIntersectionInfo;
1064 begin
1065 if length(FSlices)=0 then exit;
1066
1067 while (cury < FSlices[FCurSlice].y1) and (FCurSlice > 0) do dec(FCurSlice);
1068 while (cury > FSlices[FCurSlice].y2) and (FCurSlice < high(FSlices)) do inc(FCurSlice);
1069
1070 pInter := @inter[nbInter];
1071 with FSlices[FCurSlice] do
1072 if (cury >= y1) and (cury < y2) then
1073 begin
1074 for j := 0 to nbSegments-1 do
1075 begin
1076 cust := segments[j].custom;
1077 if pInter^ = nil then pInter^ := CreateIntersectionInfo;
1078 SetIntersectionValues(pInter^, (cury - cust^.y) * cust^.slope + cust^.x,
1079 cust^.winding, segments[j].id, cury - cust^.y, cust^.data );
1080 Inc(nbinter);
1081 inc(pInter);
1082 end;
1083 end;
1084 end;
1085
1086 constructor TFillPolyInfo.Create(const points: array of TPointF; APixelCenteredCoordinates: boolean);
AddSegnull1087 function AddSeg(numSlice: integer): integer;
1088 begin
1089 result := FSlices[numSlice].nbSegments;
1090 if length(FSlices[numSlice].segments)=FSlices[numSlice].nbSegments then
1091 setlength(FSlices[numSlice].segments,FSlices[numSlice].nbSegments*2+2);
1092 inc(FSlices[numSlice].nbSegments);
1093 end;
1094
1095 var
1096 yList: array of single;
1097 nbYList: integer;
1098 ya,yb,temp: single;
1099 sliceStart,sliceEnd,idxSeg: integer;
1100 i,j,idSeg: integer;
1101
1102 begin
1103 inherited Create(points, APixelCenteredCoordinates);
1104
1105 //slice
1106 nbYList:= length(FPoints)*2;
1107 setlength(YList, nbYList);
1108 for i := 0 to high(FPoints) do
1109 begin
1110 YList[i*2] := FPoints[i].y;
1111 YList[i*2+1] := FPoints[i].y2;
1112 end;
1113
1114 SortSingles(YList);
1115 RemoveSingleDuplicates(YList, nbYList);
1116
1117 setlength(FSlices, nbYList-1);
1118 for i := 0 to high(FSlices) do
1119 begin
1120 FSlices[i].y1 := YList[i];
1121 FSlices[i].y2 := YList[i+1];
1122 FSlices[i].nbSegments := 0;
1123 end;
1124
1125 idSeg := 0;
1126 for j := 0 to high(FPoints) do
1127 begin
1128 if FPoints[j].slope<>EmptySingle then
1129 begin
1130 ya := FPoints[j].y;
1131 yb := FPoints[j].y2;
1132 if yb < ya then
1133 begin
1134 temp := ya;
1135 ya := yb;
1136 yb := temp;
1137 end;
1138 sliceStart := BinarySearchSingle(ya,YList,0,nbYList-1);
1139 sliceEnd := BinarySearchSingle(yb,YList,0,nbYList-1);
1140 if sliceEnd > high(FSlices) then sliceEnd := high(FSlices);
1141 for i := sliceStart to sliceEnd do
1142 begin
1143 if ((FPoints[j].y < FSlices[i].y2) and
1144 (FPoints[j].y2 > FSlices[i].y1)) or
1145 ((FPoints[j].y2 < FSlices[i].y2) and
1146 (FPoints[j].y > FSlices[i].y1)) then
1147 begin
1148 idxSeg := AddSeg(i);
1149 with FSlices[i].segments[idxSeg] do
1150 begin
1151 inc(idSeg);
1152 id := idSeg;
1153 custom:= @FPoints[j];
1154 end;
1155 end;
1156 end;
1157 end;
1158 end;
1159
1160 FCurSlice := 0;
1161 FMaxIntersection:= 0;
1162 for i := 0 to high(FSlices) do
1163 if FSlices[i].nbSegments > FMaxIntersection then
1164 FMaxIntersection:= FSlices[i].nbSegments;
1165 end;
1166
TFillPolyInfo.GetSliceIndexnull1167 function TFillPolyInfo.GetSliceIndex: integer;
1168 begin
1169 Result:= FCurSlice;
1170 end;
1171
1172 { TOnePassFillPolyInfo }
1173
PartitionByYnull1174 function TOnePassFillPolyInfo.PartitionByY(left,right: integer): integer;
1175
1176 procedure Swap(idx1,idx2: integer); inline;
1177 var temp: POnePassRecord;
1178 begin
1179 temp := FSortedByY[idx1];
1180 FSortedByY[idx1] := FSortedByY[idx2];
1181 FSortedByY[idx2] := temp;
1182 end;
1183
1184 var pivotIndex: integer;
1185 pivotValue: single;
1186 storeIndex: integer;
1187 i: integer;
1188
1189 begin
1190 pivotIndex := left + random(right-left+1);
1191 pivotValue := FSortedByY[pivotIndex]^.custom^.y;
1192 swap(pivotIndex,right);
1193 storeIndex := left;
1194 for i := left to right-1 do
1195 if FSortedByY[i]^.custom^.y <= pivotValue then
1196 begin
1197 swap(i,storeIndex);
1198 inc(storeIndex);
1199 end;
1200 swap(storeIndex,right);
1201 result := storeIndex;
1202 end;
1203
1204 procedure TOnePassFillPolyInfo.QuickSortByY(left,right: integer);
1205 var pivotNewIndex: integer;
1206 begin
1207 if right > left+9 then
1208 begin
1209 pivotNewIndex := PartitionByY(left,right);
1210 QuickSortByY(left,pivotNewIndex-1);
1211 QuickSortByY(pivotNewIndex+1,right);
1212 end;
1213 end;
1214
1215 procedure TOnePassFillPolyInfo.InsertionSortByY;
1216 var i,j: integer;
1217 tempValue: single;
1218 tempPtr: POnePassRecord;
1219 begin
1220 for i := 1 to high(FSortedByY) do
1221 begin
1222 tempPtr := FSortedByY[i];
1223 TempValue := tempPtr^.custom^.y;
1224 j := i;
1225 while (j>0) and (FSortedByY[j-1]^.custom^.y > TempValue) do
1226 begin
1227 FSortedByY[j] := FSortedByY[j-1];
1228 dec(j);
1229 end;
1230 FSortedByY[j] := tempPtr;
1231 end;
1232 end;
1233
1234 procedure TOnePassFillPolyInfo.SortByY;
1235 var i,nbSorted: integer;
1236 begin
1237 setlength(FSortedByY, length(FPoints));
1238 nbSorted := 0;
1239 for i := 0 to high(FSortedByY) do
1240 if not FPoints[i].empty then
1241 begin
1242 FSortedByY[nbSorted] := @FOnePass[i];
1243 inc(nbSorted);
1244 end;
1245 setlength(FSortedByY,nbSorted);
1246 if length(FSortedByY) < 10 then InsertionSortByY else
1247 begin
1248 QuickSortByY(0,high(FSortedByY));
1249 InsertionSortByY;
1250 end;
1251 end;
1252
1253 procedure TOnePassFillPolyInfo.ComputeIntersection(cury: single;
1254 var inter: ArrayOfTIntersectionInfo; var nbInter: integer);
1255 var
1256 p,pprev,pnext: POnePassRecord;
1257 { t: TextFile;
1258 i: Integer; }
1259 pCust: PCustomPointRecord;
1260 pInter: PIntersectionInfo;
1261 begin
1262 FShouldInitializeDrawing := true;
1263
1264 p := FFirstWaiting;
1265 while p <> nil do
1266 begin
1267 if (cury >= p^.custom^.y) then
1268 begin
1269 if cury <= p^.custom^.y2+1 then
1270 begin
1271 p^.nextDrawing := FFirstDrawing;
1272 FFirstDrawing := p;
1273 inc(FSliceIndex);
1274 end;
1275 end
1276 else break;
1277 p := p^.nextWaiting;
1278 end;
1279 FFirstWaiting:= p;
1280
1281 p := FFirstDrawing;
1282 pprev := nil;
1283 pInter := @inter[nbInter];
1284 while p <> nil do
1285 begin
1286 pnext := p^.nextDrawing;
1287 pCust := p^.custom;
1288 if (((cury > pCust^.y) and (cury < pCust^.y2)) or
1289 (pCust^.includeStartingPoint and (cury = pCust^.y)) or
1290 (pCust^.includeEndingPoint and (cury = pCust^.y2))) then
1291 begin
1292 if pInter^ = nil then pInter^ := CreateIntersectionInfo;
1293 SetIntersectionValues(pInter^, (cury - pCust^.y)*pCust^.slope + pCust^.x,
1294 pCust^.winding, p^.id, cury - pCust^.y, pCust^.data);
1295 inc(nbinter);
1296 inc(pInter);
1297 end else
1298 if (cury > pCust^.y2+1) then
1299 begin
1300 if pprev <> nil then
1301 pprev^.nextDrawing := pnext
1302 else
1303 FFirstDrawing:= pnext;
1304 p := pnext;
1305 Inc(FSliceIndex);
1306 continue;
1307 end;
1308 pprev := p;
1309 p := pnext;
1310 end;
1311 { if odd(nbInter) then
1312 begin
1313 assignfile(t, 'polygon.dump');
1314 rewrite(t);
1315 writeln(t,'Polygon tested at ',cury);
1316 for i := 0 to NbPoints-1 do
1317 if isEmptyPointF(FPoints[i]) then write(t,'] [') else
1318 write(t,FPoints[i].x, ',', FPoints[i].y,' ');
1319 writeln(t);
1320 writeln(t,'Drawing');
1321 p := FFirstDrawing;
1322 while p <> nil do
1323 begin
1324 if ((p^.winding > 0) and
1325 (((cury > p^.y1) and (cury < p^.y2)) or
1326 (p^.includeStartingPoint and (cury = p^.y1)) or
1327 (p^.includeEndingPoint and (cury = p^.y2)))) or
1328 ((p^.winding < 0) and
1329 (((cury > p^.y1) and (cury < p^.y2)) or
1330 (p^.includeStartingPoint and (cury = p^.y2)) or
1331 (p^.includeEndingPoint and (cury = p^.y1)))) then
1332 write(t,'* ') else write(t,'- ');
1333
1334 writeln(t,p^.x1,',',p^.y1,' ',p^.x2,',',p^.y2,' ',p^.winding,' ',BoolToStr(p^.includeEndingPoint,'end incl','end not incl'));
1335 p := p^.nextDrawing;
1336 end;
1337 closefile(t);
1338
1339 raise exception.Create('Even intersections expected');
1340 end; }
1341 end;
1342
1343 constructor TOnePassFillPolyInfo.Create(const points: array of TPointF; APixelCenteredCoordinates: boolean);
1344 var i,j: integer;
1345 p: POnePassRecord;
1346 begin
1347 inherited create(points, APixelCenteredCoordinates);
1348
1349 FShouldInitializeDrawing := true;
1350 setlength(FOnePass, length(FPoints));
1351 for i := 0 to high(FPoints) do
1352 if not FPoints[i].empty then
1353 begin
1354 p := @FOnePass[i];
1355 p^.id := i;
1356 j := FPoints[i].next;
1357 p^.next := @FOnePass[j];
1358 p^.custom:= @FPoints[i];
1359 end;
1360
1361 SortByY;
1362 FSliceIndex := 0;
1363 end;
1364
CreateIntersectionArraynull1365 function TOnePassFillPolyInfo.CreateIntersectionArray: ArrayOfTIntersectionInfo;
1366 var i: integer;
1367 p,pprev: POnePassRecord;
1368 begin
1369 if FShouldInitializeDrawing then
1370 begin
1371 FShouldInitializeDrawing := false;
1372 FFirstWaiting:= nil;
1373 pprev := nil;
1374 for i := 0 to high(FSortedByY) do
1375 begin
1376 p := FSortedByY[i];
1377 if p^.custom^.slope <> EmptySingle then
1378 begin
1379 if pprev <> nil then
1380 pprev^.nextWaiting:= p
1381 else
1382 FFirstWaiting := p;
1383 pprev := p;
1384 end;
1385 end;
1386 end;
1387 result := inherited CreateIntersectionArray;
1388 end;
1389
GetSliceIndexnull1390 function TOnePassFillPolyInfo.GetSliceIndex: integer;
1391 begin
1392 Result:= FSliceIndex;
1393 end;
1394
1395 { TSimpleFillPolyInfo }
1396
1397 procedure TSimpleFillPolyInfo.ComputeIntersection(cury: single;
1398 var inter: ArrayOfTIntersectionInfo; var nbInter: integer);
1399 var i: integer;
1400 p: PCustomPointRecord;
1401 pInter: PIntersectionInfo;
1402 begin
1403 if FPoints = nil then exit;
1404 p := @FPoints[0];
1405 pInter := @inter[nbInter];
1406 for i := 0 to high(FPoints) do
1407 begin
1408 if (p^.winding <> 0) and
1409 ( ((cury > p^.y) and (cury < p^.y2)) or
1410 (p^.includeStartingPoint and (cury = p^.y)) or
1411 (p^.includeEndingPoint and (cury = p^.y2)) ) then
1412 begin
1413 if pInter^ = nil then pInter^ := CreateIntersectionInfo;
1414 SetIntersectionValues(pInter^, (cury - p^.y)*p^.slope + p^.x, p^.winding, i, cury - p^.y, p^.data);
1415 inc(nbinter);
1416 inc(pInter);
1417 end;
1418 inc(p);
1419 end;
1420 end;
1421
1422 constructor TSimpleFillPolyInfo.Create(const points: array of TPointF; APixelCenteredCoordinates: boolean);
1423 begin
1424 inherited Create(points, APixelCenteredCoordinates);
1425 end;
1426
1427 { TFillEllipseInfo }
1428
1429 constructor TFillEllipseInfo.Create(x, y, rx, ry: single);
1430 begin
1431 FX := x + 0.5;
1432 FY := y + 0.5;
1433 FRX := abs(rx);
1434 FRY := abs(ry);
1435 WindingFactor := 1;
1436 FSliceIndex:= -1;
1437 end;
1438
TFillEllipseInfo.GetBoundsnull1439 function TFillEllipseInfo.GetBounds: TRect;
1440 begin
1441 Result := rect(floor(fx - frx), floor(fy - fry), ceil(fx + frx), ceil(fy + fry));
1442 end;
1443
SegmentsCurvednull1444 function TFillEllipseInfo.SegmentsCurved: boolean;
1445 begin
1446 Result:= true;
1447 end;
1448
TFillEllipseInfo.GetSliceIndexnull1449 function TFillEllipseInfo.GetSliceIndex: integer;
1450 begin
1451 Result:= FSliceIndex;
1452 end;
1453
GetCenternull1454 function TFillEllipseInfo.GetCenter: TPointF;
1455 begin
1456 result := PointF(FX-0.5,FY-0.5);
1457 end;
1458
TFillEllipseInfo.NbMaxIntersectionnull1459 function TFillEllipseInfo.NbMaxIntersection: integer;
1460 begin
1461 Result := 2;
1462 end;
1463
1464 procedure TFillEllipseInfo.ComputeIntersection(cury: single;
1465 var inter: ArrayOfTIntersectionInfo; var nbInter: integer);
1466 var
1467 d: single;
1468 begin
1469 if (FRY <= 0) or (FRX <= 0) then exit;
1470 d := sqr((cury - FY) / FRY);
1471 if d < 1 then
1472 begin
1473 d := sqrt(1 - d) * FRX;
1474 inter[nbinter].SetValues( FX - d, -windingFactor, 0);
1475 Inc(nbinter);
1476 inter[nbinter].SetValues( FX + d, windingFactor, 1);
1477 Inc(nbinter);
1478 FSliceIndex := 0;
1479 end else
1480 begin
1481 if cury < FY then
1482 FSliceIndex:= -1
1483 else
1484 FSliceIndex:= 1;
1485 end;
1486 end;
1487
1488 { TFillBorderEllipseInfo }
1489
1490 constructor TFillBorderEllipseInfo.Create(x, y, rx, ry, w: single);
1491 begin
1492 if rx < 0 then
1493 rx := -rx;
1494 if ry < 0 then
1495 ry := -ry;
1496 FOuterBorder := TFillEllipseInfo.Create(x, y, rx + w / 2, ry + w / 2);
1497 if (rx > w / 2) and (ry > w / 2) then
1498 begin
1499 FInnerBorder := TFillEllipseInfo.Create(x, y, rx - w / 2, ry - w / 2);
1500 FInnerBorder.WindingFactor := -1;
1501 end
1502 else
1503 FInnerBorder := nil;
1504 end;
1505
TFillBorderEllipseInfo.GetBoundsnull1506 function TFillBorderEllipseInfo.GetBounds: TRect;
1507 begin
1508 Result := FOuterBorder.GetBounds;
1509 end;
1510
SegmentsCurvednull1511 function TFillBorderEllipseInfo.SegmentsCurved: boolean;
1512 begin
1513 Result:= FOuterBorder.SegmentsCurved;
1514 if FInnerBorder <> nil then result := result or FInnerBorder.SegmentsCurved;
1515 end;
1516
TFillBorderEllipseInfo.NbMaxIntersectionnull1517 function TFillBorderEllipseInfo.NbMaxIntersection: integer;
1518 begin
1519 Result := 4;
1520 end;
1521
1522 procedure TFillBorderEllipseInfo.ComputeIntersection(cury: single;
1523 var inter: ArrayOfTIntersectionInfo; var nbInter: integer);
1524 begin
1525 FOuterBorder.ComputeIntersection(cury, inter, nbInter);
1526 if FInnerBorder <> nil then
1527 FInnerBorder.ComputeIntersection(cury, inter, nbInter);
1528 end;
1529
1530 destructor TFillBorderEllipseInfo.Destroy;
1531 begin
1532 FOuterBorder.Free;
1533 if FInnerBorder <> nil then
1534 FInnerBorder.Free;
1535 inherited Destroy;
1536 end;
1537
GetSliceIndexnull1538 function TFillBorderEllipseInfo.GetSliceIndex: integer;
1539 begin
1540 Result:= FOuterBorder.GetSliceIndex;
1541 end;
1542
1543 { TFillRoundRectangleInfo }
1544
1545 constructor TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry: single; options: TRoundRectangleOptions; APixelCenteredCoordinates: boolean);
1546 var
1547 temp: Single;
1548 begin
1549 if y1 > y2 then
1550 begin
1551 temp := y1;
1552 y1 := y2;
1553 y2 := temp;
1554 end;
1555 if x1 > x2 then
1556 begin
1557 temp := x1;
1558 x1 := x2;
1559 x2 := temp;
1560 end;
1561 if APixelCenteredCoordinates then
1562 begin
1563 FX1 := x1 + 0.5;
1564 FY1 := y1 + 0.5;
1565 FX2 := x2 + 0.5;
1566 FY2 := y2 + 0.5;
1567 end else
1568 begin
1569 FX1 := x1;
1570 FY1 := y1;
1571 FX2 := x2;
1572 FY2 := y2;
1573 end;
1574 FRX := abs(rx);
1575 FRY := abs(ry);
1576 if 2*FRX > x2-x1 then FRX := (x2-x1)/2;
1577 if 2*FRY > y2-y1 then FRY := (y2-y1)/2;
1578 FOptions:= options;
1579 WindingFactor := 1;
1580 end;
1581
SegmentsCurvednull1582 function TFillRoundRectangleInfo.SegmentsCurved: boolean;
1583 begin
1584 if (not (rrTopLeftSquare in FOptions) and not (rrTopLeftBevel in FOptions)) or
1585 (not (rrTopRightSquare in FOptions) and not (rrTopRightBevel in FOptions)) or
1586 (not (rrBottomRightSquare in FOptions) and not (rrBottomRightBevel in FOptions)) or
1587 (not (rrBottomLeftSquare in FOptions) and not (rrBottomLeftBevel in FOptions)) then
1588 result := true else result := false;
1589 end;
1590
TFillRoundRectangleInfo.GetBoundsnull1591 function TFillRoundRectangleInfo.GetBounds: TRect;
1592 begin
1593 result := rect(floor(fx1),floor(fy1),floor(fx2)+1,floor(fy2)+1);
1594 end;
1595
TFillRoundRectangleInfo.GetBottomRightnull1596 function TFillRoundRectangleInfo.GetBottomRight: TPointF;
1597 begin
1598 result := PointF(FX2-0.5,FY2-0.5);
1599 end;
1600
TFillRoundRectangleInfo.GetTopLeftnull1601 function TFillRoundRectangleInfo.GetTopLeft: TPointF;
1602 begin
1603 result := PointF(FX1-0.5,FY1-0.5);
1604 end;
1605
TFillRoundRectangleInfo.NbMaxIntersectionnull1606 function TFillRoundRectangleInfo.NbMaxIntersection: integer;
1607 begin
1608 result := 2;
1609 end;
1610
1611 procedure TFillRoundRectangleInfo.ComputeIntersection(cury: single;
1612 var inter: ArrayOfTIntersectionInfo; var nbInter: integer);
1613 var
1614 d,d2: single;
1615 begin
1616 if (cury >= FY1) and (cury <= FY2) then
1617 begin
1618 if cury < FY1+FRY then
1619 begin
1620 d := abs((cury - (FY1+FRY)) / FRY);
1621 if d > 1 then d2 := 0
1622 else d2 := sqrt(1 - sqr(d)) * FRX;
1623
1624 if rrTopLeftSquare in FOptions then
1625 inter[nbinter].interX := FX1 else
1626 if rrTopLeftBevel in FOptions then
1627 inter[nbinter].interX := FX1 + d*FRX
1628 else
1629 inter[nbinter].interX := FX1 + FRX - d2;
1630 inter[nbinter].winding := -windingFactor;
1631 inter[nbinter].numSegment := 0;
1632 Inc(nbinter);
1633
1634 if rrTopRightSquare in FOptions then
1635 inter[nbinter].interX := FX2 else
1636 if rrTopRightBevel in FOptions then
1637 inter[nbinter].interX := FX2 - d*FRX
1638 else
1639 inter[nbinter].interX := FX2 - FRX + d2;
1640 inter[nbinter].winding := +windingFactor;
1641 inter[nbinter].numSegment := 1;
1642 Inc(nbinter);
1643 end else
1644 if cury > FY2-FRY then
1645 begin
1646 d := abs((cury - (FY2-FRY)) / FRY);
1647 if d > 1 then d2 := 0
1648 else d2 := sqrt(1 - sqr(d)) * FRX;
1649
1650 if rrBottomLeftSquare in FOptions then
1651 inter[nbinter].interX := FX1 else
1652 if rrBottomLeftBevel in FOptions then
1653 inter[nbinter].interX := FX1 + d*FRX
1654 else
1655 inter[nbinter].interX := FX1 + FRX - d2;
1656 inter[nbinter].winding := -windingFactor;
1657 inter[nbinter].numSegment := 0;
1658 Inc(nbinter);
1659
1660 if rrBottomRightSquare in FOptions then
1661 inter[nbinter].interX := FX2 else
1662 if rrBottomRightBevel in FOptions then
1663 inter[nbinter].interX := FX2 - d*FRX
1664 else
1665 inter[nbinter].interX := FX2 - FRX + d2;
1666 inter[nbinter].winding := +windingFactor;
1667 inter[nbinter].numSegment := 1;
1668 Inc(nbinter);
1669 end else
1670 begin
1671 inter[nbinter].interX := FX1;
1672 inter[nbinter].winding := -windingFactor;
1673 inter[nbinter].numSegment := 0;
1674 Inc(nbinter);
1675 inter[nbinter].interX := FX2;
1676 inter[nbinter].winding := +windingFactor;
1677 inter[nbinter].numSegment := 1;
1678 Inc(nbinter);
1679 end;
1680 end;
1681 end;
1682
1683 { TFillBorderRoundRectInfo }
1684
1685 constructor TFillBorderRoundRectInfo.Create(x1, y1, x2, y2, rx, ry, w: single; options: TRoundRectangleOptions; APixelCenteredCoordinates: boolean);
1686 var rdiff: single;
1687 temp: Single;
1688 begin
1689 if y1 > y2 then
1690 begin
1691 temp := y1;
1692 y1 := y2;
1693 y2 := temp;
1694 end;
1695 if x1 > x2 then
1696 begin
1697 temp := x1;
1698 x1 := x2;
1699 x2 := temp;
1700 end;
1701
1702 if rx < 0 then
1703 rx := -rx;
1704 if ry < 0 then
1705 ry := -ry;
1706 if 2*rx > x2-x1 then rx := (x2-x1)/2;
1707 if 2*ry > y2-y1 then ry := (y2-y1)/2;
1708 rdiff := w*(sqrt(2)-1);
1709 FOuterBorder := TFillRoundRectangleInfo.Create(x1-w/2,y1-w/2,x2+w/2,y2+w/2, rx+rdiff, ry+rdiff, options, APixelCenteredCoordinates);
1710 if (abs(x2-x1) > w) and (abs(y2-y1) > w) then
1711 begin
1712 if (rx-rdiff <= 0) or (ry-rdiff <= 0) then
1713 FInnerBorder := TFillRoundRectangleInfo.Create(x1+w/2, y1+w/2, x2-w/2, y2-w/2, 0,0, options, APixelCenteredCoordinates)
1714 else
1715 FInnerBorder := TFillRoundRectangleInfo.Create(x1+w/2, y1+w/2, x2-w/2, y2-w/2, rx-rdiff, ry-rdiff, options, APixelCenteredCoordinates);
1716 FInnerBorder.WindingFactor := -1;
1717 end
1718 else
1719 FInnerBorder := nil;
1720 end;
1721
TFillBorderRoundRectInfo.GetBoundsnull1722 function TFillBorderRoundRectInfo.GetBounds: TRect;
1723 begin
1724 result := FOuterBorder.GetBounds;
1725 end;
1726
SegmentsCurvednull1727 function TFillBorderRoundRectInfo.SegmentsCurved: boolean;
1728 begin
1729 Result:= FOuterBorder.SegmentsCurved;
1730 if FInnerBorder <> nil then result := result or FInnerBorder.SegmentsCurved;
1731 end;
1732
TFillBorderRoundRectInfo.NbMaxIntersectionnull1733 function TFillBorderRoundRectInfo.NbMaxIntersection: integer;
1734 begin
1735 Result := 4;
1736 end;
1737
1738 procedure TFillBorderRoundRectInfo.ComputeIntersection(cury: single;
1739 var inter: ArrayOfTIntersectionInfo; var nbInter: integer);
1740 begin
1741 FOuterBorder.ComputeIntersection(cury, inter, nbInter);
1742 if FInnerBorder <> nil then
1743 FInnerBorder.ComputeIntersection(cury, inter, nbInter);
1744 end;
1745
1746 destructor TFillBorderRoundRectInfo.Destroy;
1747 begin
1748 FOuterBorder.Free;
1749 FInnerBorder.Free;
1750 inherited Destroy;
1751 end;
1752
1753 initialization
1754
1755 Randomize;
1756
1757 end.
1758
1759