Ignore:
Timestamp:
Feb 1, 2012, 3:02:33 PM (12 years ago)
Author:
chronos
Message:
  • Modified: Updated BGRABitmap package to version 5.5.
  • Modified: Removed draw method ComboBox and reorganized method list to single listview with using ownerdraw facility.
  • Added: New draw method TBitmap.RawImage.Data Move which use fast Move operation. It requires same pixel format.
  • Added: New draw method Dummy for comparion of empty method and to determine possibily max frame rate limit.
Location:
GraphicTest/BGRABitmap
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • GraphicTest/BGRABitmap

    • Property svn:ignore set to
      lib

  • GraphicTest/BGRABitmap/bgrapolygon.pas

    r210 r317  
    33{$mode objfpc}{$H+}
    44
     5{ This unit contains polygon drawing functions and spline functions.
     6
     7  Shapes are drawn using a TFillShapeInfo object, which calculates the
     8  intersection of an horizontal line and the polygon.
     9
     10  Various shapes are handled :
     11  - TFillPolyInfo : polygon
     12  - TFillEllipseInfo : ellipse
     13  - TFillBorderEllipseInfo : ellipse border
     14  - TFillRoundRectangleInfo : round rectangle (or other corners)
     15  - TFillBorderRoundRectInfo : round rectangle border
     16
     17  Various fill modes :
     18  - Alternate : each time there is an intersection, it enters or go out of the polygon
     19  - Winding : filled when the sum of ascending and descending intersection is non zero
     20  - Color : fill with a color defined as a TBGRAPixel argument
     21  - Erase : erase with an alpha in the TBGRAPixel argument
     22  - Texture : draws a texture with the IBGRAScanner argument
     23
     24  Various border handling :
     25  - aliased : one horizontal line intersection is calculated per pixel in the vertical loop
     26  - antialiased : more lines are calculated and a density is computed by adding them together
     27  - multi-polygon antialiasing and superposition (TBGRAMultiShapeFiller) : same as above but
     28    by combining multiple polygons at the same time, and optionally subtracting top polygons
     29  }
     30
    531interface
    632
    733uses
    8   Classes, SysUtils, BGRADefaultBitmap, BGRABitmapTypes;
     34  Classes, SysUtils, BGRABitmapTypes, BGRAFillInfo, Graphics;
     35
     36procedure FillShapeAntialias(bmp: TBGRACustomBitmap; shapeInfo: TFillShapeInfo;
     37  c: TBGRAPixel; EraseMode: boolean; scan: IBGRAScanner; NonZeroWinding: boolean);
     38procedure FillShapeAntialiasWithTexture(bmp: TBGRACustomBitmap; shapeInfo: TFillShapeInfo;
     39  scan: IBGRAScanner; NonZeroWinding: boolean);
     40procedure FillShapeAliased(bmp: TBGRACustomBitmap; shapeInfo: TFillShapeInfo;
     41  c: TBGRAPixel; EraseMode: boolean; scan: IBGRAScanner; NonZeroWinding: boolean; drawmode: TDrawMode; AliasingIncludeBottomRight: Boolean= false);
    942
    1043type
    11   ArrayOfSingle = array of single;
    12 
    13   { TFillShapeInfo }
    14 
    15   TFillShapeInfo = class
    16     function GetBounds: TRect; virtual;
    17     function NbMaxIntersection: integer; virtual;
    18     procedure ComputeIntersection(cury: single; var inter: ArrayOfSingle;
    19       var nbInter: integer); virtual;
    20   end;
    21 
    22 procedure FillShapeAntialias(bmp: TBGRADefaultBitmap; shapeInfo: TFillShapeInfo;
     44
     45  { TBGRAMultishapeFiller }
     46
     47  TBGRAMultishapeFiller = class
     48  protected
     49    nbShapes: integer;
     50    shapes: array of record
     51        info: TFillShapeInfo;
     52        internalInfo: boolean;
     53        texture: IBGRAScanner;
     54        internalTexture: TObject;
     55        color: TExpandedPixel;
     56        bounds: TRect;
     57      end;
     58    procedure AddShape(AInfo: TFillShapeInfo; AInternalInfo: boolean; ATexture: IBGRAScanner; AInternalTexture: TObject; AColor: TBGRAPixel);
     59    function CheckRectangleBorderBounds(var x1, y1, x2, y2: single; w: single): boolean;
     60  public
     61    FillMode : TFillMode;
     62    PolygonOrder: TPolygonOrder;
     63    Antialiasing: Boolean;
     64    AliasingIncludeBottomRight: Boolean;
     65    constructor Create;
     66    destructor Destroy; override;
     67    procedure AddShape(AShape: TFillShapeInfo; AColor: TBGRAPixel);
     68    procedure AddShape(AShape: TFillShapeInfo; ATexture: IBGRAScanner);
     69    procedure AddPolygon(const points: array of TPointF; AColor: TBGRAPixel);
     70    procedure AddPolygon(const points: array of TPointF; ATexture: IBGRAScanner);
     71    procedure AddTriangleLinearColor(pt1, pt2, pt3: TPointF; c1, c2, c3: TBGRAPixel);
     72    procedure AddTriangleLinearMapping(pt1, pt2, pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF);
     73    procedure AddQuadLinearColor(pt1, pt2, pt3, pt4: TPointF; c1, c2, c3, c4: TBGRAPixel);
     74    procedure AddQuadLinearMapping(pt1, pt2, pt3, pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF);
     75    procedure AddQuadPerspectiveMapping(pt1, pt2, pt3, pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF);
     76    procedure AddEllipse(x, y, rx, ry: single; AColor: TBGRAPixel);
     77    procedure AddEllipse(x, y, rx, ry: single; ATexture: IBGRAScanner);
     78    procedure AddEllipseBorder(x, y, rx, ry, w: single; AColor: TBGRAPixel);
     79    procedure AddEllipseBorder(x, y, rx, ry, w: single; ATexture: IBGRAScanner);
     80    procedure AddRoundRectangle(x1, y1, x2, y2, rx, ry: single; AColor: TBGRAPixel; options: TRoundRectangleOptions= []);
     81    procedure AddRoundRectangle(x1, y1, x2, y2, rx, ry: single; ATexture: IBGRAScanner; options: TRoundRectangleOptions= []);
     82    procedure AddRoundRectangleBorder(x1, y1, x2, y2, rx, ry, w: single; AColor: TBGRAPixel; options: TRoundRectangleOptions= []);
     83    procedure AddRoundRectangleBorder(x1, y1, x2, y2, rx, ry, w: single; ATexture: IBGRAScanner; options: TRoundRectangleOptions= []);
     84    procedure AddRectangle(x1, y1, x2, y2: single; AColor: TBGRAPixel);
     85    procedure AddRectangle(x1, y1, x2, y2: single; ATexture: IBGRAScanner);
     86    procedure AddRectangleBorder(x1, y1, x2, y2, w: single; AColor: TBGRAPixel);
     87    procedure AddRectangleBorder(x1, y1, x2, y2, w: single; ATexture: IBGRAScanner);
     88    procedure Draw(dest: TBGRACustomBitmap);
     89  end;
     90
     91procedure FillPolyAliased(bmp: TBGRACustomBitmap; points: array of TPointF;
     92  c: TBGRAPixel; EraseMode: boolean; NonZeroWinding: boolean; drawmode: TDrawMode);
     93procedure FillPolyAliasedWithTexture(bmp: TBGRACustomBitmap; points: array of TPointF;
     94  scan: IBGRAScanner; NonZeroWinding: boolean; drawmode: TDrawMode);
     95procedure FillPolyAntialias(bmp: TBGRACustomBitmap; points: array of TPointF;
     96  c: TBGRAPixel; EraseMode: boolean; NonZeroWinding: boolean);
     97procedure FillPolyAntialiasWithTexture(bmp: TBGRACustomBitmap; points: array of TPointF;
     98  scan: IBGRAScanner; NonZeroWinding: boolean);
     99
     100procedure FillEllipseAntialias(bmp: TBGRACustomBitmap; x, y, rx, ry: single;
    23101  c: TBGRAPixel; EraseMode: boolean);
    24 
    25 type
    26   { TFillPolyInfo }
    27 
    28   TFillPolyInfo = class(TFillShapeInfo)
    29   private
    30     FPoints:      array of TPointF;
    31     FSlopes:      array of single;
    32     FEmptyPt, FChangedir: array of boolean;
    33     FNext, FPrev: array of integer;
    34   public
    35     constructor Create(points: array of TPointF);
    36     function GetBounds: TRect; override;
    37     function NbMaxIntersection: integer; override;
    38     procedure ComputeIntersection(cury: single; var inter: ArrayOfSingle;
    39       var nbInter: integer); override;
    40   end;
    41 
    42 procedure FillPolyAntialias(bmp: TBGRADefaultBitmap; points: array of TPointF;
     102procedure FillEllipseAntialiasWithTexture(bmp: TBGRACustomBitmap; x, y, rx, ry: single;
     103  scan: IBGRAScanner);
     104
     105procedure BorderEllipseAntialias(bmp: TBGRACustomBitmap; x, y, rx, ry, w: single;
    43106  c: TBGRAPixel; EraseMode: boolean);
    44 
    45 type
    46   { TFillEllipseInfo }
    47 
    48   TFillEllipseInfo = class(TFillShapeInfo)
    49   private
    50     FX, FY, FRX, FRY: single;
    51   public
    52     constructor Create(x, y, rx, ry: single);
    53     function GetBounds: TRect; override;
    54     function NbMaxIntersection: integer; override;
    55     procedure ComputeIntersection(cury: single; var inter: ArrayOfSingle;
    56       var nbInter: integer); override;
    57   end;
    58 
    59 procedure FillEllipseAntialias(bmp: TBGRADefaultBitmap; x, y, rx, ry: single;
    60   c: TBGRAPixel; EraseMode: boolean);
    61 
    62 type
    63   { TFillBorderEllipseInfo }
    64 
    65   TFillBorderEllipseInfo = class(TFillShapeInfo)
    66   private
    67     innerBorder, outerBorder: TFillEllipseInfo;
    68   public
    69     constructor Create(x, y, rx, ry, w: single);
    70     function GetBounds: TRect; override;
    71     function NbMaxIntersection: integer; override;
    72     procedure ComputeIntersection(cury: single; var inter: ArrayOfSingle;
    73       var nbInter: integer); override;
    74     destructor Destroy; override;
    75   end;
    76 
    77 procedure BorderEllipseAntialias(bmp: TBGRADefaultBitmap; x, y, rx, ry, w: single;
    78   c: TBGRAPixel; EraseMode: boolean);
     107procedure BorderEllipseAntialiasWithTexture(bmp: TBGRACustomBitmap; x, y, rx, ry, w: single;
     108  scan: IBGRAScanner);
     109
     110procedure FillRoundRectangleAntialias(bmp: TBGRACustomBitmap; x1, y1, x2, y2, rx, ry: single;
     111  options: TRoundRectangleOptions; c: TBGRAPixel; EraseMode: boolean);
     112procedure FillRoundRectangleAntialiasWithTexture(bmp: TBGRACustomBitmap; x1, y1, x2, y2, rx, ry: single;
     113  options: TRoundRectangleOptions; scan: IBGRAScanner);
     114
     115procedure BorderRoundRectangleAntialias(bmp: TBGRACustomBitmap; x1, y1, x2, y2, rx, ry, w: single;
     116  options: TRoundRectangleOptions; c: TBGRAPixel; EraseMode: boolean);
     117procedure BorderRoundRectangleAntialiasWithTexture(bmp: TBGRACustomBitmap; x1, y1, x2, y2, rx, ry, w: single;
     118  options: TRoundRectangleOptions; scan: IBGRAScanner);
     119
     120procedure BorderAndFillRoundRectangleAntialias(bmp: TBGRACustomBitmap; x1, y1, x2, y2, rx, ry, w: single;
     121  options: TRoundRectangleOptions; bordercolor,fillcolor: TBGRAPixel; bordertexture,filltexture: IBGRAScanner; EraseMode: boolean);
    79122
    80123implementation
    81124
    82 uses Math, bgrablend;
    83 
    84 procedure FillShapeAntialias(bmp: TBGRADefaultBitmap; shapeInfo: TFillShapeInfo;
    85   c: TBGRAPixel; EraseMode: boolean);
    86 const
    87   precision = 11;
    88 var
    89   bounds: TRect;
    90   miny, maxy, minx, maxx: integer;
    91 
    92   inter:   array of single;
     125uses Math, BGRABlend, BGRAGradientScanner, BGRATransform;
     126
     127procedure FillShapeAntialias(bmp: TBGRACustomBitmap; shapeInfo: TFillShapeInfo;
     128  c: TBGRAPixel; EraseMode: boolean; scan: IBGRAScanner; NonZeroWinding: boolean);
     129var
     130  inter:   array of TIntersectionInfo;
    93131  nbInter: integer;
    94   density: packed array of single;
     132
     133  firstScan, lastScan: record
     134    inter:   array of TIntersectionInfo;
     135    nbInter: integer;
     136  end;
     137
     138  miny, maxy, minx, maxx,
     139  densMinX, densMaxX: integer;
     140
     141  density: PDensity;
    95142
    96143  xb, yb, yc, i, j: integer;
    97144
    98   temp, cury, x1, x2: single;
     145  x1, x2, x1b,x2b: single;
    99146  ix1, ix2: integer;
    100147  pdest:    PBGRAPixel;
    101   pdens:    PSingle;
    102 
    103 begin
    104   bounds := shapeInfo.GetBounds;
    105   if (bounds.Right <= bounds.left) or (bounds.bottom <= bounds.top) then
    106     exit;
    107 
    108   miny := bounds.top;
    109   maxy := bounds.bottom - 1;
    110   minx := bounds.left;
    111   maxx := bounds.right - 1;
    112 
    113   if minx < 0 then
    114     minx := 0;
    115   if maxx < 0 then
    116     exit;
    117   if maxx > bmp.Width - 1 then
    118     maxx := bmp.Width - 1;
    119   if minx > bmp.Width - 1 then
    120     exit;
    121   if miny < 0 then
    122     miny := 0;
    123   if miny > bmp.Height - 1 then
    124     exit;
    125   if maxy > bmp.Height - 1 then
    126     maxy := bmp.Height - 1;
    127   if maxy < 0 then
    128     exit;
    129 
    130   setlength(inter, shapeInfo.NbMaxIntersection);
    131   setlength(density, maxx - minx + 2); //one more for safety
     148  pdens:    PDensity;
     149
     150  curvedSeg,optimised: boolean;
     151  ec: TExpandedPixel;
     152  c2:TBGRAPixel;
     153  MemScanCopy,pscan: pbgrapixel;
     154  ScanNextPixelProc: TScanNextPixelFunction;
     155  temp: Single;
     156
     157  function GetYScan(num: integer): single; inline;
     158  begin
     159    result := yb + (num * 2 + 1) / (AntialiasPrecision * 2);
     160  end;
     161
     162  procedure SubTriangleDensity(x1,density1, x2, density2: single);
     163  var ix1,ix2,n: integer;
     164      slope: single;
     165    function densityAt(x: single): single; inline;
     166    begin
     167      result := (x-x1)*slope+density1;
     168    end;
     169  var
     170      curdens: single;
     171      pdens: pdensity;
     172  begin
     173    if (x1 <> x2) and (x1 < maxx + 1) and (x2 >= minx) then
     174    begin
     175      slope := (density2-density1)/(x2-x1);
     176      if x1 < minx then
     177      begin
     178        density1 := densityAt(minx);
     179        x1 := minx;
     180      end;
     181      if x2 >= maxx + 1 then
     182      begin
     183        density2 := densityAt(maxx+1);
     184        x2 := maxx + 1;
     185      end;
     186      ix1  := floor(x1);
     187      ix2  := floor(x2);
     188
     189      if ix1 = ix2 then
     190        (density + (ix1 - minx))^ -= round((x2 - x1)*(density1+density2)/2)
     191      else
     192      begin
     193        (density + (ix1 - minx))^ := max(0, (density + (ix1 - minx))^ - round((1 - (x1 - ix1))*(density1+densityAt(ix1+1))/2) );
     194        if (ix2 <= maxx) then
     195          (density + (ix2 - minx))^ := max(0, (density + (ix2 - minx))^ - round((x2 - ix2)*(density2+densityAt(ix2))/2) );
     196      end;
     197      if ix2 > ix1 + 1 then
     198      begin
     199        curdens := densityAt(ix1+1.5);
     200        pdens := density + (ix1+1 - minx);
     201        for n := ix2-1-(ix1+1) downto 0 do
     202        begin
     203          pdens^ -= round(curdens);
     204          curdens += slope;
     205          inc(pdens);
     206        end;
     207      end;
     208    end;
     209  end;
     210
     211begin
     212  if (scan=nil) and (c.alpha=0) then exit;
     213  If not shapeInfo.ComputeMinMax(minx,miny,maxx,maxy,bmp) then exit;
     214
     215  inter := shapeInfo.CreateIntersectionArray;
     216  getmem(density, (maxx - minx + 2)*sizeof(TDensity)); //more for safety
     217  ec := GammaExpansion(c);
     218  c2 := c;
     219
     220  MemScanCopy := nil;
     221  ScanNextPixelProc := nil;
     222  if scan <> nil then
     223  begin
     224    if scan.IsScanPutPixelsDefined then
     225      GetMem(MemScanCopy,(maxx-minx+1)*sizeof(TBGRAPixel));
     226    ScanNextPixelProc := @scan.ScanNextPixel;
     227  end;
     228
     229  curvedSeg := shapeInfo.SegmentsCurved;
     230  if not curvedSeg then
     231  begin
     232    firstScan.inter := shapeInfo.CreateIntersectionArray;
     233    lastScan.inter := shapeInfo.CreateIntersectionArray;
     234  end;
    132235
    133236  //vertical scan
    … …  
    135238  begin
    136239    //mean density
    137     for i := 0 to high(density) do
    138       density[i] := 0;
    139 
    140     //precision scan
    141     for yc := 0 to precision - 1 do
    142     begin
    143       cury := yb + (yc * 2 + 1) / (precision * 2);
    144 
    145       //find intersections
    146       nbinter := 0;
    147       shapeInfo.ComputeIntersection(cury, inter, nbInter);
    148       if nbinter = 0 then
    149         continue;
    150 
    151       //sort intersections
    152       for i := 1 to nbinter - 1 do
    153       begin
    154         j := i;
    155         while (j > 0) and (inter[j - 1] > inter[j]) do
     240    fillchar(density^,(maxx-minx+1)*sizeof(TDensity),0);
     241
     242    densMinX := maxx+1;
     243    densMaxX := minx-1;
     244
     245    if not curvedSeg then
     246    begin
     247      with firstScan do
     248        shapeInfo.ComputeAndSort(yb+1/256,inter,nbInter,NonZeroWinding);
     249      with lastScan do
     250        shapeInfo.ComputeAndSort(yb+255/256,inter,nbInter,NonZeroWinding);
     251      if (firstScan.nbInter = lastScan.nbInter) and (firstScan.nbInter >= 2) then
     252      begin
     253        optimised := true;
     254        for i := 0 to firstScan.nbInter-1 do
     255          if firstScan.inter[i].numSegment <> lastScan.inter[i].numSegment then
     256          begin
     257            optimised := false;
     258            break;
     259          end;
     260      end else
     261        optimised := false;
     262
     263      if optimised then
     264      begin
     265        for i := 0 to firstScan.nbinter div 2 - 1 do
    156266        begin
    157           temp     := inter[j - 1];
    158           inter[j - 1] := inter[j];
    159           inter[j] := temp;
    160           Dec(j);
     267          x1 := firstScan.inter[i+i].interX;
     268          x1b := lastScan.inter[i+i].interX;
     269          if (x1 > x1b) then
     270          begin
     271            temp := x1;
     272            x1 := x1b;
     273            x1b := temp;
     274          end;
     275          x2 := firstScan.inter[i+i+1].interX;
     276          x2b := lastScan.inter[i+i+1].interX;
     277          if (x2 < x2b) then
     278          begin
     279            temp := x2;
     280            x2 := x2b;
     281            x2b := temp;
     282          end;
     283          {$i filldensitysegment256.inc}
     284          SubTriangleDensity(x1,256,x1b,0);
     285          SubTriangleDensity(x2b,0,x2,256);
    161286        end;
    162       end;
    163 
    164       //fill density
    165       for i := 0 to nbinter div 2 - 1 do
    166       begin
    167         x1 := inter[i + i];
    168         x2 := inter[i + i + 1];
    169         if (x1 <> x2) and (x1 < maxx + 1) and (x2 >= minx) then
     287      end else
     288      begin
     289        for yc := 0 to AntialiasPrecision - 1 do
    170290        begin
    171           if x1 < minx then
    172             x1 := minx;
    173           if x2 >= maxx + 1 then
    174             x2 := maxx + 1;
    175           ix1  := floor(x1);
    176           ix2  := floor(x2);
    177           if ix1 = ix2 then
    178             density[ix1 - minx] += x2 - x1
     291          //find intersections
     292          shapeInfo.ComputeAndSort(GetYScan(yc),inter,nbInter,NonZeroWinding);
     293
     294          {$i filldensity256.inc}
     295        end;
     296      end;
     297    end else
     298    begin
     299      optimised := false;
     300      //precision scan
     301      for yc := 0 to AntialiasPrecision - 1 do
     302      begin
     303        //find intersections
     304        shapeInfo.ComputeAndSort(GetYScan(yc),inter,nbInter,NonZeroWinding);
     305
     306        {$i filldensity256.inc}
     307      end;
     308    end;
     309
     310    if optimised then
     311      {$i renderdensity256.inc}
     312    else
     313      {$define PARAM_ANTIALIASINGFACTOR}
     314      {$i renderdensity256.inc}
     315  end;
     316
     317  freemem(MemScanCopy);
     318  shapeInfo.FreeIntersectionArray(inter);
     319
     320  if not curvedSeg then
     321  begin
     322    with firstScan do
     323    begin
     324      for i := 0 to high(inter) do
     325        inter[i].free;
     326    end;
     327    with lastScan do
     328    begin
     329      for i := 0 to high(inter) do
     330        inter[i].free;
     331    end;
     332  end;
     333  freemem(density);
     334
     335  bmp.InvalidateBitmap;
     336end;
     337
     338procedure FillShapeAliased(bmp: TBGRACustomBitmap; shapeInfo: TFillShapeInfo;
     339  c: TBGRAPixel; EraseMode: boolean; scan: IBGRAScanner; NonZeroWinding: boolean; drawmode: TDrawMode; AliasingIncludeBottomRight: Boolean= false);
     340var
     341  inter:    array of TIntersectionInfo;
     342  nbInter:  integer;
     343
     344  miny, maxy, minx, maxx: integer;
     345  xb,yb, i: integer;
     346  x1, x2: single;
     347  ix1, ix2: integer;
     348  pdest: PBGRAPixel;
     349  AliasingOfs: TPointF;
     350  ec: TExpandedPixel;
     351
     352begin
     353  if (scan=nil) and (c.alpha=0) then exit;
     354  If not shapeInfo.ComputeMinMax(minx,miny,maxx,maxy,bmp) then exit;
     355  inter := shapeInfo.CreateIntersectionArray;
     356
     357  if AliasingIncludeBottomRight then
     358    AliasingOfs := PointF(0,0) else
     359    AliasingOfs := PointF(-0.0001,-0.0001);
     360
     361  ec := GammaExpansion(c);
     362  if (scan = nil) and (c.alpha = 255) then drawmode := dmSet;
     363
     364  //vertical scan
     365  for yb := miny to maxy do
     366  begin
     367    //find intersections
     368    shapeInfo.ComputeAndSort( yb+0.5-AliasingOfs.Y, inter, nbInter, NonZeroWinding);
     369
     370    for i := 0 to nbinter div 2 - 1 do
     371    begin
     372      x1 := inter[i + i].interX-AliasingOfs.X;
     373      x2 := inter[i + i+ 1].interX-AliasingOfs.X;
     374
     375      if x1 <> x2 then
     376      begin
     377        ComputeAliasedRowBounds(x1,x2, minx,maxx, ix1,ix2);
     378        if ix1 <= ix2 then
     379        begin
     380          //render scanline
     381          if scan <> nil then //with texture scan
     382          begin
     383            pdest := bmp.ScanLine[yb] + ix1;
     384            scan.ScanMoveTo(ix1,yb);
     385            ScannerPutPixels(scan,pdest,ix2-ix1+1,drawmode);
     386          end else
     387          if EraseMode then //erase with alpha
     388          begin
     389            pdest := bmp.ScanLine[yb] + ix1;
     390            for xb := ix1 to ix2 do
     391            begin
     392              ErasePixelInline(pdest, c.alpha);
     393              Inc(pdest);
     394            end;
     395          end
    179396          else
    180397          begin
    181             density[ix1 - minx] += 1 - (x1 - ix1);
    182             if (ix2 <= maxx) then
    183               density[ix2 - minx] += x2 - ix2;
    184           end;
    185           if ix2 > ix1 + 1 then
    186           begin
    187             for j := ix1 + 1 to ix2 - 1 do
    188               density[j - minx] += 1;
     398            case drawmode of
     399              dmFastBlend: bmp.FastBlendHorizLine(ix1,yb,ix2, c);
     400              dmDrawWithTransparency: bmp.DrawHorizLine(ix1,yb,ix2, ec);
     401              dmSet: bmp.SetHorizLine(ix1,yb,ix2, c);
     402              dmXor: bmp.XorHorizLine(ix1,yb,ix2, c);
     403            end;
    189404          end;
    190405        end;
    191406      end;
    192 
    193407    end;
    194 
    195     pdest := bmp.ScanLine[yb] + minx;
    196     pdens := @density[0];
    197     //render scanline
    198     if EraseMode then
    199     begin
    200       for xb := minx to maxx do
    201       begin
    202         temp := pdens^;
    203         Inc(pdens);
    204         if temp <> 0 then
    205           ErasePixelInline(pdest, round(c.alpha * temp / precision));
    206         Inc(pdest);
    207       end;
    208     end
    209     else
    210     begin
    211       for xb := minx to maxx do
    212       begin
    213         temp := pdens^;
    214         Inc(pdens);
    215         if temp <> 0 then
    216           DrawPixelInline(pdest, BGRA(c.red, c.green, c.blue, round(
    217             c.alpha * temp / precision)));
    218         Inc(pdest);
    219       end;
    220     end;
    221   end;
    222 
     408  end;
     409
     410  shapeInfo.FreeIntersectionArray(inter);
    223411  bmp.InvalidateBitmap;
    224412end;
    225413
    226 procedure FillPolyAntialias(bmp: TBGRADefaultBitmap; points: array of TPointF;
    227   c: TBGRAPixel; EraseMode: boolean);
     414procedure FillShapeAntialiasWithTexture(bmp: TBGRACustomBitmap;
     415  shapeInfo: TFillShapeInfo; scan: IBGRAScanner; NonZeroWinding: boolean);
     416begin
     417  FillShapeAntialias(bmp,shapeInfo,BGRAPixelTransparent,False,scan,NonZeroWinding);
     418end;
     419
     420procedure FillPolyAliased(bmp: TBGRACustomBitmap; points: array of TPointF;
     421  c: TBGRAPixel; EraseMode: boolean; NonZeroWinding: boolean; drawmode: TDrawMode);
    228422var
    229423  info: TFillPolyInfo;
    … …  
    233427
    234428  info := TFillPolyInfo.Create(points);
    235   FillShapeAntialias(bmp, info, c, EraseMode);
    236   info.Free;
    237 end;
    238 
    239 procedure FillEllipseAntialias(bmp: TBGRADefaultBitmap; x, y, rx, ry: single;
     429  FillShapeAliased(bmp, info, c, EraseMode, nil, NonZeroWinding, drawmode);
     430  info.Free;
     431end;
     432
     433procedure FillPolyAliasedWithTexture(bmp: TBGRACustomBitmap;
     434  points: array of TPointF; scan: IBGRAScanner; NonZeroWinding: boolean; drawmode: TDrawMode);
     435var
     436  info: TFillPolyInfo;
     437begin
     438  if length(points) < 3 then
     439    exit;
     440
     441  info := TFillPolyInfo.Create(points);
     442  FillShapeAliased(bmp, info, BGRAPixelTransparent,False,scan, NonZeroWinding, drawmode);
     443  info.Free;
     444end;
     445
     446procedure FillPolyAntialias(bmp: TBGRACustomBitmap; points: array of TPointF;
     447  c: TBGRAPixel; EraseMode: boolean; NonZeroWinding: boolean);
     448var
     449  info: TFillPolyInfo;
     450begin
     451  if length(points) < 3 then
     452    exit;
     453
     454  info := TFillPolyInfo.Create(points);
     455  FillShapeAntialias(bmp, info, c, EraseMode, nil, NonZeroWinding);
     456  info.Free;
     457end;
     458
     459procedure FillPolyAntialiasWithTexture(bmp: TBGRACustomBitmap;
     460  points: array of TPointF; scan: IBGRAScanner; NonZeroWinding: boolean
     461  );
     462var
     463  info: TFillPolyInfo;
     464begin
     465  if length(points) < 3 then
     466    exit;
     467
     468  info := TFillPolyInfo.Create(points);
     469  FillShapeAntialiasWithTexture(bmp, info, scan, NonZeroWinding);
     470  info.Free;
     471end;
     472
     473procedure FillEllipseAntialias(bmp: TBGRACustomBitmap; x, y, rx, ry: single;
    240474  c: TBGRAPixel; EraseMode: boolean);
    241475var
    242476  info: TFillEllipseInfo;
    243477begin
    244   if (rx = 0) or (ry = 0) then
     478  if (rx = 0) or (ry = 0) or (x = EmptySingle) or (y = EmptySingle) then
    245479    exit;
    246480
    247481  info := TFillEllipseInfo.Create(x, y, rx, ry);
    248   FillShapeAntialias(bmp, info, c, EraseMode);
    249   info.Free;
    250 end;
    251 
    252 procedure BorderEllipseAntialias(bmp: TBGRADefaultBitmap; x, y, rx, ry, w: single;
     482  FillShapeAntialias(bmp, info, c, EraseMode, nil, False);
     483  info.Free;
     484end;
     485
     486procedure FillEllipseAntialiasWithTexture(bmp: TBGRACustomBitmap; x, y, rx,
     487  ry: single; scan: IBGRAScanner);
     488var
     489  info: TFillEllipseInfo;
     490begin
     491  if (rx = 0) or (ry = 0) or (x = EmptySingle) or (y = EmptySingle) then
     492    exit;
     493
     494  info := TFillEllipseInfo.Create(x, y, rx, ry);
     495  FillShapeAntialiasWithTexture(bmp, info, scan, False);
     496  info.Free;
     497end;
     498
     499procedure BorderEllipseAntialias(bmp: TBGRACustomBitmap; x, y, rx, ry, w: single;
    253500  c: TBGRAPixel; EraseMode: boolean);
    254501var
    255502  info: TFillBorderEllipseInfo;
    256503begin
    257   if (rx = 0) or (ry = 0) then
     504  if (rx = 0) or (ry = 0) or (w=0) or (x = EmptySingle) or (y = EmptySingle) then
    258505    exit;
    259506  info := TFillBorderEllipseInfo.Create(x, y, rx, ry, w);
    260   FillShapeAntialias(bmp, info, c, EraseMode);
    261   info.Free;
    262 end;
    263 
    264 { TFillShapeInfo }
    265 
    266 function TFillShapeInfo.GetBounds: TRect;
    267 begin
    268   Result := rect(0, 0, 0, 0);
    269 end;
    270 
    271 function TFillShapeInfo.NbMaxIntersection: integer;
    272 begin
    273   Result := 0;
    274 end;
    275 
    276 {$hints off}
    277 procedure TFillShapeInfo.ComputeIntersection(cury: single;
    278   var inter: ArrayOfSingle; var nbInter: integer);
    279 begin
    280 
    281 end;
    282 
    283 {$hints on}
    284 
    285 { TFillPolyInfo }
    286 
    287 constructor TFillPolyInfo.Create(points: array of TPointF);
    288 var
    289   i, j: integer;
    290   First, cur, nbP: integer;
    291 begin
    292   setlength(FPoints, length(points));
    293   nbP := 0;
    294   for i := 0 to high(points) do
    295   if (i=0) or (points[i].x<>points[i-1].X) or (points[i].y<>points[i-1].y) then
    296   begin
    297     FPoints[nbP] := points[i];
    298     inc(nbP);
    299   end;
    300   if (nbP>0) and (FPoints[nbP-1].X = FPoints[0].X) and (FPoints[nbP-1].Y = FPoints[0].Y) then dec(NbP);
    301   setlength(FPoints, nbP);
    302 
    303   //look for empty points, correct coordinate and successors
    304   setlength(FEmptyPt, length(FPoints));
    305   setlength(FNext, length(FPoints));
    306 
    307   cur   := -1;
    308   First := -1;
    309   for i := 0 to high(FPoints) do
    310     if not isEmptyPointF(FPoints[i]) then
    311     begin
    312       FEmptyPt[i]  := False;
    313       FPoints[i].x += 0.5;
    314       FPoints[i].y += 0.5;
    315       if cur <> -1 then
    316         FNext[cur] := i;
    317       if First = -1 then
    318         First := i;
    319       cur     := i;
    320     end
    321     else
    322     begin
    323       if (First <> -1) and (cur <> First) then
    324         FNext[cur] := First;
    325 
    326       FEmptyPt[i] := True;
    327       FNext[i] := -1;
    328       cur   := -1;
    329       First := -1;
     507  FillShapeAntialias(bmp, info, c, EraseMode, nil, False);
     508  info.Free;
     509end;
     510
     511procedure BorderEllipseAntialiasWithTexture(bmp: TBGRACustomBitmap; x, y, rx,
     512  ry, w: single; scan: IBGRAScanner);
     513var
     514  info: TFillBorderEllipseInfo;
     515begin
     516  if (rx = 0) or (ry = 0) or (w=0) or (x = EmptySingle) or (y = EmptySingle) then
     517    exit;
     518  info := TFillBorderEllipseInfo.Create(x, y, rx, ry, w);
     519  FillShapeAntialiasWithTexture(bmp, info, scan, False);
     520  info.Free;
     521end;
     522
     523{ TBGRAMultishapeFiller }
     524
     525procedure TBGRAMultishapeFiller.AddShape(AInfo: TFillShapeInfo; AInternalInfo: boolean; ATexture: IBGRAScanner; AInternalTexture: TObject; AColor: TBGRAPixel);
     526begin
     527  if length(shapes) = nbShapes then
     528    setlength(shapes, (length(shapes)+1)*2);
     529  with shapes[nbShapes] do
     530  begin
     531    info := AInfo;
     532    internalInfo:= AInternalInfo;
     533    texture := ATexture;
     534    internalTexture:= AInternalTexture;
     535    color := GammaExpansion(AColor);
     536  end;
     537  inc(nbShapes);
     538end;
     539
     540function TBGRAMultishapeFiller.CheckRectangleBorderBounds(var x1, y1, x2,
     541  y2: single; w: single): boolean;
     542var temp: single;
     543begin
     544  if x1 > x2 then
     545  begin
     546    temp := x1;
     547    x1 := x2;
     548    x2 := temp;
     549  end;
     550  if y1 > y2 then
     551  begin
     552    temp := y1;
     553    y1 := y2;
     554    y2 := temp;
     555  end;
     556  result := (x2-x1 > w) and (y2-y1 > w);
     557end;
     558
     559constructor TBGRAMultishapeFiller.Create;
     560begin
     561  nbShapes := 0;
     562  shapes := nil;
     563  PolygonOrder := poNone;
     564  Antialiasing := True;
     565  AliasingIncludeBottomRight := False;
     566end;
     567
     568destructor TBGRAMultishapeFiller.Destroy;
     569var
     570  i: Integer;
     571begin
     572  for i := 0 to nbShapes-1 do
     573  begin
     574    if shapes[i].internalInfo then shapes[i].info.free;
     575    shapes[i].texture := nil;
     576    if shapes[i].internalTexture <> nil then shapes[i].internalTexture.Free;
     577  end;
     578  shapes := nil;
     579  inherited Destroy;
     580end;
     581
     582procedure TBGRAMultishapeFiller.AddShape(AShape: TFillShapeInfo; AColor: TBGRAPixel);
     583begin
     584  AddShape(AShape,False,nil,nil,AColor);
     585end;
     586
     587procedure TBGRAMultishapeFiller.AddShape(AShape: TFillShapeInfo;
     588  ATexture: IBGRAScanner);
     589begin
     590  AddShape(AShape,False,ATexture,nil,BGRAPixelTransparent);
     591end;
     592
     593procedure TBGRAMultishapeFiller.AddPolygon(const points: array of TPointF;
     594  AColor: TBGRAPixel);
     595begin
     596  if length(points) <= 2 then exit;
     597  AddShape(TFillPolyInfo.Create(points),True,nil,nil,AColor);
     598end;
     599
     600procedure TBGRAMultishapeFiller.AddPolygon(const points: array of TPointF;
     601  ATexture: IBGRAScanner);
     602begin
     603  if length(points) <= 2 then exit;
     604  AddShape(TFillPolyInfo.Create(points),True,ATexture,nil,BGRAPixelTransparent);
     605end;
     606
     607procedure TBGRAMultishapeFiller.AddTriangleLinearColor(pt1, pt2, pt3: TPointF; c1, c2,
     608  c3: TBGRAPixel);
     609var
     610  grad: TBGRAGradientTriangleScanner;
     611begin
     612  grad := TBGRAGradientTriangleScanner.Create(pt1,pt2,pt3, c1,c2,c3);
     613  AddShape(TFillPolyInfo.Create([pt1,pt2,pt3]),True,grad,grad,BGRAPixelTransparent);
     614end;
     615
     616procedure TBGRAMultishapeFiller.AddTriangleLinearMapping(pt1, pt2,
     617  pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF);
     618var
     619  mapping: TBGRATriangleLinearMapping;
     620begin
     621  mapping := TBGRATriangleLinearMapping.Create(texture, pt1,pt2,pt3, tex1, tex2, tex3);
     622  AddShape(TFillPolyInfo.Create([pt1,pt2,pt3]),True,mapping,mapping,BGRAPixelTransparent);
     623end;
     624
     625procedure TBGRAMultishapeFiller.AddQuadLinearColor(pt1, pt2, pt3, pt4: TPointF;
     626  c1, c2, c3, c4: TBGRAPixel);
     627var
     628  center: TPointF;
     629  centerColor: TBGRAPixel;
     630begin
     631  center := (pt1+pt2+pt3+pt4)*(1/4);
     632  centerColor := GammaCompression( MergeBGRA(MergeBGRA(GammaExpansion(c1),GammaExpansion(c2)),
     633                    MergeBGRA(GammaExpansion(c3),GammaExpansion(c4))) );
     634  AddTriangleLinearColor(pt1,pt2,center, c1,c2,centerColor);
     635  AddTriangleLinearColor(pt2,pt3,center, c2,c3,centerColor);
     636  AddTriangleLinearColor(pt3,pt4,center, c3,c4,centerColor);
     637  AddTriangleLinearColor(pt4,pt1,center, c4,c1,centerColor);
     638end;
     639
     640procedure TBGRAMultishapeFiller.AddQuadLinearMapping(pt1, pt2, pt3,
     641  pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF);
     642var
     643  center: TPointF;
     644  centerTex: TPointF;
     645begin
     646  center := (pt1+pt2+pt3+pt4)*(1/4);
     647  centerTex := (tex1+tex2+tex3+tex4)*(1/4);
     648  AddTriangleLinearMapping(pt1,pt2,center, texture,tex1,tex2,centerTex);
     649  AddTriangleLinearMapping(pt2,pt3,center, texture,tex2,tex3,centerTex);
     650  AddTriangleLinearMapping(pt3,pt4,center, texture,tex3,tex4,centerTex);
     651  AddTriangleLinearMapping(pt4,pt1,center, texture,tex4,tex1,centerTex);
     652end;
     653
     654procedure TBGRAMultishapeFiller.AddQuadPerspectiveMapping(pt1, pt2, pt3,
     655  pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF);
     656var persp: TBGRAPerspectiveScannerTransform;
     657begin
     658  persp := TBGRAPerspectiveScannerTransform.Create(texture,[tex1,tex2,tex3,tex4],[pt1,pt2,pt3,pt4]);
     659  AddShape(TFillPolyInfo.Create([pt1,pt2,pt3,pt4]),True,persp,persp,BGRAPixelTransparent);
     660end;
     661
     662procedure TBGRAMultishapeFiller.AddEllipse(x, y, rx, ry: single; AColor: TBGRAPixel
     663  );
     664begin
     665  AddShape(TFillEllipseInfo.Create(x,y,rx,ry),True,nil,nil,AColor);
     666end;
     667
     668procedure TBGRAMultishapeFiller.AddEllipse(x, y, rx, ry: single;
     669  ATexture: IBGRAScanner);
     670begin
     671  AddShape(TFillEllipseInfo.Create(x,y,rx,ry),True,ATexture,nil,BGRAPixelTransparent);
     672end;
     673
     674procedure TBGRAMultishapeFiller.AddEllipseBorder(x, y, rx, ry, w: single;
     675  AColor: TBGRAPixel);
     676begin
     677  AddShape(TFillBorderEllipseInfo.Create(x,y,rx,ry,w),True,nil,nil,AColor);
     678end;
     679
     680procedure TBGRAMultishapeFiller.AddEllipseBorder(x, y, rx, ry, w: single;
     681  ATexture: IBGRAScanner);
     682begin
     683  AddShape(TFillBorderEllipseInfo.Create(x,y,rx,ry,w),True,ATexture,nil,BGRAPixelTransparent);
     684end;
     685
     686procedure TBGRAMultishapeFiller.AddRoundRectangle(x1, y1, x2, y2, rx, ry: single;
     687  AColor: TBGRAPixel; options: TRoundRectangleOptions);
     688begin
     689  AddShape(TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry,options),True,nil,nil,AColor);
     690end;
     691
     692procedure TBGRAMultishapeFiller.AddRoundRectangle(x1, y1, x2, y2, rx, ry: single;
     693  ATexture: IBGRAScanner; options: TRoundRectangleOptions);
     694begin
     695  AddShape(TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry,options),True,
     696     ATexture,nil,BGRAPixelTransparent);
     697end;
     698
     699procedure TBGRAMultishapeFiller.AddRoundRectangleBorder(x1, y1, x2, y2, rx,
     700  ry, w: single; AColor: TBGRAPixel; options: TRoundRectangleOptions);
     701begin
     702  AddShape(TFillBorderRoundRectInfo.Create(x1, y1, x2, y2, rx, ry,w,options),True,
     703    nil,nil,AColor);
     704end;
     705
     706procedure TBGRAMultishapeFiller.AddRoundRectangleBorder(x1, y1, x2, y2, rx, ry,
     707  w: single; ATexture: IBGRAScanner; options: TRoundRectangleOptions);
     708begin
     709  AddShape(TFillBorderRoundRectInfo.Create(x1, y1, x2, y2, rx, ry,w,options),True,
     710    ATexture,nil,BGRAPixelTransparent);
     711end;
     712
     713procedure TBGRAMultishapeFiller.AddRectangle(x1, y1, x2, y2: single;
     714  AColor: TBGRAPixel);
     715begin
     716  AddPolygon([PointF(x1,y1),PointF(x2,y1),PointF(x2,y2),PointF(x1,y2)],AColor);
     717end;
     718
     719procedure TBGRAMultishapeFiller.AddRectangle(x1, y1, x2, y2: single;
     720  ATexture: IBGRAScanner);
     721begin
     722  AddPolygon([PointF(x1,y1),PointF(x2,y1),PointF(x2,y2),PointF(x1,y2)],ATexture);
     723end;
     724
     725procedure TBGRAMultishapeFiller.AddRectangleBorder(x1, y1, x2, y2,
     726  w: single; AColor: TBGRAPixel);
     727var hw : single;
     728begin
     729  hw := w/2;
     730  if not CheckRectangleBorderBounds(x1,y1,x2,y2,w) then
     731    AddRectangle(x1-hw,y1-hw,x2+hw,y2+hw,AColor) else
     732    AddPolygon([PointF(x1-hw,y1-hw),PointF(x2+hw,y1-hw),PointF(x2+hw,y2+hw),PointF(x1-hw,y2+hw),EmptyPointF,
     733                PointF(x1+hw,y2-hw),PointF(x2-hw,y2-hw),PointF(x2-hw,y1+hw),PointF(x1+hw,y1+hw)],AColor);
     734end;
     735
     736procedure TBGRAMultishapeFiller.AddRectangleBorder(x1, y1, x2, y2,
     737  w: single; ATexture: IBGRAScanner);
     738var hw : single;
     739begin
     740  hw := w/2;
     741  if not CheckRectangleBorderBounds(x1,y1,x2,y2,w) then
     742    AddRectangle(x1-hw,y1-hw,x2+hw,y2+hw,ATexture) else
     743    AddPolygon([PointF(x1-hw,y1-hw),PointF(x2+hw,y1-hw),PointF(x2+hw,y2+hw),PointF(x1-hw,y2+hw),EmptyPointF,
     744                PointF(x1+hw,y2-hw),PointF(x2-hw,y2-hw),PointF(x2-hw,y1+hw),PointF(x1+hw,y1+hw)],ATexture);
     745end;
     746
     747procedure TBGRAMultishapeFiller.Draw(dest: TBGRACustomBitmap);
     748var
     749  shapeRow: array of record
     750    density: PDensity;
     751    densMinx,densMaxx: integer;
     752    nbInter: integer;
     753    inter: array of TIntersectionInfo;
     754  end;
     755  shapeRowsList: array of integer;
     756  NbShapeRows: integer;
     757  miny, maxy, minx, maxx,
     758  rowminx, rowmaxx: integer;
     759
     760  procedure SubstractScanlines(src,dest: integer);
     761  var i: integer;
     762
     763    procedure SubstractSegment(srcseg: integer);
     764    var x1,x2, x3,x4: single;
     765      j: integer;
     766
     767      procedure AddSegment(xa,xb: single);
     768      var nb: PInteger;
     769          prevNb,k: integer;
     770      begin
     771        nb := @shapeRow[dest].nbinter;
     772        if length(shapeRow[dest].inter) < nb^+2 then
     773        begin
     774          prevNb := length(shapeRow[dest].inter);
     775          setlength(shapeRow[dest].inter, nb^*2+2);
     776          for k := prevNb to high(shapeRow[dest].inter) do
     777            shapeRow[dest].inter[k] := shapes[dest].info.CreateIntersectionInfo;
     778        end;
     779        shapeRow[dest].inter[nb^].interX := xa;
     780        shapeRow[dest].inter[nb^+1].interX := xb;
     781        inc(nb^,2);
     782      end;
     783
     784    begin
     785      x1 := shapeRow[src].inter[(srcseg-1)*2].interX;
     786      x2 := shapeRow[src].inter[srcseg*2-1].interX;
     787      for j := shapeRow[dest].nbInter div 2 downto 1 do
     788      begin
     789        x3 := shapeRow[dest].inter[(j-1)*2].interX;
     790        x4 := shapeRow[dest].inter[j*2-1].interX;
     791        if (x2 <= x3) or (x1 >= x4) then continue; //not overlapping
     792        if (x1 <= x3) and (x2 >= x4) then
     793          shapeRow[dest].inter[j*2-1].interX := x3 //empty
     794        else
     795        if (x1 <= x3) and (x2 < x4) then
     796          shapeRow[dest].inter[(j-1)*2].interX := x2 //remove left part
     797        else
     798        if (x1 > x3) and (x2 >= x4) then
     799          shapeRow[dest].inter[j*2-1].interX := x1 else //remove right part
     800        begin
     801          //[x1,x2] is inside [x3,x4]
     802          shapeRow[dest].inter[j*2-1].interX := x1; //left part
     803          AddSegment(x2,x4);
     804        end;
     805      end;
    330806    end;
    331   if (First <> -1) and (cur <> First) then
    332     FNext[cur] := First;
    333 
    334   setlength(FPrev, length(FPoints));
    335   for i := 0 to high(FPrev) do
    336     FPrev[i] := -1;
    337   for i := 0 to high(FNext) do
    338     if FNext[i] <> -1 then
    339       FPrev[FNext[i]] := i;
    340 
    341   setlength(FSlopes, length(FPoints));
    342   setlength(FChangedir, length(FPoints));
    343 
    344   //compute slopes
    345   for i := 0 to high(FPoints) do
    346     if not FEmptyPt[i] then
    347     begin
    348       j := FNext[i];
    349 
    350       if FPoints[i].y <> FPoints[j].y then
    351         FSlopes[i] := (FPoints[j].x - FPoints[i].x) / (FPoints[j].y - FPoints[i].y)
     807
     808  begin
     809    for i := 1 to shapeRow[src].nbInter div 2 do
     810      SubstractSegment(i);
     811  end;
     812
     813var
     814    AliasingOfs: TPointF;
     815
     816  procedure AddOneLineDensity(cury: single);
     817  var
     818    i,k: integer;
     819    ix1,ix2: integer;
     820    x1,x2: single;
     821  begin
     822    for k := 0 to NbShapeRows-1 do
     823      with shapeRow[shapeRowsList[k]], shapes[shapeRowsList[k]] do
     824      begin
     825        //find intersections
     826        info.ComputeAndSort(cury, inter, nbInter, FillMode=fmWinding);
     827        nbInter := nbInter and not 1; //even
     828      end;
     829
     830      case PolygonOrder of
     831        poLastOnTop: begin
     832          for k := 1 to NbShapeRows-1 do
     833            if shapeRow[shapeRowsList[k]].nbInter > 0 then
     834              for i := 0 to k-1 do
     835                SubstractScanlines(shapeRowsList[k],shapeRowsList[i]);
     836        end;
     837        poFirstOnTop: begin
     838          for k := 0 to NbShapeRows-2 do
     839            if shapeRow[shapeRowsList[k]].nbInter > 0 then
     840              for i := k+1 to NbShapeRows-1 do
     841                SubstractScanlines(shapeRowsList[k],shapeRowsList[i]);
     842        end;
     843      end;
     844
     845      for k := 0 to NbShapeRows-1 do
     846      with shapeRow[shapeRowsList[k]] do
     847      begin
     848        //fill density
     849        if not Antialiasing then
     850        begin
     851          for i := 0 to nbinter div 2 - 1 do
     852          begin
     853            x1 := inter[i + i].interX;
     854            x2 := inter[i + i + 1].interX;
     855            ComputeAliasedRowBounds(x1+AliasingOfs.X,x2+AliasingOfs.X,minx,maxx,ix1,ix2);
     856
     857            if ix1 < densMinx then densMinx := ix1;
     858            if ix2 > densMaxx then densMaxx := ix2;
     859
     860            FillWord(density[ix1-minx],ix2-ix1+1,256);
     861          end;
     862        end else
     863          {$I filldensity256.inc}
     864      end;
     865
     866      for k := 0 to NbShapeRows-1 do
     867      with shapeRow[shapeRowsList[k]] do
     868      begin
     869        if densMinX < rowminx then rowminx := densMinX;
     870        if densMaxX > rowmaxx then rowmaxx := densMaxX;
     871      end;
     872  end;
     873
     874type
     875    TCardinalSum = record
     876          sumR,sumG,sumB,sumA: cardinal;
     877        end;
     878
     879var
     880  MultiEmpty: boolean;
     881  bounds: TRect;
     882
     883  xb, yb, yc, j,k: integer;
     884  pdest:    PBGRAPixel;
     885
     886  curSum,nextSum: ^TCardinalSum;
     887  sums: array of TCardinalSum;
     888
     889  pdens: PDensity;
     890  w: cardinal;
     891  ec: TExpandedPixel;
     892  count: integer;
     893  ScanNextFunc: function: TBGRAPixel of object;
     894
     895begin
     896  if nbShapes = 0 then exit;
     897  if nbShapes = 1 then
     898  begin
     899    if Antialiasing then
     900      FillShapeAntialias(dest,shapes[0].info,GammaCompression(shapes[0].color),False,shapes[0].texture,FillMode = fmWinding) else
     901      FillShapeAliased(dest,shapes[0].info,GammaCompression(shapes[0].color),False,shapes[0].texture,FillMode = fmWinding, dmDrawWithTransparency,
     902        AliasingIncludeBottomRight);
     903    exit;
     904  end;
     905  bounds := Rect(0,0,0,0);
     906  MultiEmpty := True;
     907  for k := 0 to nbShapes-1 do
     908  begin
     909    If shapes[k].info.ComputeMinMax(minx,miny,maxx,maxy,dest) then
     910    begin
     911      shapes[k].bounds := rect(minx,miny,maxx+1,maxy+1);
     912      if MultiEmpty then
     913      begin
     914        MultiEmpty := False;
     915        bounds := shapes[k].bounds;
     916      end else
     917      begin
     918        if minx < bounds.left then bounds.left := minx;
     919        if miny < bounds.top then bounds.top := miny;
     920        if maxx >= bounds.right then bounds.right := maxx+1;
     921        if maxy >= bounds.bottom then bounds.bottom := maxy+1;
     922      end;
     923    end else
     924      shapes[k].bounds := rect(0,0,0,0);
     925  end;
     926  if MultiEmpty then exit;
     927  minx := bounds.left;
     928  miny := bounds.top;
     929  maxx := bounds.right-1;
     930  maxy := bounds.bottom-1;
     931
     932  setlength(shapeRow, nbShapes);
     933  for k := 0 to nbShapes-1 do
     934  begin
     935    shapeRow[k].inter := shapes[k].info.CreateIntersectionArray;
     936    getmem(shapeRow[k].density, (maxx - minx + 2)*sizeof(TDensity)); //more for safety
     937  end;
     938
     939  if AliasingIncludeBottomRight then
     940    AliasingOfs := PointF(0,0) else
     941    AliasingOfs := PointF(-0.0001,-0.0001);
     942
     943  setlength(sums,maxx-minx+2); //more for safety
     944  setlength(shapeRowsList, nbShapes);
     945
     946  //vertical scan
     947  for yb := miny to maxy do
     948  begin
     949    rowminx := maxx+1;
     950    rowmaxx := minx-1;
     951
     952    //init shape rows
     953    NbShapeRows := 0;
     954    for k := 0 to nbShapes-1 do
     955    if (yb >= shapes[k].bounds.top) and (yb < shapes[k].bounds.Bottom) then
     956    begin
     957      shapeRowsList[NbShapeRows] := k;
     958      inc(NbShapeRows);
     959
     960      fillchar(shapeRow[k].density^,(maxx-minx+1)*sizeof(TDensity),0);
     961      shapeRow[k].densMinx := maxx+1;
     962      shapeRow[k].densMaxx := minx-1;
     963    end;
     964
     965    If Antialiasing then
     966    begin
     967      //precision scan
     968      for yc := 0 to AntialiasPrecision - 1 do
     969        AddOneLineDensity( yb + (yc * 2 + 1) / (AntialiasPrecision * 2) );
     970    end else
     971    begin
     972      AddOneLineDensity( yb + 0.5 - AliasingOfs.Y );
     973    end;
     974
     975    rowminx := minx;
     976    rowmaxx := maxx;
     977    if rowminx <= rowmaxx then
     978    begin
     979      if rowminx < minx then rowminx := minx;
     980      if rowmaxx > maxx then rowmaxx := maxx;
     981
     982      FillChar(sums[rowminx-minx],(rowmaxx-rowminx+1)*sizeof(sums[0]),0);
     983
     984      if Antialiasing then
     985        {$define PARAM_ANTIALIASINGFACTOR}
     986        {$i multishapeline.inc}
    352987      else
    353         FSlopes[i] := EmptySingle;
    354 
    355       FChangedir[i] := ((FPoints[i].y - FPoints[j].y > 0) and
    356         (FPoints[FPrev[i]].y - FPoints[i].y < 0)) or
    357         ((FPoints[i].y - FPoints[j].y < 0) and (FPoints[FPrev[i]].y - FPoints[i].y > 0));
    358     end
    359     else
    360     begin
    361       FSlopes[i]    := EmptySingle;
    362       FChangedir[i] := False;
     988        {$i multishapeline.inc};
     989
     990      pdest := dest.ScanLine[yb] + rowminx;
     991      xb := rowminx;
     992      nextSum := @sums[xb-minx];
     993      while xb <= rowmaxx do
     994      begin
     995        curSum := nextSum;
     996        inc(nextSum);
     997        with curSum^ do
     998        begin
     999          if sumA <> 0 then
     1000          begin
     1001            ec.red := (sumR+sumA shr 1) div sumA;
     1002            ec.green := (sumG+sumA shr 1) div sumA;
     1003            ec.blue := (sumB+sumA shr 1) div sumA;
     1004            if sumA > 255 then sumA := 255;
     1005            ec.alpha := sumA shl 8 + sumA;
     1006            count := 1;
     1007            while (xb < rowmaxx) and (nextSum^.sumA = sumA) and (nextSum^.sumB = sumB)
     1008              and (nextSum^.sumG = sumG) and (nextSum^.sumR = sumR) do
     1009            begin
     1010              inc(xb);
     1011              inc(nextSum);
     1012              inc(count);
     1013            end;
     1014            if count = 1 then
     1015              DrawExpandedPixelInlineWithAlphaCheck(pdest,ec) else
     1016               DrawExpandedPixelsInline(pdest, ec, count );
     1017            inc(pdest,count-1);
     1018          end;
     1019        end;
     1020        inc(xb);
     1021        inc(pdest);
     1022      end;
    3631023    end;
    3641024
    365 end;
    366 
    367 function TFillPolyInfo.GetBounds: TRect;
    368 var
    369   minx, miny, maxx, maxy, i: integer;
    370 begin
    371   miny := floor(FPoints[0].y);
    372   maxy := ceil(FPoints[0].y);
    373   minx := floor(FPoints[0].x);
    374   maxx := ceil(FPoints[0].x);
    375   for i := 1 to high(FPoints) do
    376     if not FEmptyPt[i] then
    377     begin
    378       if floor(FPoints[i].y) < miny then
    379         miny := floor(FPoints[i].y)
    380       else
    381       if ceil(FPoints[i].y) > maxy then
    382         maxy := ceil(FPoints[i].y);
    383 
    384       if floor(FPoints[i].x) < minx then
    385         minx := floor(FPoints[i].x)
    386       else
    387       if ceil(FPoints[i].x) > maxx then
    388         maxx := ceil(FPoints[i].x);
     1025  end;
     1026
     1027  for k := 0 to nbShapes-1 do
     1028  begin
     1029    freemem(shapeRow[k].density);
     1030    shapes[k].info.FreeIntersectionArray(shapeRow[k].inter);
     1031  end;
     1032
     1033  dest.InvalidateBitmap;
     1034end;
     1035
     1036procedure FillRoundRectangleAntialias(bmp: TBGRACustomBitmap; x1, y1, x2, y2,
     1037  rx, ry: single; options: TRoundRectangleOptions; c: TBGRAPixel; EraseMode: boolean);
     1038var
     1039  info: TFillRoundRectangleInfo;
     1040begin
     1041  if (x1 = x2) or (y1 = y2) then exit;
     1042  info := TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry, options);
     1043  FillShapeAntialias(bmp, info, c, EraseMode,nil, False);
     1044  info.Free;
     1045end;
     1046
     1047procedure FillRoundRectangleAntialiasWithTexture(bmp: TBGRACustomBitmap; x1,
     1048  y1, x2, y2, rx, ry: single; options: TRoundRectangleOptions;
     1049  scan: IBGRAScanner);
     1050var
     1051  info: TFillRoundRectangleInfo;
     1052begin
     1053  if (x1 = x2) or (y1 = y2) then exit;
     1054  info := TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry, options);
     1055  FillShapeAntialiasWithTexture(bmp, info, scan, False);
     1056  info.Free;
     1057end;
     1058
     1059procedure BorderRoundRectangleAntialias(bmp: TBGRACustomBitmap; x1, y1, x2,
     1060  y2, rx, ry, w: single; options: TRoundRectangleOptions; c: TBGRAPixel;
     1061  EraseMode: boolean);
     1062var
     1063  info: TFillBorderRoundRectInfo;
     1064begin
     1065  if (rx = 0) or (ry = 0) or (w=0) then exit;
     1066  info := TFillBorderRoundRectInfo.Create(x1, y1, x2,y2, rx, ry, w, options);
     1067  FillShapeAntialias(bmp, info, c, EraseMode, nil, False);
     1068  info.Free;
     1069end;
     1070
     1071procedure BorderRoundRectangleAntialiasWithTexture(bmp: TBGRACustomBitmap; x1,
     1072  y1, x2, y2, rx, ry, w: single; options: TRoundRectangleOptions;
     1073  scan: IBGRAScanner);
     1074var
     1075  info: TFillBorderRoundRectInfo;
     1076begin
     1077  if (rx = 0) or (ry = 0) or (w=0) then exit;
     1078  info := TFillBorderRoundRectInfo.Create(x1, y1, x2,y2, rx, ry, w, options);
     1079  FillShapeAntialiasWithTexture(bmp, info, scan, False);
     1080  info.Free;
     1081end;
     1082
     1083procedure BorderAndFillRoundRectangleAntialias(bmp: TBGRACustomBitmap; x1, y1,
     1084  x2, y2, rx, ry, w: single; options: TRoundRectangleOptions; bordercolor,
     1085  fillcolor: TBGRAPixel; bordertexture,filltexture: IBGRAScanner; EraseMode: boolean);
     1086var
     1087  info: TFillBorderRoundRectInfo;
     1088  multi: TBGRAMultishapeFiller;
     1089begin
     1090  if (rx = 0) or (ry = 0) then exit;
     1091  info := TFillBorderRoundRectInfo.Create(x1, y1, x2,y2, rx, ry, w, options);
     1092  if not EraseMode then
     1093  begin
     1094    multi := TBGRAMultishapeFiller.Create;
     1095    if filltexture <> nil then
     1096      multi.AddShape(info.innerBorder, filltexture) else
     1097      multi.AddShape(info.innerBorder, fillcolor);
     1098    if w<>0 then
     1099    begin
     1100      if bordertexture <> nil then
     1101        multi.AddShape(info, bordertexture) else
     1102        multi.AddShape(info, bordercolor);
    3891103    end;
    390   Result := rect(minx, miny, maxx + 1, maxy + 1);
    391 end;
    392 
    393 function TFillPolyInfo.NbMaxIntersection: integer;
    394 begin
    395   Result := length(FPoints);
    396 end;
    397 
    398 procedure TFillPolyInfo.ComputeIntersection(cury: single;
    399   var inter: ArrayOfSingle; var nbInter: integer);
    400 var
    401   i, j: integer;
    402 begin
    403   for i := 0 to high(FPoints) do
    404     if not FEmptyPt[i] then
    405     begin
    406       if cury = FPoints[i].y then
    407       begin
    408         if not FChangedir[i] then
    409         begin
    410           inter[nbinter] := FPoints[i].x;
    411           Inc(nbinter);
    412         end;
    413       end
    414       else
    415       if (FSlopes[i] <> EmptySingle) then
    416       begin
    417         j := FNext[i];
    418         if (((cury >= FPoints[i].y) and (cury < FPoints[j].y)) or
    419           ((cury > FPoints[j].y) and (cury <= FPoints[i].y))) then
    420         begin
    421           inter[nbinter] := (cury - FPoints[i].y) * FSlopes[i] + FPoints[i].x;
    422           Inc(nbinter);
    423         end;
    424       end;
    425     end;
    426 end;
    427 
    428 { TFillEllipseInfo }
    429 
    430 constructor TFillEllipseInfo.Create(x, y, rx, ry: single);
    431 begin
    432   FX  := x + 0.5;
    433   FY  := y + 0.5;
    434   FRX := abs(rx);
    435   FRY := abs(ry);
    436 end;
    437 
    438 function TFillEllipseInfo.GetBounds: TRect;
    439 begin
    440   Result := rect(floor(fx - frx), floor(fy - fry), ceil(fx + frx), ceil(fy + fry));
    441 end;
    442 
    443 function TFillEllipseInfo.NbMaxIntersection: integer;
    444 begin
    445   Result := 2;
    446 end;
    447 
    448 procedure TFillEllipseInfo.ComputeIntersection(cury: single;
    449   var inter: ArrayOfSingle; var nbInter: integer);
    450 var
    451   d: single;
    452 begin
    453   d := sqr((cury - FY) / FRY);
    454   if d < 1 then
    455   begin
    456     d := sqrt(1 - d) * FRX;
    457     inter[nbinter] := FX - d;
    458     Inc(nbinter);
    459     inter[nbinter] := FX + d;
    460     Inc(nbinter);
    461   end;
    462 end;
    463 
    464 { TFillBorderEllipseInfo }
    465 
    466 constructor TFillBorderEllipseInfo.Create(x, y, rx, ry, w: single);
    467 begin
    468   if rx < 0 then
    469     rx := -rx;
    470   if ry < 0 then
    471     ry := -ry;
    472   outerBorder := TFillEllipseInfo.Create(x, y, rx + w / 2, ry + w / 2);
    473   if (rx > w / 2) and (ry > w / 2) then
    474     innerBorder := TFillEllipseInfo.Create(x, y, rx - w / 2, ry - w / 2)
    475   else
    476     innerBorder := nil;
    477 end;
    478 
    479 function TFillBorderEllipseInfo.GetBounds: TRect;
    480 begin
    481   Result := outerBorder.GetBounds;
    482 end;
    483 
    484 function TFillBorderEllipseInfo.NbMaxIntersection: integer;
    485 begin
    486   Result := 4;
    487 end;
    488 
    489 procedure TFillBorderEllipseInfo.ComputeIntersection(cury: single;
    490   var inter: ArrayOfSingle; var nbInter: integer);
    491 begin
    492   outerBorder.ComputeIntersection(cury, inter, nbInter);
    493   if innerBorder <> nil then
    494     innerBorder.ComputeIntersection(cury, inter, nbInter);
    495 end;
    496 
    497 destructor TFillBorderEllipseInfo.Destroy;
    498 begin
    499   outerBorder.Free;
    500   if innerBorder <> nil then
    501     innerBorder.Free;
    502   inherited Destroy;
    503 end;
     1104    multi.Draw(bmp);
     1105    multi.Free;
     1106  end else
     1107  begin
     1108    FillShapeAntialias(bmp, info.innerBorder, fillcolor, EraseMode, nil, False);
     1109    FillShapeAntialias(bmp, info, bordercolor, EraseMode, nil, False);
     1110  end;
     1111  info.Free;
     1112end;
     1113
     1114initialization
     1115
     1116  Randomize;
    5041117
    5051118end.
    506 
Note: See TracChangeset for help on using the changeset viewer.