Changeset 317


Ignore:
Timestamp:
Feb 1, 2012, 3:02:33 PM (13 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
Files:
25 added
21 edited

Legend:

Unmodified
Added
Removed
  • GraphicTest/BGRABitmap

    • Property svn:ignore set to
      lib
  • GraphicTest/BGRABitmap/bgraanimatedgif.pas

    r210 r317  
    10051005            begin
    10061006              PChangePix^ := PBackground^;
    1007               DrawPixelInline(PBGRAPixel(PChangePix), PBGRAPixel(@newpix)^);
     1007              DrawPixelInlineNoAlphaCheck(PBGRAPixel(PChangePix), PBGRAPixel(@newpix)^);
    10081008            end
    10091009            else if PChangePix^ and AlphaMask <> 0 then
     
    10451045              begin
    10461046                PChangePix^ := PBackground^;
    1047                 DrawPixelInline(PBGRAPixel(PChangePix), PBGRAPixel(@newpix)^);
     1047                DrawPixelInlineNoAlphaCheck(PBGRAPixel(PChangePix), PBGRAPixel(@newpix)^);
    10481048              end
    10491049              else if PChangePix^ and AlphaMask <> 0 then
     
    11761176        begin
    11771177          PChangePix^ := MemPixEraseColor;
    1178           DrawPixelInline(PBGRAPixel(PChangePix), PBGRAPixel(@newpix)^);
     1178          DrawPixelInlineNoAlphaCheck(PBGRAPixel(PChangePix), PBGRAPixel(@newpix)^);
    11791179        end
    11801180        else if PChangePix^ and AlphaMask <> 0 then
  • GraphicTest/BGRABitmap/bgrabitmap.pas

    r210 r317  
    4141interface
    4242
     43{ Compiler directives are used to include the best version according
     44  to the platform }
     45
    4346uses
    4447  Classes, SysUtils,
     
    8184{$ENDIF}
    8285
    83 
     86// draw a bitmap from pure data
    8487procedure BGRABitmapDraw(ACanvas: TCanvas; Rect: TRect; AData: Pointer;
    8588  VerticalFlip: boolean; AWidth, AHeight: integer; Opaque: boolean);
    86 procedure BGRAReplace(var Source: TBGRABitmap; Temp: TObject);
     89 
     90{ Replace the content of the variable Destination with the variable
     91  Temp and frees previous object contained in Destination.
     92 
     93  This function is useful as a shortcut for :
     94 
     95  var
     96    temp: TBGRABitmap;
     97  begin
     98    ...
     99    temp := someBmp.Filter... as TBGRABitmap;
     100    someBmp.Free;
     101    someBmp := temp;
     102  end;
     103 
     104  which becomes :
     105 
     106  begin
     107    ...
     108    BGRAReplace(temp, someBmp.Filter... );
     109  end;
     110}
     111procedure BGRAReplace(var Destination: TBGRABitmap; Temp: TObject);
    87112
    88113implementation
    89114
    90 uses GraphType, BGRAAnimatedGif;
     115uses GraphType, BGRABitmapTypes;
    91116
    92117var
    93   bmp: TBGRABitmap;
     118  tempBmp: TBGRABitmap;
    94119
    95120procedure BGRABitmapDraw(ACanvas: TCanvas; Rect: TRect; AData: Pointer;
     
    98123  LineOrder: TRawImageLineOrder;
    99124begin
     125  if tempBmp = nil then
     126    tempBmp := TBGRABitmap.Create;
    100127  if VerticalFlip then
    101128    LineOrder := riloBottomToTop
     
    103130    LineOrder := riloTopToBottom;
    104131  if Opaque then
    105     bmp.DataDrawOpaque(ACanvas, Rect, AData, LineOrder, AWidth, AHeight)
     132    tempBmp.DataDrawOpaque(ACanvas, Rect, AData, LineOrder, AWidth, AHeight)
    106133  else
    107     bmp.DataDrawTransparent(ACanvas, Rect, AData, LineOrder, AWidth, AHeight);
     134    tempBmp.DataDrawTransparent(ACanvas, Rect, AData, LineOrder, AWidth, AHeight);
    108135end;
    109136
    110 procedure BGRAReplace(var Source: TBGRABitmap; Temp: TObject);
     137procedure BGRAReplace(var Destination: TBGRABitmap; Temp: TObject);
    111138begin
    112   Source.Free;
    113   Source := Temp as TBGRABitmap;
     139  Destination.Free;
     140  Destination := Temp as TBGRABitmap;
    114141end;
    115142
    116143initialization
    117144
    118   bmp := TBGRABitmap.Create(0, 0);
     145  //this variable is assigned to access appropriate functions
     146  //depending on the platform
     147  BGRABitmapFactory := TBGRABitmap;
    119148
    120149finalization
    121150
    122   bmp.Free;
     151  tempBmp.Free;
    123152
    124153end.
  • GraphicTest/BGRABitmap/bgrabitmaptypes.pas

    r210 r317  
    3030
    3131uses
    32   Classes, Graphics;
     32  Classes, Types, Graphics, FPImage, FPImgCanv, GraphType;
    3333
    3434type
     35  //pointer for direct pixel access
    3536  PBGRAPixel = ^TBGRAPixel;
    3637
     38  //pixel structure
    3739  TBGRAPixel = packed record
    3840    blue, green, red, alpha: byte;
    3941  end;
    4042
     43  //gamma expanded values
    4144  TExpandedPixel = packed record
    4245    red, green, blue, alpha: word;
    4346  end;
    4447
     48  //pixel color defined in HSL colorspace
    4549  THSLAPixel = packed record
    4650    hue, saturation, lightness, alpha: word;
    4751  end;
    4852
    49   TDrawMode = (dmSet, dmSetExceptTransparent, dmLinearBlend, dmDrawWithTransparency);
    50   TFloodfillMode = (fmSet, fmDrawWithTransparency, fmProgressive);
    51   TResampleMode = (rmSimpleStretch, rmFineResample);
     53  //general purpose color variable with floating point values
     54  TColorF = array[1..4] of single;
     55 
     56  { These types are used as parameters }
     57
     58  TDrawMode = (dmSet,                   //replace pixels
     59               dmSetExceptTransparent,  //draw pixels with alpha=255
     60               dmLinearBlend,           //blend without gamma correction
     61               dmDrawWithTransparency,  //normal blending with gamma correction
     62               dmXor);                  //bitwise xor for all channels
     63  TChannel = (cRed, cGreen, cBlue, cAlpha);
     64  TChannels = set of TChannel;
     65               
     66  //floodfill option
     67  TFloodfillMode = (fmSet,                   //set pixels
     68                    fmDrawWithTransparency,  //draw fill color with transparency
     69                    fmProgressive);          //draw fill color with transparency according to similarity with start color
     70
     71  TResampleMode = (rmSimpleStretch,   //low quality resample
     72                   rmFineResample);   //use resample filters
     73  TResampleFilter = (rfLinear,        //linear interpolation
     74                     rfHalfCosine,    //mix of rfLinear and rfCosine
     75                     rfCosine,        //cosine-like interpolation
     76                     rfBicubic,       //simple bi-cubic filter (blur)
     77                     rfMitchell,      //downsizing interpolation
     78                     rfSpline,        //upsizing interpolation
     79                     rfBestQuality);  //mix of rfMitchell and rfSpline
     80
     81  TBGRAFontQuality = (fqSystem, fqSystemClearType, fqFineAntialiasing, fqFineClearTypeRGB, fqFineClearTypeBGR);
     82
    5283  TMedianOption = (moNone, moLowSmooth, moMediumSmooth, moHighSmooth);
     84  TRadialBlurType = (rbNormal, rbDisk, rbCorona, rbPrecise, rbFast);
     85  TSplineStyle = (ssInside, ssInsideWithEnds, ssCrossing, ssCrossingWithEnds, ssOutside, ssRoundOutside, ssVertexToSide);
     86 
     87  //Advanced blending modes
     88  //see : http://www.brighthub.com/multimedia/photography/articles/18301.aspx
     89  //and : http://www.pegtop.net/delphi/articles/blendmodes/ 
     90  TBlendOperation = (boLinearBlend, boTransparent,                                  //blending
     91    boLighten, boScreen, boAdditive, boLinearAdd, boColorDodge, boNiceGlow,         //lighting
     92    boGlow, boReflect, boOverlay, boDarkOverlay, boDarken, boMultiply, boColorBurn, //masking
     93    boDifference, boLinearDifference, boNegation, boLinearNegation, boXor);         //negative
     94
     95const
     96  boGlowMask = boGlow;
     97  boLinearMultiply = boMultiply;
     98
     99const
     100  BlendOperationStr : array[TBlendOperation] of string =
     101   ('LinearBlend', 'Transparent',
     102    'Lighten', 'Screen', 'Additive', 'LinearAdd', 'ColorDodge', 'NiceGlow',
     103    'Glow', 'Reflect', 'Overlay', 'DarkOverlay', 'Darken', 'Multiply', 'ColorBurn',
     104    'Difference', 'LinearDifference', 'Negation', 'LinearNegation', 'Xor');
     105
     106function StrToBlendOperation(str: string): TBlendOperation;
     107
     108type
    53109  TGradientType = (gtLinear, gtReflected, gtDiamond, gtRadial);
    54 
    55110const
    56111  GradientTypeStr : array[TGradientType] of string =
    57112  ('Linear','Reflected','Diamond','Radial');
    58 
     113function StrToGradientType(str: string): TGradientType;
     114 
    59115type
    60   TRadialBlurType = (rbNormal, rbDisk, rbCorona, rbPrecise);
    61   TChannel = (cRed, cGreen, cBlue, cAlpha);
    62   TBlendOperation = (boLinearBlend, boTransparent, boMultiply,
    63     boLinearMultiply, boAdditive, boLinearAdd, boColorBurn, boColorDodge, boReflect,
    64     boGlow, boOverlay, boDifference, boLinearDifference, boNegation,
    65     boLinearNegation, boLighten, boDarken, boScreen, boXor);
    66 
     116  { A pen style is defined as a list of floating number. The first number is the length of the first dash,
     117    the second number is the length of the first gap, the third number is the length of the second dash...
     118    It must have an even number of values. }
     119  TBGRAPenStyle = Array Of Single;
     120  TRoundRectangleOption = (rrTopLeftSquare,rrTopRightSquare,rrBottomRightSquare,rrBottomLeftSquare,
     121                           rrTopLeftBevel,rrTopRightBevel,rrBottomRightBevel,rrBottomLeftBevel,rrDefault);
     122  TRoundRectangleOptions = set of TRoundRectangleOption;
     123  TPolygonOrder = (poNone, poFirstOnTop, poLastOnTop); //see TBGRAMultiShapeFiller in BGRAPolygon
     124 
     125function BGRAPenStyle(dash1, space1: single; dash2: single=0; space2: single = 0; dash3: single=0; space3: single = 0; dash4 : single = 0; space4 : single = 0): TBGRAPenStyle; 
     126 
     127{ Point, polygon and curve structures }
     128type
     129  PPointF = ^TPointF;
    67130  TPointF = record
    68131    x, y: single;
    69132  end;
    70133  ArrayOfTPointF = array of TPointF;
    71 
     134  TArcOption = (aoClosePath, aoPie, aoFillPath);
     135  TArcOptions = set of TArcOption;
     136
     137  TCubicBezierCurve = record
     138    p1,c1,c2,p2: TPointF;
     139  end;
     140  TQuadraticBezierCurve = record
     141    p1,c,p2: TPointF;
     142  end;
     143
     144  TPoint3D = record
     145    x,y,z: single;
     146  end;
     147
     148function ConcatPointsF(const APolylines: array of ArrayOfTPointF): ArrayOfTPointF;
     149
     150function Point3D(x,y,z: single): TPoint3D;
     151operator = (const v1,v2: TPoint3D): boolean; inline;
     152operator * (const v1,v2: TPoint3D): single; inline;
     153operator * (const v1: TPoint3D; const factor: single): TPoint3D; inline;
     154operator - (const v1,v2: TPoint3D): TPoint3D; inline;
     155operator - (const v: TPoint3D): TPoint3D; inline;
     156operator + (const v1,v2: TPoint3D): TPoint3D; inline;
     157procedure VectProduct3D(u,v: TPoint3D; out w: TPoint3D);
     158procedure Normalize3D(var v: TPoint3D); inline;
     159
     160function BezierCurve(origin, control1, control2, destination: TPointF) : TCubicBezierCurve; overload;
     161function BezierCurve(origin, control, destination: TPointF) : TQuadraticBezierCurve; overload;
     162
     163{ Useful constants }
    72164const
    73165  dmFastBlend = dmLinearBlend;
    74 
    75 const
    76   EmptySingle: single = -3.402823e38;
    77 
    78 const
    79   EmptyPointF: TPointF = (x: -3.402823e38; y: -3.402823e38);
    80 
    81 const
     166  EmptySingle: single = -3.402823e38;                        //used as a separator in floating point lists
     167  EmptyPointF: TPointF = (x: -3.402823e38; y: -3.402823e38); //used as a separator in TPointF lists
    82168  BGRAPixelTransparent: TBGRAPixel = (blue: 0; green: 0; red: 0; alpha: 0);
    83 
    84 const
    85169  BGRAWhite: TBGRAPixel = (blue: 255; green: 255; red: 255; alpha: 255);
    86 
    87 const
    88170  BGRABlack: TBGRAPixel = (blue: 0; green: 0; red: 0; alpha: 255);
    89171
    90 const
     172  //Red colors
     173  CSSIndianRed: TBGRAPixel = (blue: 92; green: 92; red: 205; alpha: 255);
     174  CSSLightCoral: TBGRAPixel = (blue: 128; green: 128; red: 240; alpha: 255);
     175  CSSSalmon: TBGRAPixel = (blue: 114; green: 128; red: 250; alpha: 255);
     176  CSSDarkSalmon: TBGRAPixel = (blue: 122; green: 150; red: 233; alpha: 255);
     177  CSSRed: TBGRAPixel = (blue: 0; green: 0; red: 255; alpha: 255);
     178  CSSCrimson: TBGRAPixel = (blue: 60; green: 20; red: 220; alpha: 255);
     179  CSSFireBrick: TBGRAPixel = (blue: 34; green: 34; red: 178; alpha: 255);
     180  CSSDarkRed: TBGRAPixel = (blue: 0; green: 0; red: 139; alpha: 255);
     181
     182  //Pink colors
     183  CSSPink: TBGRAPixel = (blue: 203; green: 192; red: 255; alpha: 255);
     184  CSSLightPink: TBGRAPixel = (blue: 193; green: 182; red: 255; alpha: 255);
     185  CSSHotPink: TBGRAPixel = (blue: 180; green: 105; red: 255; alpha: 255);
     186  CSSDeepPink: TBGRAPixel = (blue: 147; green: 20; red: 255; alpha: 255);
     187  CSSMediumVioletRed: TBGRAPixel = (blue: 133; green: 21; red: 199; alpha: 255);
     188  CSSPaleVioletRed: TBGRAPixel = (blue: 147; green: 112; red: 219; alpha: 255);
     189
     190  //Orange colors
     191  CSSLightSalmon: TBGRAPixel = (blue: 122; green: 160; red: 255; alpha: 255);
     192  CSSCoral: TBGRAPixel = (blue: 80; green: 127; red: 255; alpha: 255);
     193  CSSTomato: TBGRAPixel = (blue: 71; green: 99; red: 255; alpha: 255);
     194  CSSOrangeRed: TBGRAPixel = (blue: 0; green: 69; red: 255; alpha: 255);
     195  CSSDarkOrange: TBGRAPixel = (blue: 0; green: 140; red: 255; alpha: 255);
     196  CSSOrange: TBGRAPixel = (blue: 0; green: 165; red: 255; alpha: 255);
     197
     198  //Yellow colors
     199  CSSGold: TBGRAPixel = (blue: 0; green: 215; red: 255; alpha: 255);
     200  CSSYellow: TBGRAPixel = (blue: 0; green: 255; red: 255; alpha: 255);
     201  CSSLightYellow: TBGRAPixel = (blue: 224; green: 255; red: 255; alpha: 255);
     202  CSSLemonChiffon: TBGRAPixel = (blue: 205; green: 250; red: 255; alpha: 255);
     203  CSSLightGoldenrodYellow: TBGRAPixel = (blue: 210; green: 250; red: 250; alpha: 255);
     204  CSSPapayaWhip: TBGRAPixel = (blue: 213; green: 239; red: 255; alpha: 255);
     205  CSSMoccasin: TBGRAPixel = (blue: 181; green: 228; red: 255; alpha: 255);
     206  CSSPeachPuff: TBGRAPixel = (blue: 185; green: 218; red: 255; alpha: 255);
     207  CSSPaleGoldenrod: TBGRAPixel = (blue: 170; green: 232; red: 238; alpha: 255);
     208  CSSKhaki: TBGRAPixel = (blue: 140; green: 230; red: 240; alpha: 255);
     209  CSSDarkKhaki: TBGRAPixel = (blue: 107; green: 183; red: 189; alpha: 255);
     210
     211  //Purple colors
     212  CSSLavender: TBGRAPixel = (blue: 250; green: 230; red: 230; alpha: 255);
     213  CSSThistle: TBGRAPixel = (blue: 216; green: 191; red: 216; alpha: 255);
     214  CSSPlum: TBGRAPixel = (blue: 221; green: 160; red: 221; alpha: 255);
     215  CSSViolet: TBGRAPixel = (blue: 238; green: 130; red: 238; alpha: 255);
     216  CSSOrchid: TBGRAPixel = (blue: 214; green: 112; red: 218; alpha: 255);
     217  CSSFuchsia: TBGRAPixel = (blue: 255; green: 0; red: 255; alpha: 255);
     218  CSSMagenta: TBGRAPixel = (blue: 255; green: 0; red: 255; alpha: 255);
     219  CSSMediumOrchid: TBGRAPixel = (blue: 211; green: 85; red: 186; alpha: 255);
     220  CSSMediumPurple: TBGRAPixel = (blue: 219; green: 112; red: 147; alpha: 255);
     221  CSSBlueViolet: TBGRAPixel = (blue: 226; green: 43; red: 138; alpha: 255);
     222  CSSDarkViolet: TBGRAPixel = (blue: 211; green: 0; red: 148; alpha: 255);
     223  CSSDarkOrchid: TBGRAPixel = (blue: 204; green: 50; red: 153; alpha: 255);
     224  CSSDarkMagenta: TBGRAPixel = (blue: 139; green: 0; red: 139; alpha: 255);
     225  CSSPurple: TBGRAPixel = (blue: 128; green: 0; red: 128; alpha: 255);
     226  CSSIndigo: TBGRAPixel = (blue: 130; green: 0; red: 75; alpha: 255);
     227  CSSDarkSlateBlue: TBGRAPixel = (blue: 139; green: 61; red: 72; alpha: 255);
     228  CSSSlateBlue: TBGRAPixel = (blue: 205; green: 90; red: 106; alpha: 255);
     229  CSSMediumSlateBlue: TBGRAPixel = (blue: 238; green: 104; red: 123; alpha: 255);
     230
     231  //Green colors
     232  CSSGreenYellow: TBGRAPixel = (blue: 47; green: 255; red: 173; alpha: 255);
     233  CSSChartreuse: TBGRAPixel = (blue: 0; green: 255; red: 127; alpha: 255);
     234  CSSLawnGreen: TBGRAPixel = (blue: 0; green: 252; red: 124; alpha: 255);
     235  CSSLime: TBGRAPixel = (blue: 0; green: 255; red: 0; alpha: 255);
     236  CSSLimeGreen: TBGRAPixel = (blue: 50; green: 205; red: 50; alpha: 255);
     237  CSSPaleGreen: TBGRAPixel = (blue: 152; green: 251; red: 152; alpha: 255);
     238  CSSLightGreen: TBGRAPixel = (blue: 144; green: 238; red: 144; alpha: 255);
     239  CSSMediumSpringGreen: TBGRAPixel = (blue: 154; green: 250; red: 0; alpha: 255);
     240  CSSSpringGreen: TBGRAPixel = (blue: 127; green: 255; red: 0; alpha: 255);
     241  CSSMediumSeaGreen: TBGRAPixel = (blue: 113; green: 179; red: 60; alpha: 255);
     242  CSSSeaGreen: TBGRAPixel = (blue: 87; green: 139; red: 46; alpha: 255);
     243  CSSForestGreen: TBGRAPixel = (blue: 34; green: 139; red: 34; alpha: 255);
     244  CSSGreen: TBGRAPixel = (blue: 0; green: 128; red: 0; alpha: 255);
     245  CSSDarkGreen: TBGRAPixel = (blue: 0; green: 100; red: 0; alpha: 255);
     246  CSSYellowGreen: TBGRAPixel = (blue: 50; green: 205; red: 154; alpha: 255);
     247  CSSOliveDrab: TBGRAPixel = (blue: 35; green: 142; red: 107; alpha: 255);
     248  CSSOlive: TBGRAPixel = (blue: 0; green: 128; red: 128; alpha: 255);
     249  CSSDarkOliveGreen: TBGRAPixel = (blue: 47; green: 107; red: 85; alpha: 255);
     250  CSSMediumAquamarine: TBGRAPixel = (blue: 170; green: 205; red: 102; alpha: 255);
     251  CSSDarkSeaGreen: TBGRAPixel = (blue: 143; green: 188; red: 143; alpha: 255);
     252  CSSLightSeaGreen: TBGRAPixel = (blue: 170; green: 178; red: 32; alpha: 255);
     253  CSSDarkCyan: TBGRAPixel = (blue: 139; green: 139; red: 0; alpha: 255);
     254  CSSTeal: TBGRAPixel = (blue: 128; green: 128; red: 0; alpha: 255);
     255
     256  //Blue/Cyan colors
     257  CSSAqua: TBGRAPixel = (blue: 255; green: 255; red: 0; alpha: 255);
     258  CSSCyan: TBGRAPixel = (blue: 255; green: 255; red: 0; alpha: 255);
     259  CSSLightCyan: TBGRAPixel = (blue: 255; green: 255; red: 224; alpha: 255);
     260  CSSPaleTurquoise: TBGRAPixel = (blue: 238; green: 238; red: 175; alpha: 255);
     261  CSSAquamarine: TBGRAPixel = (blue: 212; green: 255; red: 127; alpha: 255);
     262  CSSTurquoise: TBGRAPixel = (blue: 208; green: 224; red: 64; alpha: 255);
     263  CSSMediumTurquoise: TBGRAPixel = (blue: 204; green: 209; red: 72; alpha: 255);
     264  CSSDarkTurquoise: TBGRAPixel = (blue: 209; green: 206; red: 0; alpha: 255);
     265  CSSCadetBlue: TBGRAPixel = (blue: 160; green: 158; red: 95; alpha: 255);
     266  CSSSteelBlue: TBGRAPixel = (blue: 180; green: 130; red: 70; alpha: 255);
     267  CSSLightSteelBlue: TBGRAPixel = (blue: 222; green: 196; red: 176; alpha: 255);
     268  CSSPowderBlue: TBGRAPixel = (blue: 230; green: 224; red: 176; alpha: 255);
     269  CSSLightBlue: TBGRAPixel = (blue: 230; green: 216; red: 173; alpha: 255);
     270  CSSSkyBlue: TBGRAPixel = (blue: 235; green: 206; red: 135; alpha: 255);
     271  CSSLightSkyBlue: TBGRAPixel = (blue: 250; green: 206; red: 135; alpha: 255);
     272  CSSDeepSkyBlue: TBGRAPixel = (blue: 255; green: 191; red: 0; alpha: 255);
     273  CSSDodgerBlue: TBGRAPixel = (blue: 255; green: 144; red: 30; alpha: 255);
     274  CSSCornflowerBlue: TBGRAPixel = (blue: 237; green: 149; red: 100; alpha: 255);
     275  CSSRoyalBlue: TBGRAPixel = (blue: 255; green: 105; red: 65; alpha: 255);
     276  CSSBlue: TBGRAPixel = (blue: 255; green: 0; red: 0; alpha: 255);
     277  CSSMediumBlue: TBGRAPixel = (blue: 205; green: 0; red: 0; alpha: 255);
     278  CSSDarkBlue: TBGRAPixel = (blue: 139; green: 0; red: 0; alpha: 255);
     279  CSSNavy: TBGRAPixel = (blue: 128; green: 0; red: 0; alpha: 255);
     280  CSSMidnightBlue: TBGRAPixel = (blue: 112; green: 25; red: 25; alpha: 255);
     281
     282  //Brown colors
     283  CSSCornsilk: TBGRAPixel = (blue: 220; green: 248; red: 255; alpha: 255);
     284  CSSBlanchedAlmond: TBGRAPixel = (blue: 205; green: 235; red: 255; alpha: 255);
     285  CSSBisque: TBGRAPixel = (blue: 196; green: 228; red: 255; alpha: 255);
     286  CSSNavajoWhite: TBGRAPixel = (blue: 173; green: 222; red: 255; alpha: 255);
     287  CSSWheat: TBGRAPixel = (blue: 179; green: 222; red: 245; alpha: 255);
     288  CSSBurlyWood: TBGRAPixel = (blue: 135; green: 184; red: 222; alpha: 255);
     289  CSSTan: TBGRAPixel = (blue: 140; green: 180; red: 210; alpha: 255);
     290  CSSRosyBrown: TBGRAPixel = (blue: 143; green: 143; red: 188; alpha: 255);
     291  CSSSandyBrown: TBGRAPixel = (blue: 96; green: 164; red: 244; alpha: 255);
     292  CSSGoldenrod: TBGRAPixel = (blue: 32; green: 165; red: 218; alpha: 255);
     293  CSSDarkGoldenrod: TBGRAPixel = (blue: 11; green: 134; red: 184; alpha: 255);
     294  CSSPeru: TBGRAPixel = (blue: 63; green: 133; red: 205; alpha: 255);
     295  CSSChocolate: TBGRAPixel = (blue: 30; green: 105; red: 210; alpha: 255);
     296  CSSSaddleBrown: TBGRAPixel = (blue: 19; green: 69; red: 139; alpha: 255);
     297  CSSSienna: TBGRAPixel = (blue: 45; green: 82; red: 160; alpha: 255);
     298  CSSBrown: TBGRAPixel = (blue: 42; green: 42; red: 165; alpha: 255);
     299  CSSMaroon: TBGRAPixel = (blue: 0; green: 0; red: 128; alpha: 255);
     300
     301  //White colors
     302  CSSWhite: TBGRAPixel = (blue: 255; green: 255; red: 255; alpha: 255);
     303  CSSSnow: TBGRAPixel = (blue: 250; green: 250; red: 255; alpha: 255);
     304  CSSHoneydew: TBGRAPixel = (blue: 240; green: 255; red: 250; alpha: 255);
     305  CSSMintCream: TBGRAPixel = (blue: 250; green: 255; red: 245; alpha: 255);
     306  CSSAzure: TBGRAPixel = (blue: 255; green: 255; red: 240; alpha: 255);
     307  CSSAliceBlue: TBGRAPixel = (blue: 255; green: 248; red: 240; alpha: 255);
     308  CSSGhostWhite: TBGRAPixel = (blue: 255; green: 248; red: 248; alpha: 255);
     309  CSSWhiteSmoke: TBGRAPixel = (blue: 245; green: 245; red: 245; alpha: 255);
     310  CSSSeashell: TBGRAPixel = (blue: 255; green: 245; red: 238; alpha: 255);
     311  CSSBeige: TBGRAPixel = (blue: 220; green: 245; red: 245; alpha: 255);
     312  CSSOldLace: TBGRAPixel = (blue: 230; green: 245; red: 253; alpha: 255);
     313  CSSFloralWhite: TBGRAPixel = (blue: 240; green: 250; red: 255; alpha: 255);
     314  CSSIvory: TBGRAPixel = (blue: 240; green: 255; red: 255; alpha: 255);
     315  CSSAntiqueWhite: TBGRAPixel = (blue: 215; green: 235; red: 250; alpha: 255);
     316  CSSLinen: TBGRAPixel = (blue: 230; green: 240; red: 250; alpha: 255);
     317  CSSLavenderBlush: TBGRAPixel = (blue: 245; green: 240; red: 255; alpha: 255);
     318  CSSMistyRose: TBGRAPixel = (blue: 255; green: 228; red: 255; alpha: 255);
     319
     320  //Gray colors
     321  CSSGainsboro: TBGRAPixel = (blue: 220; green: 220; red: 220; alpha: 255);
     322  CSSLightGray: TBGRAPixel = (blue: 211; green: 211; red: 211; alpha: 255);
     323  CSSSilver: TBGRAPixel = (blue: 192; green: 192; red: 192; alpha: 255);
     324  CSSDarkGray: TBGRAPixel = (blue: 169; green: 169; red: 169; alpha: 255);
     325  CSSGray: TBGRAPixel = (blue: 128; green: 128; red: 128; alpha: 255);
     326  CSSDimGray: TBGRAPixel = (blue: 105; green: 105; red: 105; alpha: 255);
     327  CSSLightSlateGray: TBGRAPixel = (blue: 153; green: 136; red: 119; alpha: 255);
     328  CSSSlateGray: TBGRAPixel = (blue: 144; green: 128; red: 112; alpha: 255);
     329  CSSDarkSlateGray: TBGRAPixel = (blue: 79; green: 79; red: 47; alpha: 255);
     330  CSSBlack: TBGRAPixel = (blue: 0; green: 0; red: 0; alpha: 255);
     331
     332  { This color is needed for drawing black shapes on the standard TCanvas, because
     333    when drawing with pure black, there is no way to know if something has been
     334    drawn or if it is transparent }
    91335  clBlackOpaque = TColor($010000);
    92336
     337type
     338  TBGRAColorDefinition = record
     339    Name: string;
     340    Color: TBGRAPixel;
     341  end;
     342
     343  { TBGRAColorList }
     344
     345  TBGRAColorList = class
     346  protected
     347    FFinished: boolean;
     348    FNbColors: integer;
     349    FColors: array of TBGRAColorDefinition;
     350    function GetByIndex(Index: integer): TBGRAPixel;
     351    function GetByName(Name: string): TBGRAPixel;
     352    function GetName(Index: integer): string;
     353  public
     354    constructor Create;
     355    procedure Add(Name: string; Color: TBGRAPixel);
     356    procedure Finished;
     357    function IndexOf(Name: string): integer;
     358
     359    property ByName[Name: string]: TBGRAPixel read GetByName;
     360    property ByIndex[Index: integer]: TBGRAPixel read GetByIndex; default;
     361    property Name[Index: integer]: string read GetName;
     362    property Count: integer read FNbColors;
     363  end;
     364
     365var
     366  CSSColors: TBGRAColorList;
     367
    93368function isEmptyPointF(pt: TPointF): boolean;
    94369
     370type
     371  TFontPixelMetric = record
     372    Defined: boolean;
     373    Baseline, xLine, CapLine, DescentLine, Lineheight: integer;
     374  end;
     375
     376  { A scanner is like an image, but its content has no limit and can be calculated on the fly.
     377    It must not implement reference counting. }
     378  IBGRAScanner = interface
     379    procedure ScanMoveTo(X,Y: Integer);
     380    function ScanNextPixel: TBGRAPixel;
     381    function ScanAt(X,Y: Single): TBGRAPixel;
     382    procedure ScanPutPixels(pdest: PBGRAPixel; count: integer; mode: TDrawMode);
     383    function IsScanPutPixelsDefined: boolean;
     384  end;
     385
     386  TScanAtFunction = function (X,Y: Single): TBGRAPixel of object;
     387  TScanNextPixelFunction = function: TBGRAPixel of object;
     388  TBGRACustomGradient = class;
     389
     390  { TBGRACustomBitmap }
     391
     392  TBGRACustomBitmap = class(TFPCustomImage,IBGRAScanner) // a bitmap can be used as a scanner
     393  private
     394    function GetFontAntialias: Boolean;
     395    procedure SetFontAntialias(const AValue: Boolean);
     396  protected
     397     { accessors to properies }
     398     function GetHeight: integer; virtual; abstract;
     399     function GetWidth: integer; virtual; abstract;
     400     function GetDataPtr: PBGRAPixel; virtual; abstract;
     401     function GetNbPixels: integer; virtual; abstract;
     402     function CheckEmpty: boolean; virtual; abstract;
     403     function GetHasTransparentPixels: boolean; virtual; abstract;
     404     function GetAverageColor: TColor; virtual; abstract;
     405     function GetAveragePixel: TBGRAPixel; virtual; abstract;
     406     procedure SetCanvasOpacity(AValue: byte); virtual; abstract;
     407     function GetScanLine(y: integer): PBGRAPixel; virtual; abstract;
     408     function GetRefCount: integer; virtual; abstract;
     409     function GetBitmap: TBitmap; virtual; abstract;
     410     function GetLineOrder: TRawImageLineOrder; virtual; abstract;
     411     function GetCanvasFP: TFPImageCanvas; virtual; abstract;
     412     function GetCanvasDrawModeFP: TDrawMode; virtual; abstract;
     413     procedure SetCanvasDrawModeFP(const AValue: TDrawMode); virtual; abstract;
     414     function GetCanvas: TCanvas; virtual; abstract;
     415     function GetCanvasOpacity: byte; virtual; abstract;
     416     function GetCanvasAlphaCorrection: boolean; virtual; abstract;
     417     procedure SetCanvasAlphaCorrection(const AValue: boolean); virtual; abstract;
     418     function GetFontHeight: integer; virtual; abstract;
     419     procedure SetFontHeight(AHeight: integer); virtual; abstract;
     420     function GetFontFullHeight: integer; virtual; abstract;
     421     procedure SetFontFullHeight(AHeight: integer); virtual; abstract;
     422     function GetPenStyle: TPenStyle; virtual; abstract;
     423     procedure SetPenStyle(const AValue: TPenStyle); virtual; abstract;
     424     function GetCustomPenStyle: TBGRAPenStyle; virtual; abstract;
     425     procedure SetCustomPenStyle(const AValue: TBGRAPenStyle); virtual; abstract;
     426     function GetClipRect: TRect; virtual; abstract;
     427     procedure SetClipRect(const AValue: TRect); virtual; abstract;
     428     function GetFontPixelMetric: TFontPixelMetric; virtual; abstract;
     429     function LoadAsBmp32(Str: TStream): boolean; virtual; abstract;
     430
     431  public
     432     Caption:   string;  //user defined caption
     433
     434     //font style
     435     FontName:  string;
     436     FontStyle: TFontStyles;
     437     FontQuality : TBGRAFontQuality;
     438     FontOrientation: integer;
     439
     440     //line style
     441     LineCap:   TPenEndCap;
     442     JoinStyle: TPenJoinStyle;
     443     JoinMiterLimit: single;
     444
     445     FillMode:  TFillMode;  //winding or alternate
     446
     447     { The resample filter is used when resizing the bitmap, and
     448       scan interpolation filter is used when the bitmap is used
     449       as a scanner (IBGRAScanner) }
     450     ResampleFilter,
     451     ScanInterpolationFilter: TResampleFilter;
     452     ScanOffset: TPoint;
     453
     454     constructor Create; virtual; abstract; overload;
     455     constructor Create(ABitmap: TBitmap); virtual; abstract; overload;
     456     constructor Create(AWidth, AHeight: integer; Color: TColor); virtual; abstract; overload;
     457     constructor Create(AWidth, AHeight: integer; Color: TBGRAPixel); virtual; abstract; overload;
     458     constructor Create(AFilename: string); virtual; abstract; overload;
     459     constructor Create(AStream: TStream); virtual; abstract; overload;
     460
     461     function NewBitmap(AWidth, AHeight: integer): TBGRACustomBitmap; virtual; abstract; overload;
     462     function NewBitmap(AWidth, AHeight: integer; Color: TBGRAPixel): TBGRACustomBitmap; virtual; abstract; overload;
     463     function NewBitmap(Filename: string): TBGRACustomBitmap; virtual; abstract; overload;
     464
     465     procedure LoadFromFile(const filename: string); virtual;
     466     procedure LoadFromStream(Str: TStream); virtual;
     467     procedure LoadFromStream(Str: TStream; Handler: TFPCustomImageReader); virtual;
     468     procedure SaveToFile(const filename: string); virtual;
     469     procedure SaveToFile(const filename: string; Handler:TFPCustomImageWriter); virtual;
     470     procedure SaveToStreamAsPng(Str: TStream); virtual; abstract;
     471     procedure Assign(ABitmap: TBitmap); virtual; abstract; overload;
     472     procedure Assign(MemBitmap: TBGRACustomBitmap); virtual; abstract; overload;
     473     procedure Serialize(AStream: TStream); virtual; abstract;
     474     procedure Deserialize(AStream: TStream); virtual; abstract;
     475
     476     {Pixel functions}
     477     procedure SetPixel(x, y: integer; c: TColor); virtual; abstract; overload;
     478     procedure XorPixel(x, y: integer; c: TBGRAPixel); virtual; abstract; overload;
     479     procedure SetPixel(x, y: integer; c: TBGRAPixel); virtual; abstract; overload;
     480     procedure DrawPixel(x, y: integer; c: TBGRAPixel); virtual; abstract; overload;
     481     procedure DrawPixel(x, y: integer; ec: TExpandedPixel); virtual; abstract; overload;
     482     procedure FastBlendPixel(x, y: integer; c: TBGRAPixel); virtual; abstract;
     483     procedure ErasePixel(x, y: integer; alpha: byte); virtual; abstract;
     484     procedure AlphaPixel(x, y: integer; alpha: byte); virtual; abstract;
     485     function GetPixel(x, y: integer): TBGRAPixel; virtual; abstract;
     486     function GetPixel(x, y: single; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; virtual; abstract; overload;
     487     function GetPixelCycle(x, y: integer): TBGRAPixel; virtual;
     488     function GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; virtual; abstract; overload;
     489     function GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter; repeatX: boolean; repeatY: boolean): TBGRAPixel; virtual; abstract; overload;
     490
     491     {Line primitives}
     492     procedure SetHorizLine(x, y, x2: integer; c: TBGRAPixel); virtual; abstract;
     493     procedure XorHorizLine(x, y, x2: integer; c: TBGRAPixel); virtual; abstract;
     494     procedure DrawHorizLine(x, y, x2: integer; c: TBGRAPixel); virtual; abstract; overload;
     495     procedure DrawHorizLine(x, y, x2: integer; ec: TExpandedPixel); virtual; abstract; overload;
     496     procedure DrawHorizLine(x, y, x2: integer; texture: IBGRAScanner); virtual; abstract; overload;
     497     procedure FastBlendHorizLine(x, y, x2: integer; c: TBGRAPixel); virtual; abstract;
     498     procedure AlphaHorizLine(x, y, x2: integer; alpha: byte); virtual; abstract;
     499     procedure SetVertLine(x, y, y2: integer; c: TBGRAPixel); virtual; abstract;
     500     procedure XorVertLine(x, y, y2: integer; c: TBGRAPixel); virtual; abstract;
     501     procedure DrawVertLine(x, y, y2: integer; c: TBGRAPixel); virtual; abstract;
     502     procedure AlphaVertLine(x, y, y2: integer; alpha: byte); virtual; abstract;
     503     procedure FastBlendVertLine(x, y, y2: integer; c: TBGRAPixel); virtual; abstract;
     504     procedure DrawHorizLineDiff(x, y, x2: integer; c, compare: TBGRAPixel;
     505       maxDiff: byte); virtual; abstract;
     506
     507     {Shapes}
     508     procedure DrawLine(x1, y1, x2, y2: integer; c: TBGRAPixel; DrawLastPixel: boolean); virtual; abstract;
     509     procedure DrawLineAntialias(x1, y1, x2, y2: integer; c: TBGRAPixel; DrawLastPixel: boolean); virtual; abstract; overload;
     510     procedure DrawLineAntialias(x1, y1, x2, y2: integer; c1, c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean); virtual; abstract; overload;
     511     procedure DrawLineAntialias(x1, y1, x2, y2: single; c: TBGRAPixel; w: single); virtual; abstract; overload;
     512     procedure DrawLineAntialias(x1, y1, x2, y2: single; texture: IBGRAScanner; w: single); virtual; abstract; overload;
     513     procedure DrawLineAntialias(x1, y1, x2, y2: single; c: TBGRAPixel; w: single; Closed: boolean); virtual; abstract; overload;
     514     procedure DrawLineAntialias(x1, y1, x2, y2: single; texture: IBGRAScanner; w: single; Closed: boolean); virtual; abstract; overload;
     515
     516     procedure DrawPolyLineAntialias(const points: array of TPoint; c: TBGRAPixel; DrawLastPixel: boolean); virtual; overload;
     517     procedure DrawPolyLineAntialias(const points: array of TPoint; c1, c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean); virtual; overload;
     518     procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single); virtual; abstract; overload;
     519     procedure DrawPolyLineAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single); virtual; abstract; overload;
     520     procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single; Closed: boolean); virtual; abstract; overload;
     521     procedure DrawPolygonAntialias(const points: array of TPointF; c: TBGRAPixel; w: single); virtual; abstract; overload;
     522     procedure DrawPolygonAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single); virtual; abstract; overload;
     523     procedure EraseLineAntialias(x1, y1, x2, y2: single; alpha: byte; w: single); virtual; abstract; overload;
     524     procedure EraseLineAntialias(x1, y1, x2, y2: single; alpha: byte; w: single; Closed: boolean); virtual; abstract; overload;
     525     procedure ErasePolyLineAntialias(const points: array of TPointF; alpha: byte; w: single); virtual; abstract; overload;
     526
     527     procedure FillTriangleLinearColor(pt1,pt2,pt3: TPointF; c1,c2,c3: TBGRAPixel); virtual; abstract; overload;
     528     procedure FillTriangleLinearColorAntialias(pt1,pt2,pt3: TPointF; c1,c2,c3: TBGRAPixel); virtual; abstract; overload;
     529     procedure FillTriangleLinearMapping(pt1,pt2,pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF; TextureInterpolation: Boolean= True); virtual; abstract; overload;
     530     procedure FillTriangleLinearMappingLightness(pt1,pt2,pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF; light1,light2,light3: word; TextureInterpolation: Boolean= True); virtual; abstract; overload;
     531     procedure FillTriangleLinearMappingAntialias(pt1,pt2,pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF); virtual; abstract; overload;
     532
     533     procedure FillQuadLinearColor(pt1,pt2,pt3,pt4: TPointF; c1,c2,c3,c4: TBGRAPixel); virtual; abstract; overload;
     534     procedure FillQuadLinearColorAntialias(pt1,pt2,pt3,pt4: TPointF; c1,c2,c3,c4: TBGRAPixel); virtual; abstract; overload;
     535     procedure FillQuadLinearMapping(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; TextureInterpolation: Boolean= True);  virtual; abstract; overload;
     536     procedure FillQuadLinearMappingLightness(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; light1,light2,light3,light4: word; TextureInterpolation: Boolean= True); virtual; abstract; overload;
     537     procedure FillQuadLinearMappingAntialias(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF); virtual; abstract; overload;
     538     procedure FillQuadPerspectiveMapping(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF); virtual; abstract; overload;
     539     procedure FillQuadPerspectiveMappingAntialias(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF); virtual; abstract; overload;
     540
     541     procedure FillPolyLinearColor(const points: array of TPointF; AColors: array of TBGRAPixel);  virtual; abstract; overload;
     542     procedure FillPolyLinearMapping(const points: array of TPointF; texture: IBGRAScanner; texCoords: array of TPointF; TextureInterpolation: Boolean); virtual; abstract; overload;
     543     procedure FillPolyLinearMappingLightness(const points: array of TPointF; texture: IBGRAScanner; texCoords: array of TPointF; lightnesses: array of word; TextureInterpolation: Boolean); virtual; abstract; overload;
     544     procedure FillPolyPerspectiveMapping(const points: array of TPointF; const pointsZ: array of single; texture: IBGRAScanner; texCoords: array of TPointF; TextureInterpolation: Boolean); virtual; abstract; overload;
     545     procedure FillPolyPerspectiveMappingLightness(const points: array of TPointF; const pointsZ: array of single; texture: IBGRAScanner; texCoords: array of TPointF; lightnesses: array of word; TextureInterpolation: Boolean); virtual; abstract; overload;
     546
     547     procedure FillPoly(const points: array of TPointF; c: TBGRAPixel; drawmode: TDrawMode); virtual; abstract;
     548     procedure FillPoly(const points: array of TPointF; texture: IBGRAScanner; drawmode: TDrawMode); virtual; abstract;
     549     procedure FillPolyAntialias(const points: array of TPointF; c: TBGRAPixel); virtual; abstract;
     550     procedure FillPolyAntialias(const points: array of TPointF; texture: IBGRAScanner); virtual; abstract;
     551     procedure ErasePoly(const points: array of TPointF; alpha: byte); virtual; abstract;
     552     procedure ErasePolyAntialias(const points: array of TPointF; alpha: byte); virtual; abstract;
     553
     554     procedure EllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel; w: single); virtual; abstract;
     555     procedure EllipseAntialias(x, y, rx, ry: single; texture: IBGRAScanner; w: single); virtual; abstract;
     556     procedure EllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel; w: single; back: TBGRAPixel); virtual; abstract;
     557     procedure FillEllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel); virtual; abstract;
     558     procedure FillEllipseAntialias(x, y, rx, ry: single; texture: IBGRAScanner); virtual; abstract;
     559     procedure FillEllipseLinearColorAntialias(x, y, rx, ry: single; outercolor, innercolor: TBGRAPixel); virtual; abstract;
     560     procedure EraseEllipseAntialias(x, y, rx, ry: single; alpha: byte); virtual; abstract;
     561
     562     procedure Rectangle(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); virtual; abstract; overload;
     563     procedure Rectangle(x, y, x2, y2: integer; BorderColor, FillColor: TBGRAPixel; mode: TDrawMode); virtual; abstract; overload;
     564     procedure Rectangle(x, y, x2, y2: integer; c: TColor); virtual; overload;
     565     procedure Rectangle(r: TRect; c: TBGRAPixel; mode: TDrawMode); virtual; overload;
     566     procedure Rectangle(r: TRect; BorderColor, FillColor: TBGRAPixel; mode: TDrawMode); virtual;overload;
     567     procedure Rectangle(r: TRect; c: TColor); virtual; overload;
     568     procedure RectangleAntialias(x, y, x2, y2: single; c: TBGRAPixel; w: single); virtual; overload;
     569     procedure RectangleAntialias(x, y, x2, y2: single; c: TBGRAPixel; w: single; back: TBGRAPixel); virtual; abstract; overload;
     570     procedure RectangleAntialias(x, y, x2, y2: single; texture: IBGRAScanner; w: single); virtual; abstract; overload;
     571
     572     procedure RoundRect(X1, Y1, X2, Y2: integer; DX, DY: integer; BorderColor, FillColor: TBGRAPixel); virtual; abstract;
     573     procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; c: TBGRAPixel; w: single; options: TRoundRectangleOptions = []); virtual; abstract;
     574     procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; pencolor: TBGRAPixel; w: single; fillcolor: TBGRAPixel; options: TRoundRectangleOptions = []); virtual; abstract;
     575     procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; penTexture: IBGRAScanner; w: single; fillTexture: IBGRAScanner; options: TRoundRectangleOptions = []); virtual; abstract;
     576     procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; texture: IBGRAScanner; w: single; options: TRoundRectangleOptions = []); virtual; abstract;
     577     procedure FillRoundRectAntialias(x,y,x2,y2,rx,ry: single; c: TBGRAPixel; options: TRoundRectangleOptions = []); virtual; abstract;
     578     procedure FillRoundRectAntialias(x,y,x2,y2,rx,ry: single; texture: IBGRAScanner; options: TRoundRectangleOptions = []); virtual; abstract;
     579     procedure EraseRoundRectAntialias(x,y,x2,y2,rx,ry: single; alpha: byte; options: TRoundRectangleOptions = []); virtual; abstract;
     580
     581     procedure FillRect(r: TRect; c: TColor); virtual; overload;
     582     procedure FillRect(r: TRect; c: TBGRAPixel; mode: TDrawMode); virtual; overload;
     583     procedure FillRect(x, y, x2, y2: integer; c: TColor); virtual; overload;
     584     procedure FillRect(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); virtual; abstract; overload;
     585     procedure FillRect(x, y, x2, y2: integer; texture: IBGRAScanner; mode: TDrawMode); virtual; abstract;
     586     procedure FillRectAntialias(x, y, x2, y2: single; c: TBGRAPixel); virtual; abstract;
     587     procedure FillRectAntialias(x, y, x2, y2: single; texture: IBGRAScanner); virtual; abstract;
     588     procedure EraseRectAntialias(x, y, x2, y2: single; alpha: byte); virtual; abstract;
     589     procedure AlphaFillRect(x, y, x2, y2: integer; alpha: byte); virtual; abstract;
     590
     591     procedure TextOut(x, y: integer; s: string; c: TBGRAPixel; align: TAlignment); virtual; abstract; overload;
     592     procedure TextOut(x, y: integer; s: string; texture: IBGRAScanner; align: TAlignment); virtual; abstract; overload;
     593     procedure TextOutAngle(x, y, orientation: integer; s: string; c: TBGRAPixel; align: TAlignment); virtual; abstract;
     594     procedure TextOutAngle(x, y, orientation: integer; s: string; texture: IBGRAScanner; align: TAlignment); virtual; abstract;
     595     procedure TextOut(x, y: integer; s: string; c: TBGRAPixel); virtual; overload;
     596     procedure TextOut(x, y: integer; s: string; c: TColor); virtual; overload;
     597     procedure TextOut(x, y: integer; s: string; texture: IBGRAScanner); virtual; overload;
     598     procedure TextRect(ARect: TRect; x, y: integer; s: string; style: TTextStyle; c: TBGRAPixel); virtual; abstract; overload;
     599     procedure TextRect(ARect: TRect; x, y: integer; s: string; style: TTextStyle; texture: IBGRAScanner); virtual; abstract; overload;
     600     procedure TextRect(ARect: TRect; s: string; halign: TAlignment; valign: TTextLayout; c: TBGRAPixel); virtual; overload;
     601     procedure TextRect(ARect: TRect; s: string; halign: TAlignment; valign: TTextLayout; texture: IBGRAScanner); virtual; overload;
     602     function TextSize(s: string): TSize; virtual; abstract;
     603
     604     {Spline}
     605     function ComputeClosedSpline(const APoints: array of TPointF; AStyle: TSplineStyle): ArrayOfTPointF; virtual; abstract;
     606     function ComputeOpenedSpline(const APoints: array of TPointF; AStyle: TSplineStyle): ArrayOfTPointF; virtual; abstract;
     607     function ComputeBezierCurve(const curve: TCubicBezierCurve): ArrayOfTPointF; virtual; abstract;
     608     function ComputeBezierCurve(const curve: TQuadraticBezierCurve): ArrayOfTPointF; virtual; abstract;
     609     function ComputeBezierSpline(const spline: array of TCubicBezierCurve): ArrayOfTPointF; virtual; abstract;
     610     function ComputeBezierSpline(const spline: array of TQuadraticBezierCurve): ArrayOfTPointF; virtual; abstract;
     611
     612     function ComputeWidePolyline(const points: array of TPointF; w: single): ArrayOfTPointF; virtual; abstract;
     613     function ComputeWidePolyline(const points: array of TPointF; w: single; Closed: boolean): ArrayOfTPointF; virtual; abstract;
     614     function ComputeWidePolygon(const points: array of TPointF; w: single): ArrayOfTPointF; virtual; abstract;
     615
     616     function ComputeEllipse(x,y,rx,ry: single): ArrayOfTPointF; virtual; abstract;
     617     function ComputeEllipse(x,y,rx,ry,w: single): ArrayOfTPointF; virtual; abstract;
     618     function ComputeArc65536(x,y,rx,ry: single; start65536,end65536: word): ArrayOfTPointF; virtual; abstract;
     619     function ComputeArcRad(x,y,rx,ry: single; startRad,endRad: single): ArrayOfTPointF; virtual; abstract;
     620     function ComputeRoundRect(x1,y1,x2,y2,rx,ry: single): ArrayOfTPointF; virtual; abstract;
     621     function ComputeRoundRect(x1,y1,x2,y2,rx,ry: single; options: TRoundRectangleOptions): ArrayOfTPointF; virtual; abstract;
     622     function ComputePie65536(x,y,rx,ry: single; start65536,end65536: word): ArrayOfTPointF; virtual; abstract;
     623     function ComputePieRad(x,y,rx,ry: single; startRad,endRad: single): ArrayOfTPointF; virtual; abstract;
     624
     625     {Filling}
     626     procedure FillTransparent; virtual;
     627     procedure NoClip; virtual; abstract;
     628     procedure ApplyGlobalOpacity(alpha: byte); virtual; abstract;
     629     procedure Fill(c: TColor); virtual; overload;
     630     procedure Fill(c: TBGRAPixel); virtual; overload;
     631     procedure Fill(texture: IBGRAScanner; mode: TDrawMode); virtual; abstract; overload;
     632     procedure Fill(texture: IBGRAScanner); virtual; abstract; overload;
     633     procedure Fill(c: TBGRAPixel; start, Count: integer); virtual; abstract; overload;
     634     procedure DrawPixels(c: TBGRAPixel; start, Count: integer); virtual; abstract;
     635     procedure AlphaFill(alpha: byte); virtual; overload;
     636     procedure AlphaFill(alpha: byte; start, Count: integer); virtual; abstract; overload;
     637     procedure FillMask(x,y: integer; AMask: TBGRACustomBitmap; color: TBGRAPixel); virtual; abstract; overload;
     638     procedure FillMask(x,y: integer; AMask: TBGRACustomBitmap; texture: IBGRAScanner); virtual; abstract; overload;
     639     procedure FillClearTypeMask(x,y: integer; xThird: integer; AMask: TBGRACustomBitmap; color: TBGRAPixel; ARGBOrder: boolean = true); virtual; abstract; overload;
     640     procedure FillClearTypeMask(x,y: integer; xThird: integer; AMask: TBGRACustomBitmap; texture: IBGRAScanner; ARGBOrder: boolean = true); virtual; abstract; overload;
     641     procedure ReplaceColor(before, after: TColor); virtual; abstract; overload;
     642     procedure ReplaceColor(before, after: TBGRAPixel); virtual; abstract; overload;
     643     procedure ReplaceTransparent(after: TBGRAPixel); virtual; abstract; overload;
     644     procedure FloodFill(X, Y: integer; Color: TBGRAPixel;
     645       mode: TFloodfillMode; Tolerance: byte = 0); virtual;
     646     procedure ParallelFloodFill(X, Y: integer; Dest: TBGRACustomBitmap; Color: TBGRAPixel;
     647       mode: TFloodfillMode; Tolerance: byte = 0); virtual; abstract;
     648     procedure GradientFill(x, y, x2, y2: integer; c1, c2: TBGRAPixel;
     649       gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode;
     650       gammaColorCorrection: boolean = True; Sinus: Boolean=False); virtual; abstract;
     651     procedure GradientFill(x, y, x2, y2: integer; gradient: TBGRACustomGradient;
     652       gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode;
     653       Sinus: Boolean=False); virtual; abstract;
     654     function CreateBrushTexture(ABrushStyle: TBrushStyle; APatternColor, ABackgroundColor: TBGRAPixel;
     655                AWidth: integer = 8; AHeight: integer = 8; APenWidth: single = 1): TBGRACustomBitmap; virtual; abstract;
     656
     657     {Canvas drawing functions}
     658     procedure DataDrawTransparent(ACanvas: TCanvas; Rect: TRect;
     659       AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); virtual; abstract;
     660     procedure DataDrawOpaque(ACanvas: TCanvas; Rect: TRect; AData: Pointer;
     661       ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); virtual; abstract;
     662     procedure GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer); virtual; abstract;
     663     procedure Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean = True); virtual; abstract;
     664     procedure Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean = True); virtual; abstract;
     665     procedure DrawPart(ARect: TRect; Canvas: TCanvas; x, y: integer; Opaque: boolean); virtual;
     666     function GetPart(ARect: TRect): TBGRACustomBitmap; virtual; abstract;
     667     function GetPtrBitmap(Top,Bottom: Integer): TBGRACustomBitmap; virtual; abstract;
     668     procedure InvalidateBitmap; virtual; abstract;         //call if you modify with Scanline
     669     procedure LoadFromBitmapIfNeeded; virtual; abstract;   //call to ensure that bitmap data is up to date
     670
     671     {BGRA bitmap functions}
     672     procedure PutImage(x, y: integer; Source: TBGRACustomBitmap; mode: TDrawMode; AOpacity: byte = 255); virtual; abstract;
     673     procedure PutImageSubpixel(x, y: single; Source: TBGRACustomBitmap);
     674     procedure PutImageAffine(Origin,HAxis,VAxis: TPointF; Source: TBGRACustomBitmap; AOpacity: Byte=255); virtual; abstract;
     675     procedure PutImageAngle(x,y: single; Source: TBGRACustomBitmap; angle: single; imageCenterX: single = 0; imageCenterY: single = 0; AOpacity: Byte=255); virtual; abstract;
     676     procedure BlendImage(x, y: integer; Source: TBGRACustomBitmap;
     677       operation: TBlendOperation); virtual; abstract;
     678     function Duplicate(DuplicateProperties: Boolean = False): TBGRACustomBitmap; virtual; abstract;
     679     function Equals(comp: TBGRACustomBitmap): boolean; virtual; abstract;
     680     function Equals(comp: TBGRAPixel): boolean; virtual; abstract;
     681     function Resample(newWidth, newHeight: integer;
     682       mode: TResampleMode = rmFineResample): TBGRACustomBitmap; virtual; abstract;
     683     procedure VerticalFlip; virtual; abstract;
     684     procedure HorizontalFlip; virtual; abstract;
     685     function RotateCW: TBGRACustomBitmap; virtual; abstract;
     686     function RotateCCW: TBGRACustomBitmap; virtual; abstract;
     687     procedure Negative; virtual; abstract;
     688     procedure LinearNegative; virtual; abstract;
     689     procedure SwapRedBlue; virtual; abstract;
     690     procedure GrayscaleToAlpha; virtual; abstract;
     691     procedure AlphaToGrayscale; virtual; abstract;
     692     procedure ApplyMask(mask: TBGRACustomBitmap); virtual; abstract;
     693     function GetImageBounds(Channel: TChannel = cAlpha): TRect; virtual; abstract;
     694     function GetImageBounds(Channels: TChannels): TRect; virtual; abstract;
     695     function MakeBitmapCopy(BackgroundColor: TColor): TBitmap; virtual; abstract;
     696
     697     {Filters}
     698     function FilterSmartZoom3(Option: TMedianOption): TBGRACustomBitmap; virtual; abstract;
     699     function FilterMedian(Option: TMedianOption): TBGRACustomBitmap; virtual; abstract;
     700     function FilterSmooth: TBGRACustomBitmap; virtual; abstract;
     701     function FilterSharpen: TBGRACustomBitmap; virtual; abstract;
     702     function FilterContour: TBGRACustomBitmap; virtual; abstract;
     703     function FilterBlurRadial(radius: integer;
     704       blurType: TRadialBlurType): TBGRACustomBitmap; virtual; abstract;
     705     function FilterPixelate(pixelSize: integer; useResample: boolean; filter: TResampleFilter = rfLinear): TBGRACustomBitmap; virtual; abstract;
     706     function FilterBlurMotion(distance: integer; angle: single;
     707       oriented: boolean): TBGRACustomBitmap; virtual; abstract;
     708     function FilterCustomBlur(mask: TBGRACustomBitmap): TBGRACustomBitmap; virtual; abstract;
     709     function FilterEmboss(angle: single): TBGRACustomBitmap; virtual; abstract;
     710     function FilterEmbossHighlight(FillSelection: boolean): TBGRACustomBitmap; virtual; abstract;
     711     function FilterGrayscale: TBGRACustomBitmap; virtual; abstract;
     712     function FilterNormalize(eachChannel: boolean = True): TBGRACustomBitmap; virtual; abstract;
     713     function FilterRotate(origin: TPointF; angle: single): TBGRACustomBitmap; virtual; abstract;
     714     function FilterSphere: TBGRACustomBitmap; virtual; abstract;
     715     function FilterTwirl(ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap; virtual; abstract;
     716     function FilterCylinder: TBGRACustomBitmap; virtual; abstract;
     717     function FilterPlane: TBGRACustomBitmap; virtual; abstract;
     718
     719     property Data: PBGRAPixel Read GetDataPtr;
     720     property Width: integer Read GetWidth;
     721     property Height: integer Read GetHeight;
     722     property NbPixels: integer Read GetNbPixels;
     723     property Empty: boolean Read CheckEmpty;
     724
     725     property ScanLine[y: integer]: PBGRAPixel Read GetScanLine;
     726     property RefCount: integer Read GetRefCount;
     727     property Bitmap: TBitmap Read GetBitmap; //don't forget to call InvalidateBitmap before if you changed something with Scanline
     728     property HasTransparentPixels: boolean Read GetHasTransparentPixels;
     729     property AverageColor: TColor Read GetAverageColor;
     730     property AveragePixel: TBGRAPixel Read GetAveragePixel;
     731     property LineOrder: TRawImageLineOrder Read GetLineOrder;
     732     property CanvasFP: TFPImageCanvas read GetCanvasFP;
     733     property CanvasDrawModeFP: TDrawMode read GetCanvasDrawModeFP write SetCanvasDrawModeFP;
     734     property Canvas: TCanvas Read GetCanvas;
     735     property CanvasOpacity: byte Read GetCanvasOpacity Write SetCanvasOpacity;
     736     property CanvasAlphaCorrection: boolean
     737       Read GetCanvasAlphaCorrection Write SetCanvasAlphaCorrection;
     738
     739     property FontHeight: integer Read GetFontHeight Write SetFontHeight;
     740     property PenStyle: TPenStyle read GetPenStyle Write SetPenStyle;
     741     property CustomPenStyle: TBGRAPenStyle read GetCustomPenStyle write SetCustomPenStyle;
     742     property ClipRect: TRect read GetClipRect write SetClipRect;
     743     property FontAntialias: Boolean read GetFontAntialias write SetFontAntialias; //antialiasing (it's different from TFont antialiasing mode)
     744     property FontFullHeight: integer read GetFontFullHeight write SetFontFullHeight;
     745     property FontPixelMetric: TFontPixelMetric read GetFontPixelMetric;
     746
     747     //interface
     748     function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
     749     function _AddRef: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
     750     function _Release: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
     751
     752     //IBGRAScanner
     753     procedure ScanMoveTo(X,Y: Integer); virtual; abstract;
     754     function ScanNextPixel: TBGRAPixel; virtual; abstract;
     755     function ScanAt(X,Y: Single): TBGRAPixel; virtual; abstract;
     756     procedure ScanPutPixels(pdest: PBGRAPixel; count: integer; mode: TDrawMode); virtual;
     757     function IsScanPutPixelsDefined: boolean; virtual;
     758  end;
     759
     760  { TBGRACustomScanner }
     761
     762  TBGRACustomScanner = class(IBGRAScanner)
     763  private
     764    FCurX,FCurY: integer;
     765  public
     766    procedure ScanMoveTo(X,Y: Integer); virtual;
     767    function ScanNextPixel: TBGRAPixel; virtual;
     768    function ScanAt(X,Y: Single): TBGRAPixel; virtual; abstract;
     769    procedure ScanPutPixels(pdest: PBGRAPixel; count: integer; mode: TDrawMode); virtual;
     770    function IsScanPutPixelsDefined: boolean; virtual;
     771    function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
     772    function _AddRef: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
     773    function _Release: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
     774  end;
     775
     776  TBGRACustomGradient = class
     777  public
     778    function GetColorAt(position: integer): TBGRAPixel; virtual; abstract;
     779    function GetAverageColor: TBGRAPixel; virtual; abstract;
     780    function GetMonochrome: boolean; virtual; abstract;
     781    property Monochrome: boolean read GetMonochrome;
     782  end;
     783
     784type
     785  TBGRABitmapAny = class of TBGRACustomBitmap;  //used to create instances of the same type (see NewBitmap)
     786
     787var
     788  BGRABitmapFactory : TBGRABitmapAny;
     789
     790{ Color functions }
    95791function GetIntensity(c: TExpandedPixel): word; inline;
    96792function SetIntensity(c: TExpandedPixel; intensity: word): TExpandedPixel;
    97793function GetLightness(c: TExpandedPixel): word; inline;
    98794function SetLightness(c: TExpandedPixel; lightness: word): TExpandedPixel;
     795function ApplyLightnessFast(color: TBGRAPixel; lightness: word): TBGRAPixel; inline;
    99796function BGRAToHSLA(c: TBGRAPixel): THSLAPixel;
     797function HSLAToExpanded(c: THSLAPixel): TExpandedPixel;
    100798function HSLAToBGRA(c: THSLAPixel): TBGRAPixel;
     799function GtoH(ghue: word): word;
     800function HtoG(hue: word): word;
     801function HueDiff(h1, h2: word): word;
     802function GetHue(ec: TExpandedPixel): word;
     803function ColorImportance(ec: TExpandedPixel): word;
     804function GSBAToBGRA(c: THSLAPixel): TBGRAPixel;
     805function GSBAToHSLA(c: THSLAPixel): THSLAPixel;
    101806function GammaExpansion(c: TBGRAPixel): TExpandedPixel; inline;
    102807function GammaCompression(ec: TExpandedPixel): TBGRAPixel; inline;
     808function GammaCompression(red,green,blue,alpha: word): TBGRAPixel; inline;
    103809function BGRAToGrayscale(c: TBGRAPixel): TBGRAPixel;
    104 function MergeBGRA(c1, c2: TBGRAPixel): TBGRAPixel;
     810function GrayscaleToBGRA(lightness: word): TBGRAPixel;
     811function MergeBGRA(c1, c2: TBGRAPixel): TBGRAPixel; overload;
     812function MergeBGRA(c1: TBGRAPixel; weight1: integer; c2: TBGRAPixel; weight2: integer): TBGRAPixel; overload;
     813function MergeBGRA(ec1, ec2: TExpandedPixel): TExpandedPixel; overload;
    105814function BGRA(red, green, blue, alpha: byte): TBGRAPixel; overload; inline;
    106815function BGRA(red, green, blue: byte): TBGRAPixel; overload; inline;
    107816function ColorToBGRA(color: TColor): TBGRAPixel; overload;
    108817function ColorToBGRA(color: TColor; opacity: byte): TBGRAPixel; overload;
     818function BGRAToFPColor(AValue: TBGRAPixel): TFPColor; inline;
     819function FPColorToBGRA(AValue: TFPColor): TBGRAPixel;
    109820function BGRAToColor(c: TBGRAPixel): TColor;
    110821operator = (const c1, c2: TBGRAPixel): boolean; inline;
    111 
     822function ExpandedDiff(ec1, ec2: TExpandedPixel): word;
     823function BGRAWordDiff(c1, c2: TBGRAPixel): word;
    112824function BGRADiff(c1, c2: TBGRAPixel): byte;
    113 function PointF(x, y: single): TPointF;
    114 
    115 function PtInRect(pt: TPoint; r: TRect): boolean;
    116 
    117 function StrToGradientType(str: string): TGradientType;
     825operator - (const c1, c2: TColorF): TColorF; inline;
     826operator + (const c1, c2: TColorF): TColorF; inline;
     827operator * (const c1, c2: TColorF): TColorF; inline;
     828operator * (const c1: TColorF; factor: single): TColorF; inline;
     829function ColorF(red,green,blue,alpha: single): TColorF;
    118830function BGRAToStr(c: TBGRAPixel): string;
    119831function StrToBGRA(str: string): TBGRAPixel;
    120832
     833{ Get height [0..1] stored in a TBGRAPixel }
     834function MapHeight(Color: TBGRAPixel): Single;
     835
     836{ Get TBGRAPixel to store height [0..1] }
     837function MapHeightToBGRA(Height: Single; Alpha: Byte): TBGRAPixel;
     838
     839
     840{ Gamma conversion arrays. Should be used as readonly }
    121841var
     842  // TBGRAPixel -> TExpandedPixel
    122843  GammaExpansionTab:   packed array[0..255] of word;
     844 
     845  // TExpandedPixel -> TBGRAPixel
    123846  GammaCompressionTab: packed array[0..65535] of byte;
    124847
     848{ Point functions }
     849function PointF(x, y: single): TPointF;
     850function PointsF(const pts: array of TPointF): ArrayOfTPointF;
     851operator = (const pt1, pt2: TPointF): boolean; inline;
     852operator - (const pt1, pt2: TPointF): TPointF; inline;
     853operator - (const pt2: TPointF): TPointF; inline;
     854operator + (const pt1, pt2: TPointF): TPointF; inline;
     855operator * (const pt1, pt2: TPointF): single; inline; //scalar product
     856operator * (const pt1: TPointF; factor: single): TPointF; inline;
     857operator * (factor: single; const pt1: TPointF): TPointF; inline;
     858function PtInRect(pt: TPoint; r: TRect): boolean;
     859function VectLen(dx,dy: single): single; overload;
     860function VectLen(v: TPointF): single; overload;
     861
     862{ Line and polygon functions }
     863type
     864    TLineDef = record
     865       origin, dir: TPointF;
     866    end;
     867
     868function IntersectLine(line1, line2: TLineDef): TPointF;
     869function IntersectLine(line1, line2: TLineDef; out parallel: boolean): TPointF;
     870function IsConvex(const pts: array of TPointF; IgnoreAlign: boolean = true): boolean;
     871function DoesQuadIntersect(pt1,pt2,pt3,pt4: TPointF): boolean;
     872function DoesSegmentIntersect(pt1,pt2,pt3,pt4: TPointF): boolean;
     873
     874{ Cyclic functions }
     875function PositiveMod(value, cycle: integer): integer; inline;
     876
     877{ Sin65536 and Cos65536 are fast routines to compute sine and cosine as integer values.
     878  They use a table to store already computed values. The return value is an integer
     879  ranging from 0 to 65536, so the mean value is 32768 and the half amplitude is
     880  32768 instead of 1. The input has a period of 65536, so you can supply any integer
     881  without applying a modulo. }
     882procedure PrecalcSin65536; // compute all values now
     883function Sin65536(value: word): integer; inline;
     884function Cos65536(value: word): integer; inline;
     885
    125886implementation
    126887
    127888uses Math, SysUtils;
    128889
     890function StrToBlendOperation(str: string): TBlendOperation;
     891var op: TBlendOperation;
     892begin
     893  result := boTransparent;
     894  str := LowerCase(str);
     895  for op := low(TBlendOperation) to high(TBlendOperation) do
     896    if str = LowerCase(BlendOperationStr[op]) then
     897    begin
     898      result := op;
     899      exit;
     900    end;
     901end;
     902
     903function StrToGradientType(str: string): TGradientType;
     904var gt: TGradientType;
     905begin
     906  result := gtLinear;
     907  str := LowerCase(str);
     908  for gt := low(TGradientType) to high(TGradientType) do
     909    if str = LowerCase(GradientTypeStr[gt]) then
     910    begin
     911      result := gt;
     912      exit;
     913    end;
     914end;
     915
     916{ Make a pen style. Need an even number of values. See TBGRAPenStyle }
     917function BGRAPenStyle(dash1, space1: single; dash2: single; space2: single;
     918  dash3: single; space3: single; dash4: single; space4: single): TBGRAPenStyle;
     919var
     920  i: Integer;
     921begin
     922  if dash4 <> 0 then
     923  begin
     924    setlength(result,8);
     925    result[6] := dash4;
     926    result[7] := space4;
     927    result[4] := dash3;
     928    result[5] := space3;
     929    result[2] := dash2;
     930    result[3] := space2;
     931  end else
     932  if dash3 <> 0 then
     933  begin
     934    setlength(result,6);
     935    result[4] := dash3;
     936    result[5] := space3;
     937    result[2] := dash2;
     938    result[3] := space2;
     939  end else
     940  if dash2 <> 0 then
     941  begin
     942    setlength(result,4);
     943    result[2] := dash2;
     944    result[3] := space2;
     945  end else
     946  begin
     947    setlength(result,2);
     948  end;
     949  result[0] := dash1;
     950  result[1] := space1;
     951  for i := 0 to high(result) do
     952    if result[i]=0 then
     953      raise exception.Create('Zero is not a valid value');
     954end;
     955
     956{ Bézier curves definitions. See : http://en.wikipedia.org/wiki/B%C3%A9zier_curve }
     957
     958function ConcatPointsF(const APolylines: array of ArrayOfTPointF
     959  ): ArrayOfTPointF;
     960var
     961  i,pos,count:integer;
     962  j: Integer;
     963begin
     964  count := 0;
     965  for i := 0 to high(APolylines) do
     966    inc(count,length(APolylines[i]));
     967  setlength(result,count);
     968  pos := 0;
     969  for i := 0 to high(APolylines) do
     970    for j := 0 to high(APolylines[i]) do
     971    begin
     972      result[pos] := APolylines[i][j];
     973      inc(pos);
     974    end;
     975end;
     976
     977operator-(const v: TPoint3D): TPoint3D;
     978begin
     979  result.x := -v.x;
     980  result.y := -v.y;
     981  result.z := -v.z;
     982end;
     983
     984operator + (const v1,v2: TPoint3D): TPoint3D; inline;
     985begin
     986  result.x := v1.x+v2.x;
     987  result.y := v1.y+v2.y;
     988  result.z := v1.z+v2.z;
     989end;
     990
     991operator - (const v1,v2: TPoint3D): TPoint3D; inline;
     992begin
     993  result.x := v1.x-v2.x;
     994  result.y := v1.y-v2.y;
     995  result.z := v1.z-v2.z;
     996end;
     997
     998operator * (const v1: TPoint3D; const factor: single): TPoint3D; inline;
     999begin
     1000  result.x := v1.x*factor;
     1001  result.y := v1.y*factor;
     1002  result.z := v1.z*factor;
     1003end;
     1004
     1005function Point3D(x, y, z: single): TPoint3D;
     1006begin
     1007  result.x := x;
     1008  result.y := y;
     1009  result.z := z;
     1010end;
     1011
     1012operator=(const v1, v2: TPoint3D): boolean;
     1013begin
     1014  result := (v1.x=v2.x) and (v1.y=v2.y) and (v1.z=v2.z);
     1015end;
     1016
     1017operator * (const v1,v2: TPoint3D): single; inline;
     1018begin
     1019  result := v1.x*v2.x + v1.y*v2.y + v1.z*v2.z;
     1020end;
     1021
     1022procedure Normalize3D(var v: TPoint3D); inline;
     1023var len: double;
     1024begin
     1025  len := v*v;
     1026  if len = 0 then exit;
     1027  len := sqrt(len);
     1028  v.x /= len;
     1029  v.y /= len;
     1030  v.z /= len;
     1031end;
     1032
     1033procedure VectProduct3D(u,v: TPoint3D; out w: TPoint3D);
     1034begin
     1035  w.x := u.y*v.z-u.z*v.y;
     1036  w.y := u.z*v.x-u.x*v.z;
     1037  w.z := u.x*v.Y-u.y*v.x;
     1038end;
     1039
     1040// Define a Bézier curve with two control points.
     1041function BezierCurve(origin, control1, control2, destination: TPointF): TCubicBezierCurve;
     1042begin
     1043  result.p1 := origin;
     1044  result.c1 := control1;
     1045  result.c2 := control2;
     1046  result.p2 := destination;
     1047end;
     1048
     1049// Define a Bézier curve with one control point.
     1050function BezierCurve(origin, control, destination: TPointF
     1051  ): TQuadraticBezierCurve;
     1052begin
     1053  result.p1 := origin;
     1054  result.c := control;
     1055  result.p2 := destination;
     1056end;
     1057
     1058{ Check if a PointF structure is empty or should be treated as a list separator }
    1291059function isEmptyPointF(pt: TPointF): boolean;
    1301060begin
     
    1321062end;
    1331063
     1064{ TBGRAColorList }
     1065
     1066function TBGRAColorList.GetByIndex(Index: integer): TBGRAPixel;
     1067begin
     1068  if (Index < 0) or (Index >= FNbColors) then
     1069    result := BGRAPixelTransparent
     1070  else
     1071    result := FColors[Index].Color;
     1072end;
     1073
     1074function TBGRAColorList.GetByName(Name: string): TBGRAPixel;
     1075var i: integer;
     1076begin
     1077  i := IndexOf(Name);
     1078  if i = -1 then
     1079    result := BGRAPixelTransparent
     1080  else
     1081    result := FColors[i].Color;
     1082end;
     1083
     1084function TBGRAColorList.GetName(Index: integer): string;
     1085begin
     1086  if (Index < 0) or (Index >= FNbColors) then
     1087    result := ''
     1088  else
     1089    result := FColors[Index].Name;
     1090end;
     1091
     1092constructor TBGRAColorList.Create;
     1093begin
     1094  FNbColors:= 0;
     1095  FColors := nil;
     1096  FFinished:= false;
     1097end;
     1098
     1099procedure TBGRAColorList.Add(Name: string; Color: TBGRAPixel);
     1100begin
     1101  if FFinished then
     1102    raise Exception.Create('This list is already finished');
     1103  if length(FColors) = FNbColors then
     1104    SetLength(FColors, FNbColors*2+1);
     1105  FColors[FNbColors].Name := Name;
     1106  FColors[FNbColors].Color := Color;
     1107  inc(FNbColors);
     1108end;
     1109
     1110procedure TBGRAColorList.Finished;
     1111begin
     1112  if FFinished then exit;
     1113  FFinished := true;
     1114  SetLength(FColors, FNbColors);
     1115end;
     1116
     1117function TBGRAColorList.IndexOf(Name: string): integer;
     1118var i: integer;
     1119begin
     1120  for i := 0 to FNbColors-1 do
     1121    if CompareText(Name, FColors[i].Name) = 0 then
     1122    begin
     1123      result := i;
     1124      exit;
     1125    end;
     1126  result := -1;
     1127end;
     1128
     1129{ TBGRACustomBitmap }
     1130
     1131function TBGRACustomBitmap.GetFontAntialias: Boolean;
     1132begin
     1133  result := FontQuality <> fqSystem;
     1134end;
     1135
     1136procedure TBGRACustomBitmap.SetFontAntialias(const AValue: Boolean);
     1137begin
     1138  if AValue and not FontAntialias then
     1139    FontQuality := fqFineAntialiasing
     1140  else if not AValue and (FontQuality <> fqSystem) then
     1141    FontQuality := fqSystem;
     1142end;
     1143
     1144{ These declaration make sure that these methods are virtual }
     1145procedure TBGRACustomBitmap.LoadFromFile(const filename: string);
     1146begin
     1147  inherited LoadFromFile(filename);
     1148end;
     1149
     1150procedure TBGRACustomBitmap.SaveToFile(const filename: string);
     1151begin
     1152  inherited SaveToFile(filename);
     1153end;
     1154
     1155procedure TBGRACustomBitmap.SaveToFile(const filename: string;
     1156  Handler: TFPCustomImageWriter);
     1157begin
     1158  inherited SaveToFile(filename, Handler);
     1159end;
     1160
     1161{ LoadFromStream uses TFPCustomImage routine, which uses
     1162  Colors property to access pixels. That's why the
     1163  FP drawing mode is temporarily changed to load
     1164  bitmaps properly }
     1165procedure TBGRACustomBitmap.LoadFromStream(Str: TStream);
     1166var
     1167  OldDrawMode: TDrawMode;
     1168begin
     1169  OldDrawMode := CanvasDrawModeFP;
     1170  CanvasDrawModeFP := dmSet;
     1171  try
     1172    if not LoadAsBmp32(Str) then
     1173      inherited LoadFromStream(Str);
     1174  finally
     1175    CanvasDrawModeFP := OldDrawMode;
     1176  end;
     1177end;
     1178
     1179{ See above }
     1180procedure TBGRACustomBitmap.LoadFromStream(Str: TStream;
     1181  Handler: TFPCustomImageReader);
     1182var
     1183  OldDrawMode: TDrawMode;
     1184begin
     1185  OldDrawMode := CanvasDrawModeFP;
     1186  CanvasDrawModeFP := dmSet;
     1187  try
     1188    inherited LoadFromStream(Str, Handler);
     1189  finally
     1190    CanvasDrawModeFP := OldDrawMode;
     1191  end;
     1192end;
     1193
     1194{ Look for a pixel considering the bitmap is repeated in both directions }
     1195function TBGRACustomBitmap.GetPixelCycle(x, y: integer): TBGRAPixel;
     1196begin
     1197  if (Width = 0) or (Height = 0) then
     1198    Result := BGRAPixelTransparent
     1199  else
     1200    Result := (Scanline[PositiveMod(y,Height)] + PositiveMod(x,Width))^;
     1201end;
     1202
     1203{ Pixel polylines are constructed by concatenation }
     1204procedure TBGRACustomBitmap.DrawPolyLineAntialias(const points: array of TPoint;
     1205  c: TBGRAPixel; DrawLastPixel: boolean);
     1206var i: integer;
     1207begin
     1208   if length(points) = 1 then
     1209   begin
     1210     if DrawLastPixel then DrawPixel(points[0].x,points[0].y,c);
     1211   end
     1212   else
     1213     for i := 0 to high(points)-1 do
     1214       DrawLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y,c,DrawLastPixel and (i=high(points)-1));
     1215end;
     1216
     1217procedure TBGRACustomBitmap.DrawPolyLineAntialias(const points: array of TPoint; c1,
     1218  c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean);
     1219var i: integer;
     1220begin
     1221   if length(points) = 1 then
     1222   begin
     1223     if DrawLastPixel then DrawPixel(points[0].x,points[0].y,c1);
     1224   end
     1225   else
     1226     for i := 0 to high(points)-1 do
     1227       DrawLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y,c1,c2,dashLen,DrawLastPixel and (i=high(points)-1));
     1228end;
     1229
     1230{ Following functions are defined for convenience }
     1231procedure TBGRACustomBitmap.Rectangle(x, y, x2, y2: integer; c: TColor);
     1232begin
     1233  Rectangle(x, y, x2, y2, ColorToBGRA(c), dmSet);
     1234end;
     1235
     1236procedure TBGRACustomBitmap.Rectangle(r: TRect; c: TBGRAPixel; mode: TDrawMode
     1237  );
     1238begin
     1239  Rectangle(r.left, r.top, r.right, r.bottom, c, mode);
     1240end;
     1241
     1242procedure TBGRACustomBitmap.Rectangle(r: TRect; BorderColor,
     1243  FillColor: TBGRAPixel; mode: TDrawMode);
     1244begin
     1245  Rectangle(r.left, r.top, r.right, r.bottom, BorderColor, FillColor, mode);
     1246end;
     1247
     1248procedure TBGRACustomBitmap.Rectangle(r: TRect; c: TColor);
     1249begin
     1250  Rectangle(r.left, r.top, r.right, r.bottom, c);
     1251end;
     1252
     1253procedure TBGRACustomBitmap.RectangleAntialias(x, y, x2, y2: single;
     1254  c: TBGRAPixel; w: single);
     1255begin
     1256  RectangleAntialias(x, y, x2, y2, c, w, BGRAPixelTransparent);
     1257end;
     1258
     1259procedure TBGRACustomBitmap.FillRect(r: TRect; c: TColor);
     1260begin
     1261  FillRect(r.Left, r.top, r.right, r.bottom, c);
     1262end;
     1263
     1264procedure TBGRACustomBitmap.FillRect(r: TRect; c: TBGRAPixel; mode: TDrawMode);
     1265begin
     1266  FillRect(r.Left, r.top, r.right, r.bottom, c, mode);
     1267end;
     1268
     1269procedure TBGRACustomBitmap.FillRect(x, y, x2, y2: integer; c: TColor);
     1270begin
     1271  FillRect(x, y, x2, y2, ColorToBGRA(c), dmSet);
     1272end;
     1273
     1274procedure TBGRACustomBitmap.TextOut(x, y: integer; s: string; c: TBGRAPixel);
     1275begin
     1276  TextOut(x, y, s, c, taLeftJustify);
     1277end;
     1278
     1279procedure TBGRACustomBitmap.TextOut(x, y: integer; s: string; c: TColor);
     1280begin
     1281  TextOut(x, y, s, ColorToBGRA(c));
     1282end;
     1283
     1284procedure TBGRACustomBitmap.TextOut(x, y: integer; s: string;
     1285  texture: IBGRAScanner);
     1286begin
     1287  TextOut(x, y, s, texture, taLeftJustify);
     1288end;
     1289
     1290procedure TBGRACustomBitmap.TextRect(ARect: TRect; s: string;
     1291  halign: TAlignment; valign: TTextLayout; c: TBGRAPixel);
     1292var
     1293  style: TTextStyle;
     1294begin
     1295  {$hints off}
     1296  FillChar(style,sizeof(style),0);
     1297  {$hints on}
     1298  style.Alignment := halign;
     1299  style.Layout := valign;
     1300  style.Wordbreak := true;
     1301  style.ShowPrefix := false;
     1302  style.Clipping := false;
     1303  TextRect(ARect,ARect.Left,ARect.Top,s,style,c);
     1304end;
     1305
     1306procedure TBGRACustomBitmap.TextRect(ARect: TRect; s: string;
     1307  halign: TAlignment; valign: TTextLayout; texture: IBGRAScanner);
     1308var
     1309  style: TTextStyle;
     1310begin
     1311  {$hints off}
     1312  FillChar(style,sizeof(style),0);
     1313  {$hints on}
     1314  style.Alignment := halign;
     1315  style.Layout := valign;
     1316  style.Wordbreak := true;
     1317  style.ShowPrefix := false;
     1318  style.Clipping := false;
     1319  TextRect(ARect,ARect.Left,ARect.Top,s,style,texture);
     1320end;
     1321
     1322procedure TBGRACustomBitmap.FillTransparent;
     1323begin
     1324  Fill(BGRAPixelTransparent);
     1325end;
     1326
     1327procedure TBGRACustomBitmap.Fill(c: TColor);
     1328begin
     1329  Fill(ColorToBGRA(c));
     1330end;
     1331
     1332procedure TBGRACustomBitmap.Fill(c: TBGRAPixel);
     1333begin
     1334  Fill(c, 0, NbPixels);
     1335end;
     1336
     1337procedure TBGRACustomBitmap.AlphaFill(alpha: byte);
     1338begin
     1339  AlphaFill(alpha, 0, NbPixels);
     1340end;
     1341
     1342procedure TBGRACustomBitmap.FloodFill(X, Y: integer; Color: TBGRAPixel;
     1343  mode: TFloodfillMode; Tolerance: byte);
     1344begin
     1345  ParallelFloodFill(X,Y,Self,Color,mode,Tolerance);
     1346end;
     1347
     1348procedure TBGRACustomBitmap.DrawPart(ARect: TRect; Canvas: TCanvas; x,
     1349  y: integer; Opaque: boolean);
     1350var
     1351  partial: TBGRACustomBitmap;
     1352begin
     1353  partial := GetPart(ARect);
     1354  if partial <> nil then
     1355  begin
     1356    partial.Draw(Canvas, x, y, Opaque);
     1357    partial.Free;
     1358  end;
     1359end;
     1360
     1361procedure TBGRACustomBitmap.PutImageSubpixel(x, y: single; Source: TBGRACustomBitmap);
     1362begin
     1363  PutImageAngle(x,y,source,0);
     1364end;
     1365
     1366{ Interface gateway }
     1367function TBGRACustomBitmap.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
     1368begin
     1369  if GetInterface(iid, obj) then
     1370    Result := S_OK
     1371  else
     1372    Result := longint(E_NOINTERFACE);
     1373end;
     1374
     1375{ There is no automatic reference counting, but it is compulsory to define these functions }
     1376function TBGRACustomBitmap._AddRef: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
     1377begin
     1378  result := 0;
     1379end;
     1380
     1381function TBGRACustomBitmap._Release: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
     1382begin
     1383  result := 0;
     1384end;
     1385
     1386{$hints off}
     1387procedure TBGRACustomBitmap.ScanPutPixels(pdest: PBGRAPixel; count: integer;
     1388  mode: TDrawMode);
     1389begin
     1390  //do nothing
     1391end;
     1392{$hints on}
     1393
     1394function TBGRACustomBitmap.IsScanPutPixelsDefined: boolean;
     1395begin
     1396  result := False;
     1397end;
     1398
     1399{********************** End of TBGRACustomBitmap **************************}
     1400
     1401{ TBGRACustomScanner }
     1402{ The abstract class record the position so that a derived class
     1403  need only to redefine ScanAt }
     1404
     1405procedure TBGRACustomScanner.ScanMoveTo(X, Y: Integer);
     1406begin
     1407  FCurX := X;
     1408  FCurY := Y;
     1409end;
     1410
     1411{ Call ScanAt to determine pixel value }
     1412function TBGRACustomScanner.ScanNextPixel: TBGRAPixel;
     1413begin
     1414  result := ScanAt(FCurX,FCurY);
     1415  Inc(FCurX);
     1416end;
     1417
     1418{$hints off}
     1419procedure TBGRACustomScanner.ScanPutPixels(pdest: PBGRAPixel; count: integer;
     1420  mode: TDrawMode);
     1421begin
     1422  //do nothing
     1423end;
     1424{$hints on}
     1425
     1426function TBGRACustomScanner.IsScanPutPixelsDefined: boolean;
     1427begin
     1428  result := false;
     1429end;
     1430
     1431{ Interface gateway }
     1432function TBGRACustomScanner.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
     1433begin
     1434  if GetInterface(iid, obj) then
     1435    Result := S_OK
     1436  else
     1437    Result := longint(E_NOINTERFACE);
     1438end;
     1439
     1440{ There is no automatic reference counting, but it is compulsory to define these functions }
     1441function TBGRACustomScanner._AddRef: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
     1442begin
     1443  result := 0;
     1444end;
     1445
     1446function TBGRACustomScanner._Release: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
     1447begin
     1448  result := 0;
     1449end;
     1450
     1451{********************** End of TBGRACustomScanner **************************}
     1452
     1453{ The gamma correction is approximated here by a power function }
    1341454const
    135   GammaExpFactor   = 1.7;
    136 {  redWeight = 0.299;
    137   greenWeight = 0.587;
    138   blueWeight = 0.114;}
    139   redWeightShl10   = 306;
    140   greenWeightShl10 = 601;
    141   blueWeightShl10  = 117;
     1455  GammaExpFactor   = 1.7; //exponent
     1456  redWeightShl10   = 306; // = 0.299
     1457  greenWeightShl10 = 601; // = 0.587
     1458  blueWeightShl10  = 117; // = 0.114
    1421459
    1431460var
     
    1461463procedure InitGamma;
    1471464var
    148   i: integer; {t: textfile; prevval,val: byte; }
    149 begin
     1465  i: integer;
     1466{$IFDEF WINCE}
     1467  j,prevpos,curpos,midpos: integer;
     1468{$ENDIF}
     1469begin
     1470  //the linear factor is used to normalize expanded values in the range 0..65535
    1501471  GammaLinearFactor := 65535 / power(255, GammaExpFactor);
     1472
     1473{$IFDEF WINCE}
     1474  curpos := 0;
     1475  GammaExpansionTab[0] := 0;
     1476  GammaCompressionTab[0] := 0;
     1477  for i := 0 to 255 do
     1478  begin
     1479    prevpos := curpos;
     1480    curpos := round(power(i, GammaExpFactor) * GammaLinearFactor);
     1481    if i = 1 then curpos := 1; //to avoid information loss
     1482    GammaExpansionTab[i] := curpos;
     1483    midpos := (prevpos+1+curpos) div 2;
     1484    for j := prevpos+1 to midpos-1 do
     1485      GammaCompressionTab[j] := i-1;
     1486    for j := midpos to curpos do
     1487      GammaCompressionTab[j] := i;
     1488  end;
     1489{$ELSE}
    1511490  for i := 0 to 255 do
    1521491    GammaExpansionTab[i] := round(power(i, GammaExpFactor) * GammaLinearFactor);
     
    1551494    GammaCompressionTab[i] := round(power(i / GammaLinearFactor, 1 / GammaExpFactor));
    1561495
    157   GammaExpansionTab[1]   := 1; //to avoid information lost
     1496  GammaExpansionTab[1]   := 1; //to avoid information loss
    1581497  GammaCompressionTab[1] := 1;
    159 {
    160      assignfile(t,'gammaout.txt');
    161      rewrite(t);
    162      prevval := 255;
    163      for i := 0 to 255 do
    164      begin
    165        val := GammaCompressionTab[i*256+128];
    166        if val <> prevval then writeln(t,val);
    167        prevval := val;
    168      end;
    169      closefile(t);}
    170 end;
    171 
    172 {$hints off}
    173 
     1498{$ENDIF}
     1499end;
     1500
     1501{************************** Color functions **************************}
     1502
     1503{ The intensity is defined here as the maximum value of any color component }
    1741504function GetIntensity(c: TExpandedPixel): word; inline;
    1751505begin
     
    1861516begin
    1871517  curIntensity := GetIntensity(c);
    188   if curIntensity = 0 then
     1518  if curIntensity = 0 then //suppose it's gray if there is no color information
    1891519    Result := c
    1901520  else
    1911521  begin
     1522    //linear interpolation to reached wanted intensity
    1921523    Result.red   := (c.red * intensity + (curIntensity shr 1)) div curIntensity;
    1931524    Result.green := (c.green * intensity + (curIntensity shr 1)) div curIntensity;
     
    1971528end;
    1981529
     1530{ The lightness here is defined as the subjective sensation of luminosity, where
     1531  blue is the darkest component and green the lightest }
    1991532function GetLightness(c: TExpandedPixel): word; inline;
    2001533begin
     
    2861619end;
    2871620
     1621function ApplyLightnessFast(color: TBGRAPixel; lightness: word): TBGRAPixel; inline;
     1622var lightness256: byte;
     1623begin
     1624  if lightness <= 32768 then
     1625  begin
     1626    if lightness = 32768 then
     1627      result := color else
     1628    begin
     1629      lightness256 := GammaCompressionTab[lightness shl 1];
     1630      result := BGRA(color.red * lightness256 shr 8, color.green*lightness256 shr 8,
     1631                     color.blue * lightness256 shr 8, color.alpha);
     1632    end;
     1633  end else
     1634  begin
     1635    if lightness = 65535 then
     1636      result := BGRAWhite else
     1637    begin
     1638      lightness256 := GammaCompressionTab[(lightness-32767) shl 1];
     1639      result := BGRA(color.red + (255-color.red)*lightness256 shr 8,
     1640                     color.green + (255-color.green)*lightness256 shr 8,
     1641                     color.blue + (255-color.blue)*lightness256 shr 8,
     1642                     color.alpha);
     1643    end;
     1644  end;
     1645end;
     1646
     1647{ Conversion from RGB value to HSL colorspace. See : http://en.wikipedia.org/wiki/HSL_color_space }
    2881648function BGRAToHSLA(c: TBGRAPixel): THSLAPixel;
    2891649const
     
    2941654var
    2951655  ec: TExpandedPixel;
    296   min, max, minMax: word;
     1656  min, max, minMax: integer;
    2971657  twiceLightness: integer;
     1658  r,g,b: integer;
    2981659begin
    2991660  ec  := GammaExpansion(c);
    300   min := ec.red;
    301   max := ec.red;
    302   if ec.green > max then
    303     max := ec.green
    304   else
    305   if ec.green < min then
    306     min := ec.green;
    307   if ec.blue > max then
    308     max := ec.blue
    309   else
    310   if ec.blue < min then
    311     min  := ec.blue;
     1661  r := ec.red;
     1662  g := ec.green;
     1663  b := ec.blue;
     1664  min := r;
     1665  max := r;
     1666  if g > max then
     1667    max := g
     1668  else
     1669  if g < min then
     1670    min := g;
     1671  if b > max then
     1672    max := b
     1673  else
     1674  if b < min then
     1675    min  := b;
    3121676  minMax := max - min;
    3131677
     
    3151679    Result.hue := 0
    3161680  else
    317   if max = ec.red then
    318     Result.hue := (((ec.green - ec.blue) * deg60 + (minMax shr 1)) div
     1681  if max = r then
     1682    Result.hue := (((g - b) * deg60) div
    3191683      minMax + deg360) mod deg360
    3201684  else
    321   if max = ec.green then
    322     Result.hue := ((ec.blue - ec.red) * deg60 + (minMax shr 1)) div minMax + deg120
    323   else
    324     {max = ec.blue} Result.hue :=
    325       ((ec.red - ec.green) * deg60 + (minMax shr 1)) div minMax + deg240;
     1685  if max = g then
     1686    Result.hue := ((b - r) * deg60) div minMax + deg120
     1687  else
     1688    {max = b} Result.hue :=
     1689      ((r - g) * deg60) div minMax + deg240;
    3261690  twiceLightness := max + min;
    3271691  if min = max then
    3281692    Result.saturation := 0
    3291693  else
     1694  {$hints off}
    3301695  if twiceLightness < 65536 then
    331     Result.saturation := (minMax shl 16) div (twiceLightness + 1)
    332   else
    333     Result.saturation := (minMax shl 16) div (131072 - twiceLightness);
     1696    Result.saturation := (int64(minMax) shl 16) div (twiceLightness + 1)
     1697  else
     1698    Result.saturation := (int64(minMax) shl 16) div (131072 - twiceLightness);
     1699  {$hints on}
    3341700  Result.lightness := twiceLightness shr 1;
    3351701  Result.alpha := ec.alpha;
    336   Result.hue   := Result.hue * 65536 div deg360;
    337 end;
    338 
    339 function HSLAToBGRA(c: THSLAPixel): TBGRAPixel;
     1702  Result.hue   := (Result.hue shl 16) div deg360;
     1703end;
     1704
     1705function HtoG(hue: word): word;
     1706const
     1707  segmentDest: array[0..5] of word =
     1708     (13653, 10923, 8192, 13653, 10923, 8192);
     1709  segmentSrc: array[0..5] of word =
     1710     (10923, 10922, 10923, 10923, 10922, 10923);
     1711begin
     1712  if hue < segmentSrc[0] then
     1713    result := hue * segmentDest[0] div segmentSrc[0]
     1714  else
     1715  begin
     1716    result := segmentDest[0];
     1717    hue -= segmentSrc[0];
     1718    if hue < segmentSrc[1] then
     1719      result += hue * segmentDest[1] div segmentSrc[1]
     1720    else
     1721    begin
     1722      result += segmentDest[1];
     1723      hue -= segmentSrc[1];
     1724      if hue < segmentSrc[2] then
     1725        result += hue * segmentDest[2] div segmentSrc[2]
     1726      else
     1727      begin
     1728        result += segmentDest[2];
     1729        hue -= segmentSrc[2];
     1730        if hue < segmentSrc[3] then
     1731          result += hue * segmentDest[3] div segmentSrc[3]
     1732        else
     1733        begin
     1734          result += segmentDest[3];
     1735          hue -= segmentSrc[3];
     1736          if hue < segmentSrc[4] then
     1737            result += hue * segmentDest[4] div segmentSrc[4]
     1738          else
     1739          begin
     1740            result += segmentDest[4];
     1741            hue -= segmentSrc[4];
     1742            result += hue * segmentDest[5] div segmentSrc[5];
     1743          end;
     1744        end;
     1745      end;
     1746    end;
     1747  end;
     1748end;
     1749
     1750function GtoH(ghue: word): word;
     1751const
     1752  segment: array[0..5] of word =
     1753     (13653, 10923, 8192, 13653, 10923, 8192);
     1754begin
     1755  if ghue < segment[0] then
     1756    result := ghue * 10923 div segment[0]
     1757  else
     1758  begin
     1759    ghue -= segment[0];
     1760    if ghue < segment[1] then
     1761      result := ghue * (21845-10923) div segment[1] + 10923
     1762    else
     1763    begin
     1764      ghue -= segment[1];
     1765      if ghue < segment[2] then
     1766        result := ghue * (32768-21845) div segment[2] + 21845
     1767      else
     1768      begin
     1769        ghue -= segment[2];
     1770        if ghue < segment[3] then
     1771          result := ghue * (43691-32768) div segment[3] + 32768
     1772        else
     1773        begin
     1774          ghue -= segment[3];
     1775          if ghue < segment[4] then
     1776            result := ghue * (54613-43691) div segment[4] + 43691
     1777          else
     1778          begin
     1779            ghue -= segment[4];
     1780            result := ghue * (65536-54613) div segment[5] + 54613;
     1781          end;
     1782        end;
     1783      end;
     1784    end;
     1785  end;
     1786end;
     1787
     1788function HSLAToExpanded(c: THSLAPixel): TExpandedPixel;
    3401789const
    3411790  deg30  = 4096;
     
    3641813var
    3651814  q, p: integer;
    366   ec:   TExpandedPixel;
    3671815begin
    3681816  c.hue := c.hue * deg360 shr 16;
    3691817  if c.saturation = 0 then  //gray
    3701818  begin
    371     ec.red   := c.lightness;
    372     ec.green := c.lightness;
    373     ec.blue  := c.lightness;
    374     ec.alpha := c.alpha;
    375     Result   := GammaCompression(ec);
     1819    result.red   := c.lightness;
     1820    result.green := c.lightness;
     1821    result.blue  := c.lightness;
     1822    result.alpha := c.alpha;
    3761823    exit;
    3771824  end;
     1825  {$hints off}
    3781826  if c.lightness < 32768 then
    3791827    q := (c.lightness shr 1) * ((65535 + c.saturation) shr 1) shr 14
     
    3811829    q := c.lightness + c.saturation - ((c.lightness shr 1) *
    3821830      (c.saturation shr 1) shr 14);
     1831  {$hints on}
    3831832  if q > 65535 then
    3841833    q := 65535;
     
    3861835  if p > 65535 then
    3871836    p      := 65535;
    388   ec.red   := ComputeColor(p, q, c.hue + deg120);
    389   ec.green := ComputeColor(p, q, c.hue);
    390   ec.blue  := ComputeColor(p, q, c.hue + deg240);
    391   ec.alpha := c.alpha;
    392   Result   := GammaCompression(ec);
    393 end;
    394 
     1837  result.red   := ComputeColor(p, q, c.hue + deg120);
     1838  result.green := ComputeColor(p, q, c.hue);
     1839  result.blue  := ComputeColor(p, q, c.hue + deg240);
     1840  result.alpha := c.alpha;
     1841end;
     1842
     1843{ Conversion from HSL colorspace to RGB. See : http://en.wikipedia.org/wiki/HSL_color_space }
     1844function HSLAToBGRA(c: THSLAPixel): TBGRAPixel;
     1845var ec: TExpandedPixel;
     1846begin
     1847  ec := HSLAToExpanded(c);
     1848  Result := GammaCompression(ec);
     1849end;
     1850
     1851function HueDiff(h1, h2: word): word;
     1852begin
     1853  result := abs(integer(h1)-integer(h2));
     1854  if result > 32768 then result := 65536-result;
     1855end;
     1856
     1857function GetHue(ec: TExpandedPixel): word;
     1858const
     1859  deg60  = 8192;
     1860  deg120 = deg60 * 2;
     1861  deg240 = deg60 * 4;
     1862  deg360 = deg60 * 6;
     1863var
     1864  min, max, minMax: integer;
     1865  r,g,b: integer;
     1866begin
     1867  r := ec.red;
     1868  g := ec.green;
     1869  b := ec.blue;
     1870  min := r;
     1871  max := r;
     1872  if g > max then
     1873    max := g
     1874  else
     1875  if g < min then
     1876    min := g;
     1877  if b > max then
     1878    max := b
     1879  else
     1880  if b < min then
     1881    min  := b;
     1882  minMax := max - min;
     1883
     1884  if minMax = 0 then
     1885    Result := 0
     1886  else
     1887  if max = r then
     1888    Result := (((g - b) * deg60) div
     1889      minMax + deg360) mod deg360
     1890  else
     1891  if max = g then
     1892    Result := ((b - r) * deg60) div minMax + deg120
     1893  else
     1894    {max = b} Result :=
     1895      ((r - g) * deg60) div minMax + deg240;
     1896
     1897  Result   := (Result shl 16) div deg360; //normalize
     1898end;
     1899
     1900function ColorImportance(ec: TExpandedPixel): word;
     1901var min,max: word;
     1902begin
     1903  min := ec.red;
     1904  max := ec.red;
     1905  if ec.green > max then
     1906    max := ec.green
     1907  else
     1908  if ec.green < min then
     1909    min := ec.green;
     1910  if ec.blue > max then
     1911    max := ec.blue
     1912  else
     1913  if ec.blue < min then
     1914    min  := ec.blue;
     1915  result := max - min;
     1916end;
     1917
     1918function GSBAToBGRA(c: THSLAPixel): TBGRAPixel;
     1919var ec: TExpandedPixel;
     1920    lightness: word;
     1921begin
     1922  c.hue := GtoH(c.hue);
     1923  lightness := c.lightness;
     1924  c.lightness := 32768;
     1925  ec := HSLAToExpanded(c);
     1926  result := GammaCompression(SetLightness(ec, lightness));
     1927end;
     1928
     1929function GSBAToHSLA(c: THSLAPixel): THSLAPixel;
     1930begin
     1931  result := BGRAToHSLA(GSBAToBGRA(c));
     1932end;
     1933
     1934{ Apply gamma correction using conversion tables }
    3951935function GammaExpansion(c: TBGRAPixel): TExpandedPixel;
    3961936begin
     
    3981938  Result.green := GammaExpansionTab[c.green];
    3991939  Result.blue  := GammaExpansionTab[c.blue];
    400   Result.alpha := c.alpha shl 8 + 128;
    401 end;
    402 
    403 {$hints on}
     1940  Result.alpha := c.alpha shl 8 + c.alpha;
     1941end;
    4041942
    4051943function GammaCompression(ec: TExpandedPixel): TBGRAPixel;
     
    4111949end;
    4121950
     1951function GammaCompression(red, green, blue, alpha: word): TBGRAPixel;
     1952begin
     1953  Result.red   := GammaCompressionTab[red];
     1954  Result.green := GammaCompressionTab[green];
     1955  Result.blue  := GammaCompressionTab[blue];
     1956  Result.alpha := alpha shr 8;
     1957end;
     1958
     1959// Conversion to grayscale by taking into account
     1960// different color weights
    4131961function BGRAToGrayscale(c: TBGRAPixel): TBGRAPixel;
    4141962var
     
    4301978end;
    4311979
     1980function GrayscaleToBGRA(lightness: word): TBGRAPixel;
     1981begin
     1982  result.red := GammaCompressionTab[lightness];
     1983  result.green := result.red;
     1984  result.blue := result.red;
     1985  result.alpha := $ff;
     1986end;
     1987
     1988{ Merge linearly two colors of same importance }
    4321989function MergeBGRA(c1, c2: TBGRAPixel): TBGRAPixel;
     1990var c12: cardinal;
    4331991begin
    4341992  if (c1.alpha = 0) then
     
    4391997  else
    4401998  begin
    441     Result.red   := round((c1.red * c1.alpha + c2.red * c2.alpha) /
    442       (c1.alpha + c2.alpha));
    443     Result.green := round((c1.green * c1.alpha + c2.green * c2.alpha) /
    444       (c1.alpha + c2.alpha));
    445     Result.blue  := round((c1.blue * c1.alpha + c2.blue * c2.alpha) /
    446       (c1.alpha + c2.alpha));
    447     Result.alpha := (c1.alpha + c2.alpha + 1) div 2;
     1999    c12 := c1.alpha + c2.alpha;
     2000    Result.red   := (c1.red * c1.alpha + c2.red * c2.alpha + c12 shr 1) div c12;
     2001    Result.green := (c1.green * c1.alpha + c2.green * c2.alpha + c12 shr 1) div c12;
     2002    Result.blue  := (c1.blue * c1.alpha + c2.blue * c2.alpha + c12 shr 1) div c12;
     2003    Result.alpha := (c12 + 1) shr 1;
     2004  end;
     2005end;
     2006
     2007function MergeBGRA(c1: TBGRAPixel; weight1: integer; c2: TBGRAPixel;
     2008  weight2: integer): TBGRAPixel;
     2009var
     2010    f1,f2,f12: integer;
     2011begin
     2012  f1 := c1.alpha*weight1;
     2013  f2 := c2.alpha*weight2;
     2014  if (f1 = 0) then
     2015  begin
     2016    if (f2 = 0) then
     2017      result := BGRAPixelTransparent
     2018    else
     2019      Result := c2
     2020  end
     2021  else
     2022  if (f2 = 0) then
     2023    Result := c1
     2024  else
     2025  if (weight1+weight2 = 0) then
     2026    Result := BGRAPixelTransparent
     2027  else
     2028  begin
     2029    f12 := f1+f2;
     2030    if f12 = 0 then
     2031      result := BGRAPixelTransparent
     2032    else
     2033    begin
     2034      Result.red   := (c1.red * f1 + c2.red * f2 + f12 shr 1) div f12;
     2035      Result.green := (c1.green * f1 + c2.green * f2 + f12 shr 1) div f12;
     2036      Result.blue  := (c1.blue * f1 + c2.blue * f2 + f12 shr 1) div f12;
     2037      Result.alpha := (f12 + ((weight1+weight2) shr 1)) div (weight1+weight2);
     2038    end;
     2039  end;
     2040end;
     2041
     2042{ Merge two colors of same importance }
     2043function MergeBGRA(ec1, ec2: TExpandedPixel): TExpandedPixel;
     2044var c12: cardinal;
     2045begin
     2046  if (ec1.alpha = 0) then
     2047    Result := ec2
     2048  else
     2049  if (ec2.alpha = 0) then
     2050    Result := ec1
     2051  else
     2052  begin
     2053    c12 := ec1.alpha + ec2.alpha;
     2054    Result.red   := (int64(ec1.red) * ec1.alpha + int64(ec2.red) * ec2.alpha + c12 shr 1) div c12;
     2055    Result.green := (int64(ec1.green) * ec1.alpha + int64(ec2.green) * ec2.alpha + c12 shr 1) div c12;
     2056    Result.blue  := (int64(ec1.blue) * ec1.alpha + int64(ec2.blue) * ec2.alpha + c12 shr 1) div c12;
     2057    Result.alpha := (c12 + 1) shr 1;
    4482058  end;
    4492059end;
     
    4652075end;
    4662076
     2077{ Convert a TColor value to a TBGRAPixel value. Note that
     2078  you need to call ColorToRGB first if you use a system
     2079  color identifier like clWindow. }
    4672080{$PUSH}{$R-}
    4682081function ColorToBGRA(color: TColor): TBGRAPixel; overload;
     
    4832096{$POP}
    4842097
    485 {$hints off}
     2098{ Conversion from TFPColor to TBGRAPixel assuming TFPColor
     2099  is already gamma compressed }
     2100function FPColorToBGRA(AValue: TFPColor): TBGRAPixel;
     2101begin
     2102  with AValue do
     2103    Result := BGRA(red shr 8, green shr 8, blue shr 8, alpha shr 8);
     2104end;
     2105
     2106function BGRAToFPColor(AValue: TBGRAPixel): TFPColor; inline;
     2107begin
     2108  result.red := AValue.red shl 8 + AValue.red;
     2109  result.green := AValue.green shl 8 + AValue.green;
     2110  result.blue := AValue.blue shl 8 + AValue.blue;
     2111  result.alpha := AValue.alpha shl 8 + AValue.alpha;
     2112end;
     2113
    4862114function BGRAToColor(c: TBGRAPixel): TColor;
    4872115begin
    4882116  Result := c.red + (c.green shl 8) + (c.blue shl 16);
    4892117end;
    490 
    491 {$hints on}
    4922118
    4932119operator = (const c1, c2: TBGRAPixel): boolean;
     
    5002126end;
    5012127
    502 function BGRADiff(c1, c2: TBGRAPixel): byte;
     2128function LessStartSlope65535(value: word): word;
     2129var factor: word;
     2130begin
     2131  factor := 4096 - (not value)*3 shr 7;
     2132  result := value*factor shr 12;
     2133end;
     2134
     2135function ExpandedDiff(ec1, ec2: TExpandedPixel): word;
    5032136var
    5042137  CompRedAlpha1, CompGreenAlpha1, CompBlueAlpha1, CompRedAlpha2,
    5052138  CompGreenAlpha2, CompBlueAlpha2: integer;
    506   DiffAlpha: byte;
    507 begin
    508     {$hints off}
    509   CompRedAlpha1 := c1.red * c1.alpha;
    510   CompGreenAlpha1 := c1.green * c1.alpha;
    511   CompBlueAlpha1 := c1.blue * c1.alpha;
    512   CompRedAlpha2 := c2.red * c2.alpha;
    513   CompGreenAlpha2 := c2.green * c2.alpha;
    514   CompBlueAlpha2 := c2.blue * c2.alpha;
    515     {$hints on}
    516   Result    := (Abs(CompRedAlpha2 - CompRedAlpha1) +
    517     Abs(CompBlueAlpha2 - CompBlueAlpha1) + Abs(CompGreenAlpha2 - CompGreenAlpha1)) div
    518     (3 * 255);
    519   DiffAlpha := Abs(c2.Alpha - c1.Alpha) * 3 shr 2;
     2139  DiffAlpha: word;
     2140  ColorDiff: word;
     2141  TempHueDiff: word;
     2142begin
     2143  CompRedAlpha1 := ec1.red * ec1.alpha shr 16; //gives 0..65535
     2144  CompGreenAlpha1 := ec1.green * ec1.alpha shr 16;
     2145  CompBlueAlpha1 := ec1.blue * ec1.alpha shr 16;
     2146  CompRedAlpha2 := ec2.red * ec2.alpha shr 16;
     2147  CompGreenAlpha2 := ec2.green * ec2.alpha shr 16;
     2148  CompBlueAlpha2 := ec2.blue * ec2.alpha shr 16;
     2149  Result    := (Abs(CompRedAlpha2 - CompRedAlpha1)*redWeightShl10 +
     2150    Abs(CompBlueAlpha2 - CompBlueAlpha1)*blueWeightShl10 +
     2151    Abs(CompGreenAlpha2 - CompGreenAlpha1)*greenWeightShl10) shr 10;
     2152  ColorDiff := min(ColorImportance(ec1),ColorImportance(ec2));
     2153  if ColorDiff > 0 then
     2154  begin
     2155    TempHueDiff := HueDiff(HtoG(GetHue(ec1)),HtoG(GetHue(ec2)));
     2156    if TempHueDiff < 32768 then
     2157      TempHueDiff := LessStartSlope65535(TempHueDiff shl 1) shr 4
     2158    else
     2159      TempHueDiff := TempHueDiff shr 3;
     2160    Result := ((Result shr 4)* (not ColorDiff) + TempHueDiff*ColorDiff) shr 12;
     2161  end;
     2162  DiffAlpha := Abs(integer(ec2.Alpha) - integer(ec1.Alpha));
    5202163  if DiffAlpha > Result then
    5212164    Result := DiffAlpha;
    5222165end;
    5232166
     2167function BGRAWordDiff(c1, c2: TBGRAPixel): word;
     2168begin
     2169  result := ExpandedDiff(GammaExpansion(c1),GammaExpansion(c2));
     2170end;
     2171
     2172function BGRADiff(c1,c2: TBGRAPixel): byte;
     2173begin
     2174  result := ExpandedDiff(GammaExpansion(c1),GammaExpansion(c2)) shr 8;
     2175end;
     2176
     2177operator-(const c1, c2: TColorF): TColorF;
     2178begin
     2179  result[1] := c1[1]-c2[1];
     2180  result[2] := c1[2]-c2[2];
     2181  result[3] := c1[3]-c2[3];
     2182  result[4] := c1[4]-c2[4];
     2183end;
     2184
     2185operator+(const c1, c2: TColorF): TColorF;
     2186begin
     2187  result[1] := c1[1]+c2[1];
     2188  result[2] := c1[2]+c2[2];
     2189  result[3] := c1[3]+c2[3];
     2190  result[4] := c1[4]+c2[4];
     2191end;
     2192
     2193operator*(const c1, c2: TColorF): TColorF;
     2194begin
     2195  result[1] := c1[1]*c2[1];
     2196  result[2] := c1[2]*c2[2];
     2197  result[3] := c1[3]*c2[3];
     2198  result[4] := c1[4]*c2[4];
     2199end;
     2200
     2201operator*(const c1: TColorF; factor: single): TColorF;
     2202begin
     2203  result[1] := c1[1]*factor;
     2204  result[2] := c1[2]*factor;
     2205  result[3] := c1[3]*factor;
     2206  result[4] := c1[4]*factor;
     2207end;
     2208
     2209function ColorF(red, green, blue, alpha: single): TColorF;
     2210begin
     2211  result[1] := red;
     2212  result[2] := green;
     2213  result[3] := blue;
     2214  result[4] := alpha;
     2215end;
     2216
     2217{ Write a color in hexadecimal format RRGGBBAA }
     2218function BGRAToStr(c: TBGRAPixel): string;
     2219begin
     2220  result := IntToHex(c.red,2)+IntToHex(c.green,2)+IntToHex(c.Blue,2)+IntToHex(c.Alpha,2);
     2221end;
     2222
     2223type
     2224    arrayOfString = array of string;
     2225
     2226function SimpleParseFuncParam(str: string): arrayOfString;
     2227var idxOpen,start,cur: integer;
     2228begin
     2229    result := nil;
     2230    idxOpen := pos('(',str);
     2231    if idxOpen = 0 then exit;
     2232    start := idxOpen+1;
     2233    cur := start;
     2234    while cur <= length(str) do
     2235    begin
     2236       if str[cur] in[',',')'] then
     2237       begin
     2238         setlength(result,length(result)+1);
     2239         result[high(result)] := copy(str,start,cur-start);
     2240         start := cur+1;
     2241       end;
     2242       inc(cur);
     2243    end;
     2244    if start <= length(str) then
     2245    begin
     2246      setlength(result,length(result)+1);
     2247      result[high(result)] := copy(str,start,length(str)-start+1);
     2248    end;
     2249end;
     2250
     2251function ParseColorValue(str: string): byte;
     2252var pourcent,unclipped,errPos: integer;
     2253begin
     2254  if str = '' then result := 0 else
     2255  begin
     2256    if str[length(str)]='%' then
     2257    begin
     2258      val(copy(str,1,length(str)-1),pourcent,errPos);
     2259      if pourcent < 0 then result := 0 else
     2260      if pourcent > 100 then result := 255 else
     2261        result := pourcent*255 div 100;
     2262    end else
     2263    begin
     2264      val(str,unclipped,errPos);
     2265      if unclipped < 0 then result := 0 else
     2266      if unclipped > 255 then result := 255 else
     2267        result := unclipped;
     2268    end;
     2269  end;
     2270end;
     2271
     2272{ Read a color in hexadecimal format RRGGBB(AA) or RGB(A) }
     2273function StrToBGRA(str: string): TBGRAPixel;
     2274var errPos: integer;
     2275    values: array of string;
     2276    alphaF: single;
     2277    idx: integer;
     2278begin
     2279  if str = '' then
     2280  begin
     2281    result := BGRAPixelTransparent;
     2282    exit;
     2283  end;
     2284  str := lowerCase(str);
     2285
     2286  //VGA color names
     2287  if str='black' then result := BGRA(0,0,0) else
     2288  if str='silver' then result := BGRA(192,192,192) else
     2289  if str='gray' then result := BGRA(128,128,128) else
     2290  if str='white' then result := BGRA(255,255,255) else
     2291  if str='maroon' then result := BGRA(128,0,0) else
     2292  if str='red' then result := BGRA(255,0,0) else
     2293  if str='purple' then result := BGRA(128,0,128) else
     2294  if str='fuchsia' then result := BGRA(255,0,255) else
     2295  if str='green' then result := BGRA(0,128,0) else
     2296  if str='lime' then result := BGRA(0,255,0) else
     2297  if str='olive' then result := BGRA(128,128,0) else
     2298  if str='yellow' then result := BGRA(255,255,0) else
     2299  if str='navy' then result := BGRA(0,0,128) else
     2300  if str='blue' then result := BGRA(0,0,255) else
     2301  if str='teal' then result := BGRA(0,128,128) else
     2302  if str='aqua' then result := BGRA(0,255,255) else
     2303  if str='transparent' then result := BGRAPixelTransparent else
     2304  begin
     2305    //check CSS color
     2306    idx := CSSColors.IndexOf(str);
     2307    if idx <> -1 then
     2308    begin
     2309      result := CSSColors[idx];
     2310      exit;
     2311    end;
     2312
     2313    //CSS RGB notation
     2314    if (copy(str,1,4)='rgb(') or (copy(str,1,5)='rgba(') then
     2315    begin
     2316      values := SimpleParseFuncParam(str);
     2317      if (length(values)=3) or (length(values)=4) then
     2318      begin
     2319        result.red := ParseColorValue(values[0]);
     2320        result.green := ParseColorValue(values[1]);
     2321        result.blue := ParseColorValue(values[2]);
     2322        if length(values)=4 then
     2323        begin
     2324          val(values[3],alphaF,errPos);
     2325          if alphaF < 0 then
     2326            result.alpha := 0 else
     2327          if alphaF > 1 then
     2328            result.alpha := 255
     2329          else
     2330            result.alpha := round(alphaF*255);
     2331        end else
     2332          result.alpha := 255;
     2333      end else
     2334        result := BGRAPixelTransparent;
     2335      exit;
     2336    end;
     2337
     2338    //remove HTML notation header
     2339    if str[1]='#' then delete(str,1,1);
     2340
     2341    //add alpha if missing
     2342    if length(str)=6 then str += 'FF';
     2343    if length(str)=3 then str += 'F';
     2344
     2345    //hex notation
     2346    if length(str)=8 then
     2347    begin
     2348      val('$'+copy(str,1,2),result.red,errPos);
     2349      val('$'+copy(str,3,2),result.green,errPos);
     2350      val('$'+copy(str,5,2),result.blue,errPos);
     2351      val('$'+copy(str,7,2),result.alpha,errPos);
     2352    end else
     2353    if length(str)=4 then
     2354    begin
     2355      val('$'+copy(str,1,1),result.red,errPos);
     2356      val('$'+copy(str,2,1),result.green,errPos);
     2357      val('$'+copy(str,3,1),result.blue,errPos);
     2358      val('$'+copy(str,4,1),result.alpha,errPos);
     2359      result.red *= $11;
     2360      result.green *= $11;
     2361      result.blue *= $11;
     2362      result.alpha *= $11;
     2363    end else
     2364      result := BGRAPixelTransparent;
     2365  end;
     2366
     2367end;
     2368
     2369
     2370function MapHeight(Color: TBGRAPixel): Single;
     2371var intval: integer;
     2372begin
     2373  intval := color.Green shl 16 + color.red shl 8 + color.blue;
     2374  result := intval/16777215;
     2375end;
     2376
     2377function MapHeightToBGRA(Height: Single; Alpha: Byte): TBGRAPixel;
     2378var intval: integer;
     2379begin
     2380  if Height >= 1 then result := BGRA(255,255,255,alpha) else
     2381  if Height <= 0 then result := BGRA(0,0,0,alpha) else
     2382  begin
     2383    intval := round(Height*16777215);
     2384    result := BGRA(intval shr 8,intval shr 16,intval,alpha);
     2385  end;
     2386end;
     2387
     2388{********************** Point functions **************************}
     2389
    5242390function PointF(x, y: single): TPointF;
    5252391begin
    5262392  Result.x := x;
    5272393  Result.y := y;
     2394end;
     2395
     2396function PointsF(const pts: array of TPointF): ArrayOfTPointF;
     2397var
     2398  i: Integer;
     2399begin
     2400  setlength(result, length(pts));
     2401  for i := 0 to high(pts) do result[i] := pts[i];
     2402end;
     2403
     2404operator =(const pt1, pt2: TPointF): boolean;
     2405begin
     2406  result := (pt1.x = pt2.x) and (pt1.y = pt2.y);
     2407end;
     2408
     2409operator-(const pt1, pt2: TPointF): TPointF;
     2410begin
     2411  result.x := pt1.x-pt2.x;
     2412  result.y := pt1.y-pt2.y;
     2413end;
     2414
     2415operator-(const pt2: TPointF): TPointF;
     2416begin
     2417  result.x := -pt2.x;
     2418  result.y := -pt2.y;
     2419end;
     2420
     2421operator+(const pt1, pt2: TPointF): TPointF;
     2422begin
     2423  result.x := pt1.x+pt2.x;
     2424  result.y := pt1.y+pt2.y;
     2425end;
     2426
     2427operator*(const pt1, pt2: TPointF): single;
     2428begin
     2429  result := pt1.x*pt2.x + pt1.y*pt2.y;
     2430end;
     2431
     2432operator*(const pt1: TPointF; factor: single): TPointF;
     2433begin
     2434  result.x := pt1.x*factor;
     2435  result.y := pt1.y*factor;
     2436end;
     2437
     2438operator*(factor: single; const pt1: TPointF): TPointF;
     2439begin
     2440  result.x := pt1.x*factor;
     2441  result.y := pt1.y*factor;
    5282442end;
    5292443
     
    5482462end;
    5492463
    550 function StrToGradientType(str: string): TGradientType;
    551 var gt: TGradientType;
    552 begin
    553   result := gtLinear;
    554   str := LowerCase(str);
    555   for gt := low(TGradientType) to high(TGradientType) do
    556     if str = LowerCase(GradientTypeStr[gt]) then
     2464function VectLen(dx, dy: single): single;
     2465begin
     2466  result := sqrt(dx*dx+dy*dy);
     2467end;
     2468
     2469function VectLen(v: TPointF): single;
     2470begin
     2471  result := sqrt(v.x*v.x+v.y*v.y);
     2472end;
     2473
     2474function IntersectLine(line1, line2: TLineDef): TPointF;
     2475var parallel: boolean;
     2476begin
     2477  result := IntersectLine(line1,line2,parallel);
     2478end;
     2479
     2480function IntersectLine(line1, line2: TLineDef; out parallel: boolean): TPointF;
     2481var divFactor: double;
     2482begin
     2483  parallel := false;
     2484  //if lines are parallel
     2485  if ((line1.dir.x = line2.dir.x) and (line1.dir.y = line2.dir.y)) or
     2486     ((abs(line1.dir.y) < 1e-6) and (abs(line2.dir.y) < 1e-6)) then
     2487  begin
     2488       parallel := true;
     2489       //return the center of the segment between line origins
     2490       result.x := (line1.origin.x+line2.origin.x)/2;
     2491       result.y := (line1.origin.y+line2.origin.y)/2;
     2492  end else
     2493  if abs(line1.dir.y) < 1e-6 then //line1 is horizontal
     2494  begin
     2495       result.y := line1.origin.y;
     2496       result.x := line2.origin.x + (result.y - line2.origin.y)
     2497               /line2.dir.y*line2.dir.x;
     2498  end else
     2499  if abs(line2.dir.y) < 1e-6 then //line2 is horizontal
     2500  begin
     2501       result.y := line2.origin.y;
     2502       result.x := line1.origin.x + (result.y - line1.origin.y)
     2503               /line1.dir.y*line1.dir.x;
     2504  end else
     2505  begin
     2506       divFactor := line1.dir.x/line1.dir.y - line2.dir.x/line2.dir.y;
     2507       if abs(divFactor) < 1e-6 then //almost parallel
     2508       begin
     2509            parallel := true;
     2510            //return the center of the segment between line origins
     2511            result.x := (line1.origin.x+line2.origin.x)/2;
     2512            result.y := (line1.origin.y+line2.origin.y)/2;
     2513       end else
     2514       begin
     2515         result.y := (line2.origin.x - line1.origin.x +
     2516                  line1.origin.y*line1.dir.x/line1.dir.y -
     2517                  line2.origin.y*line2.dir.x/line2.dir.y)
     2518                  / divFactor;
     2519         result.x := line1.origin.x + (result.y - line1.origin.y)
     2520                 /line1.dir.y*line1.dir.x;
     2521       end;
     2522  end;
     2523end;
     2524
     2525{ Check if a polygon is convex, i.e. it always turns in the same direction }
     2526function IsConvex(const pts: array of TPointF; IgnoreAlign: boolean = true): boolean;
     2527var
     2528  positive,negative,zero: boolean;
     2529  product: single;
     2530  i: Integer;
     2531begin
     2532  positive := false;
     2533  negative := false;
     2534  zero := false;
     2535  for i := 0 to high(pts) do
     2536  begin
     2537    product := (pts[(i+1) mod length(pts)].x-pts[i].x)*(pts[(i+2) mod length(pts)].y-pts[i].y) -
     2538               (pts[(i+1) mod length(pts)].y-pts[i].y)*(pts[(i+2) mod length(pts)].x-pts[i].x);
     2539    if product > 0 then
    5572540    begin
    558       result := gt;
    559       exit;
     2541      if negative then
     2542      begin
     2543        result := false;
     2544        exit;
     2545      end;
     2546      positive := true;
     2547    end else
     2548    if product < 0 then
     2549    begin
     2550      if positive then
     2551      begin
     2552        result := false;
     2553        exit;
     2554      end;
     2555      negative := true;
     2556    end else
     2557      zero := true;
     2558  end;
     2559  if not IgnoreAlign and zero then
     2560    result := false
     2561  else
     2562    result := true;
     2563end;
     2564
     2565{ Check if two segments intersect }
     2566function DoesSegmentIntersect(pt1,pt2,pt3,pt4: TPointF): boolean;
     2567var
     2568  seg1: TLineDef;
     2569  seg1len: single;
     2570  seg2: TLineDef;
     2571  seg2len: single;
     2572  inter: TPointF;
     2573  pos1,pos2: single;
     2574  para: boolean;
     2575
     2576begin
     2577  { Determine line definitions }
     2578  seg1.origin := pt1;
     2579  seg1.dir := pt2-pt1;
     2580  seg1len := sqrt(sqr(seg1.dir.X)+sqr(seg1.dir.Y));
     2581  if seg1len = 0 then
     2582  begin
     2583    result := false;
     2584    exit;
     2585  end;
     2586  seg1.dir *= 1/seg1len;
     2587
     2588  seg2.origin := pt3;
     2589  seg2.dir := pt4-pt3;
     2590  seg2len := sqrt(sqr(seg2.dir.X)+sqr(seg2.dir.Y));
     2591  if seg2len = 0 then
     2592  begin
     2593    result := false;
     2594    exit;
     2595  end;
     2596  seg2.dir *= 1/seg2len;
     2597
     2598  //obviously parallel
     2599  if seg1.dir = seg2.dir then
     2600    result := false
     2601  else
     2602  begin
     2603    //try to compute intersection
     2604    inter := IntersectLine(seg1,seg2,para);
     2605    if para then
     2606      result := false
     2607    else
     2608    begin
     2609      //check if intersections are inside the segments
     2610      pos1 := (inter-seg1.origin)*seg1.dir;
     2611      pos2 := (inter-seg2.origin)*seg2.dir;
     2612      if (pos1 >= 0) and (pos1 <= seg1len) and
     2613         (pos2 >= 0) and (pos2 <= seg2len) then
     2614        result := true
     2615      else
     2616        result := false;
    5602617    end;
    561 end;
    562 
    563 function BGRAToStr(c: TBGRAPixel): string;
    564 begin
    565   result := IntToHex(c.red,2)+IntToHex(c.green,2)+IntToHex(c.Blue,2)+IntToHex(c.Alpha,2);
    566 end;
    567 
    568 {$hints off}
    569 {$notes off}
    570 function StrToBGRA(str: string): TBGRAPixel;
    571 var errPos: integer;
    572 begin
    573   if length(str)=6 then str += 'FF';
    574   if length(str)=3 then str += 'F';
    575   if length(str)=8 then
    576   begin
    577     val('$'+copy(str,1,2),result.red,errPos);
    578     val('$'+copy(str,3,2),result.green,errPos);
    579     val('$'+copy(str,5,2),result.blue,errPos);
    580     val('$'+copy(str,7,2),result.alpha,errPos);
     2618  end;
     2619end;
     2620
     2621{ Check if a quaduadrilateral intersects itself }
     2622function DoesQuadIntersect(pt1,pt2,pt3,pt4: TPointF): boolean;
     2623begin
     2624  result := DoesSegmentIntersect(pt1,pt2,pt3,pt4) or DoesSegmentIntersect(pt2,pt3,pt4,pt1);
     2625end;
     2626
     2627{************************** Cyclic functions *******************}
     2628
     2629// Get the cyclic value in the range [0..cycle-1]
     2630function PositiveMod(value, cycle: integer): integer; inline;
     2631begin
     2632  result := value mod cycle;
     2633  if result < 0 then //modulo can be negative
     2634    Inc(result, cycle);
     2635end;
     2636
     2637{ Table of precalc values. Note : the value is stored for
     2638  the first half of the cycle, and values are stored 'minus 1'
     2639  in order to stay in the range 0..65535 }
     2640var
     2641  sinTab65536: packed array of word;
     2642
     2643function Sin65536(value: word): integer;
     2644var b: integer;
     2645begin
     2646  //allocate array
     2647  if sinTab65536 = nil then
     2648    setlength(sinTab65536,32768);
     2649
     2650  if value >= 32768 then //function is upside down after half-period
     2651  begin
     2652    b := value xor 32768;
     2653    if sinTab65536[b] = 0 then //precalc
     2654      sinTab65536[b] := round((sin(b*2*Pi/65536)+1)*65536/2)-1;
     2655    result := not sinTab65536[b];
    5812656  end else
    582   if length(str)=4 then
    583   begin
    584     val('$'+copy(str,1,1),result.red,errPos);
    585     val('$'+copy(str,2,1),result.green,errPos);
    586     val('$'+copy(str,3,1),result.blue,errPos);
    587     val('$'+copy(str,4,1),result.alpha,errPos);
    588     result.red *= $11;
    589     result.green *= $11;
    590     result.blue *= $11;
    591     result.alpha *= $11;
    592   end else
    593     result := BGRAPixelTransparent;
    594 end;
    595 {$notes on}
    596 {$hints on}
     2657  begin
     2658    b := value;
     2659    if sinTab65536[b] = 0 then //precalc
     2660      sinTab65536[b] := round((sin(b*2*Pi/65536)+1)*65536/2)-1;
     2661    {$hints off}
     2662    result := sinTab65536[b]+1;
     2663    {$hints on}
     2664  end;
     2665end;
     2666
     2667function Cos65536(value: word): integer;
     2668begin
     2669  result := Sin65536(value+16384); //cosine is translated
     2670end;
     2671
     2672procedure PrecalcSin65536;
     2673var
     2674  i: Integer;
     2675begin
     2676  for i := 0 to 32767 do Sin65536(i);
     2677end;
    5972678
    5982679initialization
    5992680
    6002681  InitGamma;
     2682  CSSColors := TBGRAColorList.Create;
     2683  CSSColors.Add('AliceBlue',CSSAliceBlue);
     2684  CSSColors.Add('AntiqueWhite',CSSAntiqueWhite);
     2685  CSSColors.Add('Aqua',CSSAqua);
     2686  CSSColors.Add('Aquamarine',CSSAquamarine);
     2687  CSSColors.Add('Azure',CSSAzure);
     2688  CSSColors.Add('Beige',CSSBeige);
     2689  CSSColors.Add('Bisque',CSSBisque);
     2690  CSSColors.Add('Black',CSSBlack);
     2691  CSSColors.Add('BlanchedAlmond',CSSBlanchedAlmond);
     2692  CSSColors.Add('Blue',CSSBlue);
     2693  CSSColors.Add('BlueViolet',CSSBlueViolet);
     2694  CSSColors.Add('Brown',CSSBrown);
     2695  CSSColors.Add('BurlyWood',CSSBurlyWood);
     2696  CSSColors.Add('CadetBlue',CSSCadetBlue);
     2697  CSSColors.Add('Chartreuse',CSSChartreuse);
     2698  CSSColors.Add('Chocolate',CSSChocolate);
     2699  CSSColors.Add('Coral',CSSCoral);
     2700  CSSColors.Add('CornflowerBlue',CSSCornflowerBlue);
     2701  CSSColors.Add('Cornsilk',CSSCornsilk);
     2702  CSSColors.Add('Crimson',CSSCrimson);
     2703  CSSColors.Add('Cyan',CSSCyan);
     2704  CSSColors.Add('DarkBlue',CSSDarkBlue);
     2705  CSSColors.Add('DarkCyan',CSSDarkCyan);
     2706  CSSColors.Add('DarkGoldenrod',CSSDarkGoldenrod);
     2707  CSSColors.Add('DarkGray',CSSDarkGray);
     2708  CSSColors.Add('DarkGreen',CSSDarkGreen);
     2709  CSSColors.Add('DarkKhaki',CSSDarkKhaki);
     2710  CSSColors.Add('DarkMagenta',CSSDarkMagenta);
     2711  CSSColors.Add('DarkOliveGreen',CSSDarkOliveGreen);
     2712  CSSColors.Add('DarkOrange',CSSDarkOrange);
     2713  CSSColors.Add('DarkOrchid',CSSDarkOrchid);
     2714  CSSColors.Add('DarkRed',CSSDarkRed);
     2715  CSSColors.Add('DarkSalmon',CSSDarkSalmon);
     2716  CSSColors.Add('DarkSeaGreen',CSSDarkSeaGreen);
     2717  CSSColors.Add('DarkSlateBlue',CSSDarkSlateBlue);
     2718  CSSColors.Add('DarkSlateGray',CSSDarkSlateGray);
     2719  CSSColors.Add('DarkTurquoise',CSSDarkTurquoise);
     2720  CSSColors.Add('DarkViolet',CSSDarkViolet);
     2721  CSSColors.Add('DeepPink',CSSDeepPink);
     2722  CSSColors.Add('DeepSkyBlue',CSSDeepSkyBlue);
     2723  CSSColors.Add('DimGray',CSSDimGray);
     2724  CSSColors.Add('DodgerBlue',CSSDodgerBlue);
     2725  CSSColors.Add('FireBrick',CSSFireBrick);
     2726  CSSColors.Add('FloralWhite',CSSFloralWhite);
     2727  CSSColors.Add('ForestGreen',CSSForestGreen);
     2728  CSSColors.Add('Fuchsia',CSSFuchsia);
     2729  CSSColors.Add('Gainsboro',CSSGainsboro);
     2730  CSSColors.Add('GhostWhite',CSSGhostWhite);
     2731  CSSColors.Add('Gold',CSSGold);
     2732  CSSColors.Add('Goldenrod',CSSGoldenrod);
     2733  CSSColors.Add('Gray',CSSGray);
     2734  CSSColors.Add('Green',CSSGreen);
     2735  CSSColors.Add('GreenYellow',CSSGreenYellow);
     2736  CSSColors.Add('Honeydew',CSSHoneydew);
     2737  CSSColors.Add('HotPink',CSSHotPink);
     2738  CSSColors.Add('IndianRed',CSSIndianRed);
     2739  CSSColors.Add('Indigo',CSSIndigo);
     2740  CSSColors.Add('Ivory',CSSIvory);
     2741  CSSColors.Add('Khaki',CSSKhaki);
     2742  CSSColors.Add('Lavender',CSSLavender);
     2743  CSSColors.Add('LavenderBlush',CSSLavenderBlush);
     2744  CSSColors.Add('LawnGreen',CSSLawnGreen);
     2745  CSSColors.Add('LemonChiffon',CSSLemonChiffon);
     2746  CSSColors.Add('LightBlue',CSSLightBlue);
     2747  CSSColors.Add('LightCoral',CSSLightCoral);
     2748  CSSColors.Add('LightCyan',CSSLightCyan);
     2749  CSSColors.Add('LightGoldenrodYellow',CSSLightGoldenrodYellow);
     2750  CSSColors.Add('LightGray',CSSLightGray);
     2751  CSSColors.Add('LightGreen',CSSLightGreen);
     2752  CSSColors.Add('LightPink',CSSLightPink);
     2753  CSSColors.Add('LightSalmon',CSSLightSalmon);
     2754  CSSColors.Add('LightSeaGreen',CSSLightSeaGreen);
     2755  CSSColors.Add('LightSkyBlue',CSSLightSkyBlue);
     2756  CSSColors.Add('LightSlateGray',CSSLightSlateGray);
     2757  CSSColors.Add('LightSteelBlue',CSSLightSteelBlue);
     2758  CSSColors.Add('LightYellow',CSSLightYellow);
     2759  CSSColors.Add('Lime',CSSLime);
     2760  CSSColors.Add('LimeGreen',CSSLimeGreen);
     2761  CSSColors.Add('Linen',CSSLinen);
     2762  CSSColors.Add('Magenta',CSSMagenta);
     2763  CSSColors.Add('Maroon',CSSMaroon);
     2764  CSSColors.Add('MediumAquamarine',CSSMediumAquamarine);
     2765  CSSColors.Add('MediumBlue',CSSMediumBlue);
     2766  CSSColors.Add('MediumOrchid',CSSMediumOrchid);
     2767  CSSColors.Add('MediumPurple',CSSMediumPurple);
     2768  CSSColors.Add('MediumSeaGreen',CSSMediumSeaGreen);
     2769  CSSColors.Add('MediumSlateBlue',CSSMediumSlateBlue);
     2770  CSSColors.Add('MediumSpringGreen',CSSMediumSpringGreen);
     2771  CSSColors.Add('MediumTurquoise',CSSMediumTurquoise);
     2772  CSSColors.Add('MediumVioletRed',CSSMediumVioletRed);
     2773  CSSColors.Add('MidnightBlue',CSSMidnightBlue);
     2774  CSSColors.Add('MintCream',CSSMintCream);
     2775  CSSColors.Add('MistyRose',CSSMistyRose);
     2776  CSSColors.Add('Moccasin',CSSMoccasin);
     2777  CSSColors.Add('NavajoWhite',CSSNavajoWhite);
     2778  CSSColors.Add('Navy',CSSNavy);
     2779  CSSColors.Add('OldLace',CSSOldLace);
     2780  CSSColors.Add('Olive',CSSOlive);
     2781  CSSColors.Add('OliveDrab',CSSOliveDrab);
     2782  CSSColors.Add('Orange',CSSOrange);
     2783  CSSColors.Add('OrangeRed',CSSOrangeRed);
     2784  CSSColors.Add('Orchid',CSSOrchid);
     2785  CSSColors.Add('PaleGoldenrod',CSSPaleGoldenrod);
     2786  CSSColors.Add('PaleGreen',CSSPaleGreen);
     2787  CSSColors.Add('PaleTurquoise',CSSPaleTurquoise);
     2788  CSSColors.Add('PaleVioletRed',CSSPaleVioletRed);
     2789  CSSColors.Add('PapayaWhip',CSSPapayaWhip);
     2790  CSSColors.Add('PeachPuff',CSSPeachPuff);
     2791  CSSColors.Add('Peru',CSSPeru);
     2792  CSSColors.Add('Pink',CSSPink);
     2793  CSSColors.Add('Plum',CSSPlum);
     2794  CSSColors.Add('PowderBlue',CSSPowderBlue);
     2795  CSSColors.Add('Purple',CSSPurple);
     2796  CSSColors.Add('Red',CSSRed);
     2797  CSSColors.Add('RosyBrown',CSSRosyBrown);
     2798  CSSColors.Add('RoyalBlue',CSSRoyalBlue);
     2799  CSSColors.Add('SaddleBrown',CSSSaddleBrown);
     2800  CSSColors.Add('Salmon',CSSSalmon);
     2801  CSSColors.Add('SandyBrown',CSSSandyBrown);
     2802  CSSColors.Add('SeaGreen',CSSSeaGreen);
     2803  CSSColors.Add('Seashell',CSSSeashell);
     2804  CSSColors.Add('Sienna',CSSSienna);
     2805  CSSColors.Add('Silver',CSSSilver);
     2806  CSSColors.Add('SkyBlue',CSSSkyBlue);
     2807  CSSColors.Add('SlateBlue',CSSSlateBlue);
     2808  CSSColors.Add('SlateGray',CSSSlateGray);
     2809  CSSColors.Add('Snow',CSSSnow);
     2810  CSSColors.Add('SpringGreen',CSSSpringGreen);
     2811  CSSColors.Add('SteelBlue',CSSSteelBlue);
     2812  CSSColors.Add('Tan',CSSTan);
     2813  CSSColors.Add('Teal',CSSTeal);
     2814  CSSColors.Add('Thistle',CSSThistle);
     2815  CSSColors.Add('Tomato',CSSTomato);
     2816  CSSColors.Add('Turquoise',CSSTurquoise);
     2817  CSSColors.Add('Violet',CSSViolet);
     2818  CSSColors.Add('Wheat',CSSWheat);
     2819  CSSColors.Add('White',CSSWhite);
     2820  CSSColors.Add('WhiteSmoke',CSSWhiteSmoke);
     2821  CSSColors.Add('Yellow',CSSYellow);
     2822  CSSColors.Add('YellowGreen',CSSYellowGreen);
     2823  CSSColors.Finished;
     2824
     2825finalization
     2826
     2827  CSSColors.Free;
    6012828
    6022829end.
    603 
  • GraphicTest/BGRABitmap/bgrablend.pas

    r210 r317  
    11unit BGRABlend;
     2
     3{ This unit contains pixel blending functions. They take a destination adress as parameter,
     4  and draw pixels at this address with different blending modes. These functions are used
     5  by many functions in BGRABitmap library to do the low level drawing. }
    26
    37{$mode objfpc}{$H+}
     
    812  Classes, SysUtils, BGRABitmapTypes;
    913
     14{ Draw one pixel with alpha blending }
     15procedure DrawPixelInlineWithAlphaCheck(dest: PBGRAPixel; const c: TBGRAPixel); inline; overload;
     16procedure DrawPixelInlineWithAlphaCheck(dest: PBGRAPixel; c: TBGRAPixel; appliedOpacity: byte); inline; overload;
     17procedure DrawExpandedPixelInlineWithAlphaCheck(dest: PBGRAPixel; const ec: TExpandedPixel); inline; overload;
     18procedure DrawPixelInlineExpandedOrNotWithAlphaCheck(dest: PBGRAPixel; const ec: TExpandedPixel; c: TBGRAPixel); inline; overload;  //alpha in 'c' parameter
     19procedure DrawPixelInlineNoAlphaCheck(dest: PBGRAPixel; const c: TBGRAPixel); inline; overload;
     20procedure DrawExpandedPixelInlineNoAlphaCheck(dest: PBGRAPixel; const ec: TExpandedPixel; calpha: byte); inline; overload;
     21
     22procedure CopyPixelsWithOpacity(dest,src: PBGRAPixel; opacity: byte; Count: integer); inline;
     23function ApplyOpacity(opacity1,opacity2: byte): byte; inline;
     24function FastRoundDiv255(value: cardinal): cardinal; inline;
     25
     26{ Draw a series of pixels with alpha blending }
     27procedure DrawPixelsInline(dest: PBGRAPixel; c: TBGRAPixel; Count: integer); inline; overload;
     28procedure DrawExpandedPixelsInline(dest: PBGRAPixel; ec: TExpandedPixel; Count: integer); inline; overload;
     29procedure DrawPixelsInlineExpandedOrNot(dest: PBGRAPixel; ec: TExpandedPixel; c: TBGRAPixel; Count: integer); inline; overload;  //alpha in 'c' parameter
     30
     31{ Draw one pixel with linear alpha blending }
     32procedure FastBlendPixelInline(dest: PBGRAPixel; const c: TBGRAPixel); inline; overload;
     33procedure FastBlendPixelInline(dest: PBGRAPixel; c: TBGRAPixel; appliedOpacity: byte); inline; overload;
     34
     35{ Draw a series of pixels with linear alpha blending }
     36procedure FastBlendPixelsInline(dest: PBGRAPixel; c: TBGRAPixel; Count: integer); inline;
     37
     38{ Replace a series of pixels }
     39procedure FillInline(dest: PBGRAPixel; c: TBGRAPixel; Count: integer); inline;
     40
     41{ Xor a series of pixels }
     42procedure XorInline(dest: PBGRAPixel; c: TBGRAPixel; Count: integer); inline;
     43procedure XorPixels(pdest, psrc: PBGRAPixel; count: integer);
     44
     45{ Set alpha value for a series of pixels }
     46procedure AlphaFillInline(dest: PBGRAPixel; alpha: byte; Count: integer); inline;
     47
     48{ Erase a series of pixels, i.e. decrease alpha value }
     49procedure ErasePixelInline(dest: PBGRAPixel; alpha: byte); inline;
     50
     51{ Draw a pixel to the extent the current pixel is close enough to compare value.
     52  It should not be called on pixels that have not been checked to be close enough }
     53procedure DrawPixelInlineDiff(dest: PBGRAPixel; c, compare: TBGRAPixel;
     54  maxDiff: byte); inline;
     55{ Draw a series of pixel to the extent the current pixel is close enough to compare value }
     56procedure DrawPixelsInlineDiff(dest: PBGRAPixel; c: TBGRAPixel;
     57  Count: integer; compare: TBGRAPixel; maxDiff: byte); inline;
     58
     59{ Blend pixels with scanner content }
     60procedure ScannerPutPixels(scan: IBGRAScanner; pdest: PBGRAPixel; count: integer; mode: TDrawMode);
     61
     62{ Perform advanced blending operation }
    1063procedure BlendPixels(pdest: PBGRAPixel; psrc: PBGRAPixel;
    1164  blendOp: TBlendOperation; Count: integer);
    1265
    13 procedure DrawPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;
    14 procedure DrawPixelsInline(dest: PBGRAPixel; c: TBGRAPixel; Count: integer); inline;
    15 
    16 procedure FillInline(dest: PBGRAPixel; c: TBGRAPixel; Count: integer); inline;
    17 procedure AlphaFillInline(dest: PBGRAPixel; alpha: byte; Count: integer); inline;
    18 procedure ErasePixelInline(dest: PBGRAPixel; alpha: byte); inline;
    19 
    20 procedure FastBlendPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;
    21 procedure FastBlendPixelsInline(dest: PBGRAPixel; c: TBGRAPixel; Count: integer); inline;
    22 
    23 procedure DrawPixelInlineDiff(dest: PBGRAPixel; c, compare: TBGRAPixel;
    24   maxDiff: byte); inline;
    25 procedure DrawPixelsInlineDiff(dest: PBGRAPixel; c: TBGRAPixel;
    26   Count: integer; compare: TBGRAPixel; maxDiff: byte); inline;
    27 
    2866//layer blend modes ( http://www.pegtop.net/delphi/articles/blendmodes/ )
    29 procedure MultiplyPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;
    3067procedure LinearMultiplyPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;
    3168procedure AddPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;
     
    3471procedure ColorDodgePixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;
    3572procedure ReflectPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;
     73procedure NonLinearReflectPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;
    3674procedure GlowPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;
     75procedure NiceGlowPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;
    3776procedure OverlayPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;
     77procedure LinearOverlayPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;
    3878procedure DifferencePixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;
    3979procedure LinearDifferencePixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;
     
    4787implementation
    4888
     89procedure ScannerPutPixels(scan: IBGRAScanner; pdest: PBGRAPixel; count: integer; mode: TDrawMode);
     90var c : TBGRAPixel;
     91  i: Integer;
     92  scanNextFunc: function(): TBGRAPixel of object;
     93begin
     94  if scan.IsScanPutPixelsDefined then
     95    scan.ScanPutPixels(pdest,count,mode) else
     96  begin
     97    scanNextFunc := @scan.ScanNextPixel;
     98    case mode of
     99      dmLinearBlend:
     100        for i := 0 to count-1 do
     101        begin
     102          FastBlendPixelInline(pdest, scanNextFunc());
     103          inc(pdest);
     104        end;
     105      dmDrawWithTransparency:
     106        for i := 0 to count-1 do
     107        begin
     108          DrawPixelInlineWithAlphaCheck(pdest, scanNextFunc());
     109          inc(pdest);
     110        end;
     111      dmSet:
     112        for i := 0 to count-1 do
     113        begin
     114          pdest^ := scanNextFunc();
     115          inc(pdest);
     116        end;
     117      dmXor:
     118        for i := 0 to count-1 do
     119        begin
     120          PDWord(pdest)^ := PDWord(pdest)^ xor DWord(scanNextFunc());
     121          inc(pdest);
     122        end;
     123      dmSetExceptTransparent:
     124        for i := 0 to count-1 do
     125        begin
     126          c := scanNextFunc();
     127          if c.alpha = 255 then pdest^ := c;
     128          inc(pdest);
     129        end;
     130    end;
     131  end;
     132end;
     133
    49134procedure BlendPixels(pdest: PBGRAPixel; psrc: PBGRAPixel;
    50135  blendOp: TBlendOperation; Count: integer);
     
    61146    boTransparent: while Count > 0 do
    62147      begin
    63         DrawPixelInline(pdest, psrc^);
     148        DrawPixelInlineWithAlphaCheck(pdest, psrc^);
    64149        Inc(pdest);
    65150        Inc(psrc);
     
    69154    boMultiply: while Count > 0 do
    70155      begin
    71         MultiplyPixelInline(pdest, psrc^);
    72         Inc(pdest);
    73         Inc(psrc);
    74         Dec(Count);
    75       end;
    76 
    77     boLinearMultiply: while Count > 0 do
    78       begin
    79         LinearMultiplyPixelInline(pdest, psrc^);
     156        LinearMultiplyPixelInline(pdest, psrc^);  //same look with non linear
    80157        Inc(pdest);
    81158        Inc(psrc);
     
    131208      end;
    132209
     210    boNiceGlow: while Count > 0 do
     211      begin
     212        NiceGlowPixelInline(pdest, psrc^);
     213        Inc(pdest);
     214        Inc(psrc);
     215        Dec(Count);
     216      end;
     217
    133218    boOverlay: while Count > 0 do
    134219      begin
     220        LinearOverlayPixelInline(pdest, psrc^);
     221        Inc(pdest);
     222        Inc(psrc);
     223        Dec(Count);
     224      end;
     225
     226    boDarkOverlay: while Count > 0 do
     227      begin
    135228        OverlayPixelInline(pdest, psrc^);
    136229        Inc(pdest);
     
    202295        Dec(Count);
    203296      end;
     297  end;
     298end;
     299
     300procedure XorInline(dest: PBGRAPixel; c: TBGRAPixel; Count: integer);
     301begin
     302  while Count > 0 do
     303  begin
     304    PDWord(dest)^ := PDWord(dest)^ xor DWord(c);
     305    Inc(dest);
     306    Dec(Count);
     307  end;
     308end;
     309
     310procedure XorPixels(pdest, psrc: PBGRAPixel; count: integer);
     311begin
     312  while Count > 0 do
     313  begin
     314    PDWord(pdest)^ := PDWord(psrc)^ xor PDWord(pdest)^;
     315    Inc(pdest);
     316    Inc(psrc);
     317    Dec(Count);
    204318  end;
    205319end;
     
    224338  n: integer;
    225339begin
     340  if c.alpha = 0 then exit;
    226341  for n := Count - 1 downto 0 do
    227342  begin
     
    234349var
    235350  n: integer;
    236 begin
     351  ec: TExpandedPixel;
     352begin
     353  if c.alpha = 0 then exit;
     354  if c.alpha = 255 then
     355  begin
     356    filldword(dest^,count,longword(c));
     357    exit;
     358  end;
     359  ec := GammaExpansion(c);
    237360  for n := Count - 1 downto 0 do
    238361  begin
    239     DrawPixelInline(dest, c);
     362    DrawExpandedPixelInlineNoAlphaCheck(dest, ec,c.alpha);
     363    Inc(dest);
     364  end;
     365end;
     366
     367procedure DrawExpandedPixelsInline(dest: PBGRAPixel; ec: TExpandedPixel;
     368  Count: integer);
     369var
     370  n: integer;
     371  c: TBGRAPixel;
     372begin
     373  if ec.alpha < $0100 then exit;
     374  if ec.alpha >= $FF00 then
     375  begin
     376    c := GammaCompression(ec);
     377    filldword(dest^,count,longword(c));
     378    exit;
     379  end;
     380  for n := Count - 1 downto 0 do
     381  begin
     382    DrawExpandedPixelInlineNoAlphaCheck(dest, ec, ec.alpha shr 8);
     383    Inc(dest);
     384  end;
     385end;
     386
     387procedure DrawPixelsInlineExpandedOrNot(dest: PBGRAPixel; ec: TExpandedPixel; c: TBGRAPixel; Count: integer
     388  );
     389var
     390  n: integer;
     391begin
     392  if c.alpha = 0 then exit;
     393  if c.alpha = 255 then
     394  begin
     395    filldword(dest^,count,longword(c));
     396    exit;
     397  end;
     398  for n := Count - 1 downto 0 do
     399  begin
     400    DrawExpandedPixelInlineNoAlphaCheck(dest, ec, c.alpha);
    240401    Inc(dest);
    241402  end;
     
    255416
    256417{$hints off}
    257 procedure DrawPixelInline(dest: PBGRAPixel; c: TBGRAPixel);
     418procedure DrawPixelInlineWithAlphaCheck(dest: PBGRAPixel; const c: TBGRAPixel);
     419begin
     420  if c.alpha = 0 then
     421    exit;
     422  if c.alpha = 255 then
     423  begin
     424    dest^ := c;
     425    exit;
     426  end;
     427  DrawPixelInlineNoAlphaCheck(dest,c);
     428end;
     429
     430procedure DrawPixelInlineWithAlphaCheck(dest: PBGRAPixel; c: TBGRAPixel; appliedOpacity: byte);
     431begin
     432  c.alpha := ApplyOpacity(c.alpha,appliedOpacity);
     433  if c.alpha = 0 then
     434    exit;
     435  if c.alpha = 255 then
     436  begin
     437    dest^ := c;
     438    exit;
     439  end;
     440  DrawPixelInlineNoAlphaCheck(dest,c);
     441end;
     442
     443procedure CopyPixelsWithOpacity(dest, src: PBGRAPixel; opacity: byte;
     444  Count: integer);
     445var c: TBGRAPixel;
     446begin
     447  while count > 0 do
     448  begin
     449    c := src^;
     450    c.alpha := ApplyOpacity(c.alpha,opacity);
     451    dest^ := c;
     452    inc(src);
     453    inc(dest);
     454    dec(count);
     455  end;
     456end;
     457
     458function ApplyOpacity(opacity1, opacity2: byte): byte;
     459begin
     460  result := opacity1*(opacity2+1) shr 8;
     461end;
     462
     463function FastRoundDiv255(value: cardinal): cardinal; inline;
     464begin
     465  result := (value + (value shr 7)) shr 8;
     466end;
     467
     468procedure DrawExpandedPixelInlineWithAlphaCheck(dest: PBGRAPixel; const ec: TExpandedPixel);
     469var
     470  calpha: byte;
     471begin
     472  calpha := ec.alpha shr 8;
     473  if calpha = 0 then
     474    exit;
     475  if calpha = 255 then
     476  begin
     477    dest^ := GammaCompression(ec);
     478    exit;
     479  end;
     480  DrawExpandedPixelInlineNoAlphaCheck(dest,ec,calpha);
     481end;
     482
     483procedure DrawPixelInlineExpandedOrNotWithAlphaCheck(dest: PBGRAPixel; const ec: TExpandedPixel; c: TBGRAPixel);
     484begin
     485  if c.alpha = 0 then
     486    exit;
     487  if c.alpha = 255 then
     488  begin
     489    dest^ := c;
     490    exit;
     491  end;
     492  DrawExpandedPixelInlineNoAlphaCheck(dest,ec,c.alpha);
     493end;
     494
     495procedure DrawPixelInlineNoAlphaCheck(dest: PBGRAPixel; const c: TBGRAPixel);
    258496var
    259497  p: PByte;
    260498  a1f, a2f, a12, a12m: cardinal;
    261499begin
    262   if c.alpha = 0 then
    263     exit;
    264   if c.alpha = 255 then
    265   begin
    266     dest^ := c;
    267     exit;
    268   end;
    269 
    270500  a12  := 65025 - (not dest^.alpha) * (not c.alpha);
    271501  a12m := a12 shr 1;
     
    289519end;
    290520
    291 procedure FastBlendPixelInline(dest: PBGRAPixel; c: TBGRAPixel);
     521procedure DrawExpandedPixelInlineNoAlphaCheck(dest: PBGRAPixel;
     522  const ec: TExpandedPixel; calpha: byte);
     523var
     524  p: PByte;
     525  a1f, a2f, a12, a12m: cardinal;
     526begin
     527  a12  := 65025 - (not dest^.alpha) * (not calpha);
     528  a12m := a12 shr 1;
     529
     530  a1f := dest^.alpha * (not calpha);
     531  a2f := (calpha shl 8) - calpha;
     532
     533  p := PByte(dest);
     534
     535  p^ := GammaCompressionTab[(GammaExpansionTab[dest^.blue] * a1f +
     536    ec.blue * a2f + a12m) div a12];
     537  Inc(p);
     538  p^ := GammaCompressionTab[(GammaExpansionTab[dest^.green] * a1f +
     539    ec.green * a2f + a12m) div a12];
     540  Inc(p);
     541  p^ := GammaCompressionTab[(GammaExpansionTab[dest^.red] * a1f +
     542    ec.red * a2f + a12m) div a12];
     543  Inc(p);
     544
     545  p^ := (a12 + a12 shr 7) shr 8;
     546end;
     547
     548procedure FastBlendPixelInline(dest: PBGRAPixel; const c: TBGRAPixel);
    292549var
    293550  p: PByte;
     
    320577end;
    321578
     579procedure FastBlendPixelInline(dest: PBGRAPixel; c: TBGRAPixel;
     580  appliedOpacity: byte);
     581begin
     582  c.alpha := ApplyOpacity(c.alpha,appliedOpacity);
     583  FastBlendPixelInline(dest,c);
     584end;
     585
    322586procedure DrawPixelInlineDiff(dest: PBGRAPixel; c, compare: TBGRAPixel;
    323587  maxDiff: byte); inline;
    324588begin
    325   DrawPixelInline(dest, BGRA(c.red, c.green, c.blue,
     589  DrawPixelInlineWithAlphaCheck(dest, BGRA(c.red, c.green, c.blue,
    326590    (c.alpha * (maxDiff + 1 - BGRADiff(dest^, compare)) + (maxDiff + 1) shr 1) div
    327591    (maxDiff + 1)));
     
    332596  newAlpha: byte;
    333597begin
    334   newAlpha := dest^.alpha * (255 - alpha) div 255;
     598  newAlpha := ApplyOpacity(dest^.alpha, not alpha);
    335599  if newAlpha = 0 then
    336600    dest^ := BGRAPixelTransparent
     
    343607{--------------------------------------- Layer blending -----------------------------------------}
    344608
    345 function ByteMultiplyInline(a, b: byte): byte;
    346 begin
    347   Result := GammaCompressionTab[GammaExpansionTab[a] * GammaExpansionTab[b] shr 16];
    348 end;
    349 
    350609function ByteLinearMultiplyInline(a, b: byte): byte;
    351610begin
    352611  Result := (a * b) shr 8;
    353 end;
    354 
    355 procedure MultiplyPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;
    356 var
    357   destalpha: byte;
    358 begin
    359   destalpha   := dest^.alpha;
    360   dest^.red   := (ByteMultiplyInline(dest^.red, c.red) * destalpha +
    361     c.red * (not destalpha)) shr 8;
    362   dest^.green := (ByteMultiplyInline(dest^.green, c.green) * destalpha +
    363     c.green * (not destalpha)) shr 8;
    364   dest^.blue  := (ByteMultiplyInline(dest^.blue, c.blue) * destalpha +
    365     c.blue * (not destalpha)) shr 8;
    366   dest^.alpha := c.alpha;
    367612end;
    368613
     
    456701end;
    457702
     703{$hints off}
    458704function ByteDodgeInline(a, b: byte): byte; inline;
    459705var
     
    464710  else
    465711  begin
    466     temp := (a shl 8) div (255 - b);
     712    temp := (a shl 8) div (not b);
    467713    if temp > 255 then
    468714      Result := 255
     
    471717  end;
    472718end;
     719{$hints on}
    473720
    474721procedure ColorDodgePixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;
     
    486733end;
    487734
    488 function ByteReflectInline(a, b: byte): byte; inline;
    489 var
    490   temp: integer;
     735{$hints off}
     736function ByteNonLinearReflectInline(a, b: byte): byte; inline;
     737var
     738  temp: longword;
     739  wa,wb: word;
    491740begin
    492741  if b = 255 then
     
    494743  else
    495744  begin
    496     temp := a * a div (255 - b);
     745    wa := GammaExpansionTab[a];
     746    wb := GammaExpansionTab[b];
     747    temp := wa * wa div (not wb);
     748    if temp >= 65535 then
     749      Result := 255
     750    else
     751      Result := GammaCompressionTab[ temp ];
     752  end;
     753end;
     754
     755function ByteReflectInline(a, b: byte): byte; inline;
     756var
     757  temp: integer;
     758begin
     759  if b = 255 then
     760    Result := 255
     761  else
     762  begin
     763    temp := a * a div (not b);
    497764    if temp > 255 then
    498765      Result := 255
     
    501768  end;
    502769end;
     770{$hints on}
     771
    503772
    504773procedure ReflectPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;
     
    526795    c.green * (not destalpha)) shr 8;
    527796  dest^.blue  := (ByteReflectInline(c.blue, dest^.blue) * destalpha +
     797    c.blue * (not destalpha)) shr 8;
     798  dest^.alpha := c.alpha;
     799end;
     800
     801procedure NiceGlowPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;
     802var
     803  destalpha: byte;
     804begin
     805  destalpha   := dest^.alpha;
     806  dest^.red   := (ByteReflectInline(c.red, dest^.red) * destalpha +
     807    c.red * (not destalpha)) shr 8;
     808  dest^.green := (ByteReflectInline(c.green, dest^.green) * destalpha +
     809    c.green * (not destalpha)) shr 8;
     810  dest^.blue  := (ByteReflectInline(c.blue, dest^.blue) * destalpha +
     811    c.blue * (not destalpha)) shr 8;
     812
     813  if (c.red > c.green) and (c.red > c.blue) then
     814    dest^.alpha := c.red else
     815  if (c.green > c.blue) then
     816    dest^.alpha := c.green else
     817    dest^.alpha := c.blue;
     818  dest^.alpha := ApplyOpacity(GammaExpansionTab[dest^.alpha] shr 8,c.alpha);
     819end;
     820
     821procedure NonLinearReflectPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;
     822var
     823  destalpha: byte;
     824begin
     825  destalpha   := dest^.alpha;
     826  dest^.red   := (ByteNonLinearReflectInline(dest^.red, c.red) * destalpha +
     827    c.red * (not destalpha)) shr 8;
     828  dest^.green := (ByteNonLinearReflectInline(dest^.green, c.green) * destalpha +
     829    c.green * (not destalpha)) shr 8;
     830  dest^.blue  := (ByteNonLinearReflectInline(dest^.blue, c.blue) * destalpha +
    528831    c.blue * (not destalpha)) shr 8;
    529832  dest^.alpha := c.alpha;
     
    532835{$hints off}
    533836function ByteOverlayInline(a, b: byte): byte; inline;
     837var wa,wb: word;
     838begin
     839  wa := GammaExpansionTab[a];
     840  wb := GammaExpansionTab[b];
     841  if wa < 32768 then
     842    Result := GammaCompressionTab[ (wa * wb) shr 15 ]
     843  else
     844    Result := GammaCompressionTab[ 65535 - ((not wa) * (not wb) shr 15) ];
     845end;
     846
     847function ByteLinearOverlayInline(a, b: byte): byte; inline;
    534848begin
    535849  if a < 128 then
    536850    Result := (a * b) shr 7
    537851  else
    538     Result := 255 - ((255 - a) * (255 - b) shr 7);
     852    Result := 255 - ((not a) * (not b) shr 7);
    539853end;
    540854
     
    551865    c.green * (not destalpha)) shr 8;
    552866  dest^.blue  := (ByteOverlayInline(dest^.blue, c.blue) * destalpha +
     867    c.blue * (not destalpha)) shr 8;
     868  dest^.alpha := c.alpha;
     869end;
     870
     871procedure LinearOverlayPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;
     872var
     873  destalpha: byte;
     874begin
     875  destalpha   := dest^.alpha;
     876  dest^.red   := (ByteLinearOverlayInline(dest^.red, c.red) * destalpha +
     877    c.red * (not destalpha)) shr 8;
     878  dest^.green := (ByteLinearOverlayInline(dest^.green, c.green) * destalpha +
     879    c.green * (not destalpha)) shr 8;
     880  dest^.blue  := (ByteLinearOverlayInline(dest^.blue, c.blue) * destalpha +
    553881    c.blue * (not destalpha)) shr 8;
    554882  dest^.alpha := c.alpha;
  • GraphicTest/BGRABitmap/bgracompressablebitmap.pas

    r210 r317  
    1 unit bgracompressablebitmap;
     1unit BGRACompressableBitmap;
    22
    33{$mode objfpc}{$H+}
    44
    55interface
     6
     7{ This unit contains the TBGRACompressableBitmap class, which
     8  can be used to temporarily compress bitmaps in memory.
     9  To use it, create an instance with the bitmap you want
     10  to compress. You can then free the original bitmap because
     11  TBGRACompressableBitmap contains all information necessary
     12  to build it again. To construct again your bitmap, call
     13  the GetBitmap function.
     14
     15  When you have your bitmap in TBGRACompressableBitmap,
     16  you can call Compress function as many times as necessary
     17  until all data is compressed. It does only a part of the
     18  work at each call, so you can put it in a loop or in
     19  a timer. When it's done, Compress returns false to
     20  notify that it did nothing, which means you can
     21  stop calling Compress.
     22
     23  In this implementation, the memory usage grows during
     24  the compression process and is lower only after it is
     25  finished. So it is recommended to compress one bitmap
     26  at a time. }
    627
    728uses
     
    1637     FWidth,FHeight: integer;
    1738     FCaption: String;
     39     FBounds: TRect;
    1840     FCompressedDataArray: array of TMemoryStream;
    1941     FUncompressedData: TMemoryStream;
     
    2547     constructor Create(Source: TBGRABitmap);
    2648     function GetBitmap: TBGRABitmap;
    27      function Compress: boolean;
     49     
     50     //call Compress as many times as necessary
     51     //when it returns false, it means that
     52     //the image compression is finished
     53     function Compress: boolean;
     54     
    2855     function UsedMemory: Int64;
    2956     procedure Assign(Source: TBGRABitmap);
     
    3865uses zstream, BGRABitmapTypes;
    3966
    40 const maxPartSize = 1048576;
     67// size of each chunk treated by Compress function
     68const maxPartSize = 524288;
    4169
    4270{ TBGRACompressedBitmap }
     
    6391end;
    6492
     93{ Constructs the bitmap again, decompressing if necessary.
     94  After this, the image is not compressed anymore so the
     95  memoy usage grows again and the access becomes fast
     96  because there is no need to decompress anymore. }
    6597function TBGRACompressableBitmap.GetBitmap: TBGRABitmap;
     98var UsedPart: TBGRABitmap;
     99    UsedNbPixels: Integer;
    66100begin
    67101  Decompress;
     
    74108  result.Caption := FCaption;
    75109  FUncompressedData.Position := 0;
    76   FUncompressedData.Read(result.Data^,result.NbPixels*Sizeof(TBGRAPixel));
    77 end;
    78 
     110  if (FBounds.Left <> 0) or (FBounds.Top <> 0)
     111    or (FBounds.Right <> FWidth) or (FBounds.Bottom <> FHeight) then
     112  begin
     113    UsedNbPixels := (FBounds.Right-FBounds.Left)*(FBounds.Bottom-FBounds.Top);
     114    if UsedNbPixels > 0 then
     115    begin
     116      UsedPart := TBGRABitmap.Create(FBounds.Right-FBounds.Left,FBounds.Bottom-FBounds.Top);
     117      FUncompressedData.Read(UsedPart.Data^,UsedPart.NbPixels*Sizeof(TBGRAPixel));
     118      result.PutImage(FBounds.Left,FBounds.Top,UsedPart,dmSet);
     119      UsedPart.Free;
     120    end;
     121  end else
     122    FUncompressedData.Read(result.Data^,result.NbPixels*Sizeof(TBGRAPixel));
     123end;
     124
     125{ Returns the total memory used by this object for storing bitmap data }
    79126function TBGRACompressableBitmap.UsedMemory: Int64;
    80127var i: integer;
     
    86133end;
    87134
     135{ Do one compress step or return false }
    88136function TBGRACompressableBitmap.Compress: boolean;
    89137var comp: Tcompressionstream;
     
    91139begin
    92140  if FCompressedDataArray = nil then FCompressionProgress := 0;
    93   if FUncompressedData = nil then
     141  if (FUncompressedData = nil) or (FUncompressedData.Size = 0) then
    94142  begin
    95143    result := false;
     
    104152      partSize := maxPartSize else
    105153        partSize := integer(FUncompressedData.Size - FCompressionProgress);
     154
     155    //use fast compression to avoid slowing down the application
    106156    comp := Tcompressionstream.Create(clfastest,FCompressedDataArray[high(FCompressedDataArray)]);
    107157    comp.write(partSize,sizeof(partSize));
     
    136186end;
    137187
     188{ Free all data }
    138189procedure TBGRACompressableBitmap.FreeData;
    139190var i: integer;
     
    148199end;
    149200
     201{ Copy a bitmap into this object. As it is copied, you need not
     202  keep a copy of the source }
    150203procedure TBGRACompressableBitmap.Assign(Source: TBGRABitmap);
     204var
     205  UsedPart: TBGRABitmap;
     206  NbUsedPixels: integer;
    151207begin
    152208  FreeData;
     
    161217  FHeight := Source.Height;
    162218  FCaption := Source.Caption;
     219  FBounds := Source.GetImageBounds([cRed,cGreen,cBlue,cAlpha]);
     220  NbUsedPixels := (FBounds.Right-FBounds.Left)*(FBounds.Bottom-FBounds.Top);
    163221  FUncompressedData := TMemoryStream.Create;
    164   FUncompressedData.Write(Source.Data^,Source.NbPixels*Sizeof(TBGRAPixel));
     222  if NbUsedPixels = 0 then exit;
     223
     224  if (FBounds.Left <> 0) or (FBounds.Top <> 0)
     225    or (FBounds.Right <> Source.Width) or (FBounds.Bottom <> Source.Height) then
     226  begin
     227    UsedPart := Source.GetPart(FBounds) as TBGRABitmap;
     228    FUncompressedData.Write(UsedPart.Data^,NbUsedPixels*Sizeof(TBGRAPixel));
     229    UsedPart.Free;
     230  end else
     231    FUncompressedData.Write(Source.Data^,Source.NbPixels*Sizeof(TBGRAPixel));
    165232end;
    166233
  • GraphicTest/BGRABitmap/bgradefaultbitmap.pas

    r210 r317  
    2929interface
    3030
     31{ This unit contains TBGRADefaultBitmap class. This class contains basic drawing routines,
     32  and call functions from other units to perform advanced drawing functions. }
     33
    3134uses
    32   Classes, SysUtils, Types, FPImage, Graphics, BGRABitmapTypes, GraphType;
     35  Classes, SysUtils, Types, FPImage, Graphics, BGRABitmapTypes, GraphType, FPImgCanv, BGRACanvas, BGRACanvas2D, FPWritePng;
    3336
    3437type
    35   TBGRADefaultBitmap = class;
    36   TBGRABitmapAny     = class of TBGRADefaultBitmap;
    37 
    3838  { TBGRADefaultBitmap }
    3939
    40   TBGRADefaultBitmap = class(TFPCustomImage)
     40  TBGRADefaultBitmap = class(TBGRACustomBitmap)
    4141  private
    42     FEraseMode: boolean;
    43     FBitmapModified: boolean; //if TBitmap has changed
    44     FFontHeightSign: integer;
    45     FFont: TFont;
     42    { Bounds checking which are shared by drawing functions. These functions check
     43      if the coordinates are visible and return true if it is the case, swap
     44      coordinates if necessary and make them fit into the clipping rectangle }
     45    function CheckHorizLineBounds(var x, y, x2: integer): boolean; inline;
     46    function CheckVertLineBounds(var x, y, y2: integer; out delta: integer): boolean; inline;
     47    function CheckRectBounds(var x,y,x2,y2: integer; minsize: integer): boolean; inline;
     48    function CheckClippedRectBounds(var x,y,x2,y2: integer): boolean; inline;
     49    function CheckPutImageBounds(x, y, tx, ty: integer; out minxb, minyb, maxxb, maxyb, ignoreleft: integer): boolean; inline;
     50    function CheckAntialiasRectBounds(var x,y,x2,y2: single; w: single): boolean;
     51    function GetCanvasBGRA: TBGRACanvas;
     52    function GetCanvas2D: TBGRACanvas2D;
     53  protected
     54    FRefCount: integer; //reference counter (not related to interface reference counter)
     55
     56    //Pixel data
     57    FData:      PBGRAPixel;              //pointer to pixels
     58    FWidth, FHeight, FNbPixels: integer; //dimensions
     59    FDataModified: boolean;              //if data image has changed so TBitmap should be updated
     60    FLineOrder: TRawImageLineOrder;
     61    FClipRect:  TRect;                   //clipping (can be the whole image if there is no clipping)
     62
     63    //Scan
     64    FScanPtr : PBGRAPixel;          //current scan address
     65    FScanCurX,FScanCurY: integer;   //current scan coordinates
     66
     67    //LCL bitmap object
     68    FBitmap:   TBitmap;
     69    FBitmapModified: boolean;         //if TBitmap has changed so pixel data should be updated
     70    FCanvasOpacity: byte;             //opacity used with standard canvas functions
     71    FAlphaCorrectionNeeded: boolean;  //the alpha channel is not correct because standard functions do not
     72                                      //take it into account
     73
     74    //FreePascal drawing routines
     75    FCanvasFP: TFPImageCanvas;
     76    FCanvasDrawModeFP: TDrawMode;
     77    FCanvasPixelProcFP: procedure(x, y: integer; col: TBGRAPixel) of object;
     78
     79    //canvas-like with antialiasing and texturing
     80    FCanvasBGRA: TBGRACanvas;
     81    FCanvas2D: TBGRACanvas2D;
     82
     83    //drawing options
     84    FEraseMode: boolean;      //when polygons are erased instead of drawn
     85    FFont: TFont;             //font parameters
    4686    FFontHeight: integer;
    47     function GetCanvasAlphaCorrection: boolean;
    48     procedure SetCanvasAlphaCorrection(const AValue: boolean);
    49     procedure UpdateFont;
    50     procedure SetFontHeight(AHeight: integer);
     87    FFontHeightSign: integer; //sign correction
     88
     89    { Pen style can be defined by PenStyle property of by CustomPenStyle property.
     90      When PenStyle property is assigned, CustomPenStyle property is assigned the actual
     91      pen pattern. }
     92    FCustomPenStyle:  TBGRAPenStyle;
     93    FPenStyle: TPenStyle;
     94
     95    //Pixel data
     96    function GetRefCount: integer; override;
     97    function GetScanLine(y: integer): PBGRAPixel; override; //don't forget to call InvalidateBitmap after modifications
     98    function LoadFromRawImage(ARawImage: TRawImage; DefaultOpacity: byte;
     99      AlwaysReplaceAlpha: boolean = False; RaiseErrorOnInvalidPixelFormat: boolean = True): boolean;
     100    function GetDataPtr: PBGRAPixel; override;
     101    procedure ClearTransparentPixels;
    51102    function GetScanlineFast(y: integer): PBGRAPixel; inline;
    52   protected
    53     FBitmap:   TBitmap; //LCL bitmap object
    54     FRefCount: integer; //reference counter
    55 
    56     {Pixel data}
    57     FData:      PBGRAPixel;
    58     FWidth, FHeight, FNbPixels: integer;
    59     FDataModified: boolean; //if data image has changed
    60     FLineOrder: TRawImageLineOrder;
    61     FCanvasOpacity: byte;
    62     FAlphaCorrectionNeeded: boolean;
    63 
    64     function GetScanLine(y: integer): PBGRAPixel;
    65     //don't forget to call InvalidateBitmap after modifications
    66     function GetBitmap: TBitmap;
    67     function GetCanvas: TCanvas;
     103    function GetLineOrder: TRawImageLineOrder; override;
     104    function GetNbPixels: integer; override;
     105    function GetWidth: integer; override;
     106    function GetHeight: integer; override;
     107
     108    //LCL bitmap object
     109    function GetBitmap: TBitmap; override;
     110    function GetCanvas: TCanvas; override;
    68111    procedure DiscardBitmapChange; inline;
    69     procedure LoadFromRawImage(ARawImage: TRawImage; DefaultOpacity: byte;
    70       AlwaysReplaceAlpha: boolean = False);
     112    procedure DoAlphaCorrection;
     113    procedure SetCanvasOpacity(AValue: byte); override;
     114    function GetCanvasOpacity: byte; override;
     115    function GetCanvasAlphaCorrection: boolean; override;
     116    procedure SetCanvasAlphaCorrection(const AValue: boolean); override;
     117
     118    //FreePascal drawing routines
     119    function GetCanvasFP: TFPImageCanvas; override;
     120    procedure SetCanvasDrawModeFP(const AValue: TDrawMode); override;
     121    function GetCanvasDrawModeFP: TDrawMode; override;
    71122
    72123    {Allocation routines}
     
    78129
    79130    procedure Init; virtual;
     131
    80132    {TFPCustomImage}
    81133    procedure SetInternalColor(x, y: integer; const Value: TFPColor); override;
     
    84136    function GetInternalPixel(x, y: integer): integer; override;
    85137
    86     {resample}
    87     function FineResample(NewWidth, NewHeight: integer): TBGRADefaultBitmap;
    88     function SimpleStretch(NewWidth, NewHeight: integer): TBGRADefaultBitmap;
    89 
    90     function CheckEmpty: boolean;
    91     function GetHasTransparentPixels: boolean;
    92     function GetAverageColor: TColor;
    93     function GetAveragePixel: TBGRAPixel;
    94     procedure SetCanvasOpacity(AValue: byte);
    95     function GetDataPtr: PBGRAPixel;
    96     procedure DoAlphaCorrection;
    97     procedure ClearTransparentPixels;
    98 
    99     {Spline}
    100     function Spline(y0, y1, y2, y3: single; t: single): single;
     138    {Image functions}
     139    function FineResample(NewWidth, NewHeight: integer): TBGRACustomBitmap;
     140    function SimpleStretch(NewWidth, NewHeight: integer): TBGRACustomBitmap;
     141    function CheckEmpty: boolean; override;
     142    function GetHasTransparentPixels: boolean; override;
     143    function GetAverageColor: TColor; override;
     144    function GetAveragePixel: TBGRAPixel; override;
     145    function CreateAdaptedPngWriter: TFPWriterPNG;
     146    function LoadAsBmp32(Str: TStream): boolean; override;
     147
     148    //drawing
     149    function GetCustomPenStyle: TBGRAPenStyle; override;
     150    procedure SetCustomPenStyle(const AValue: TBGRAPenStyle); override;
     151    procedure SetPenStyle(const AValue: TPenStyle); override;
     152    function GetPenStyle: TPenStyle; override;
     153
     154    procedure UpdateFont;
     155    function GetFontHeight: integer; override;
     156    procedure SetFontHeight(AHeight: integer); override;
     157    function GetFontFullHeight: integer; override;
     158    procedure SetFontFullHeight(AHeight: integer); override;
     159    function GetFontPixelMetric: TFontPixelMetric; override;
     160
     161    function GetClipRect: TRect; override;
     162    procedure SetClipRect(const AValue: TRect); override;
    101163
    102164  public
    103     Caption:   string;
    104     FontName:  string;
    105     FontStyle: TFontStyles;
    106 
    107165    {Reference counter functions}
    108     function NewReference: TBGRADefaultBitmap;
     166    function NewReference: TBGRACustomBitmap;
    109167    procedure FreeReference;
    110     function GetUnique: TBGRADefaultBitmap;
    111     function NewBitmap(AWidth, AHeight: integer): TBGRADefaultBitmap;
    112     function NewBitmap(Filename: string): TBGRADefaultBitmap;
     168    function GetUnique: TBGRACustomBitmap;
    113169
    114170    {TFPCustomImage override}
     
    117173
    118174    {Constructors}
    119     constructor Create;
    120     constructor Create(ABitmap: TBitmap);
    121     constructor Create(AWidth, AHeight: integer; Color: TColor);
    122     constructor Create(AWidth, AHeight: integer; Color: TBGRAPixel);
     175    constructor Create; override;
     176    constructor Create(ABitmap: TBitmap); override;
     177    constructor Create(AWidth, AHeight: integer; Color: TColor); override;
     178    constructor Create(AWidth, AHeight: integer; Color: TBGRAPixel); override;
     179    constructor Create(AFilename: string); override;
     180    constructor Create(AStream: TStream); override;
    123181    destructor Destroy; override;
    124182
    125183    {Loading functions}
    126     procedure LoadFromFile(const filename: string);
    127     procedure SaveToFile(const filename: string);
    128     constructor Create(AFilename: string);
    129     constructor Create(AStream: TStream);
    130     procedure Assign(Bitmap: TBitmap); overload;
    131     procedure Assign(MemBitmap: TBGRADefaultBitmap); overload;
     184    function NewBitmap(AWidth, AHeight: integer): TBGRACustomBitmap; override;
     185    function NewBitmap(AWidth, AHeight: integer; Color: TBGRAPixel): TBGRACustomBitmap; override;
     186    function NewBitmap(Filename: string): TBGRACustomBitmap; override;
     187
     188    procedure LoadFromFile(const filename: string); override;
     189    procedure SaveToFile(const filename: string); override;
     190    procedure SaveToStreamAsPng(Str: TStream); override;
     191    procedure Assign(ABitmap: TBitmap); override; overload;
     192    procedure Assign(MemBitmap: TBGRACustomBitmap);override; overload;
     193    procedure Serialize(AStream: TStream); override;
     194    procedure Deserialize(AStream: TStream); override;
     195    class procedure SerializeEmpty(AStream: TStream);
    132196
    133197    {Pixel functions}
    134     procedure SetPixel(x, y: integer; c: TColor); overload;
    135     procedure SetPixel(x, y: integer; c: TBGRAPixel); overload;
    136     procedure DrawPixel(x, y: integer; c: TBGRAPixel);
    137     procedure FastBlendPixel(x, y: integer; c: TBGRAPixel);
    138     procedure ErasePixel(x, y: integer; alpha: byte);
    139     procedure AlphaPixel(x, y: integer; alpha: byte);
    140     function GetPixel(x, y: integer): TBGRAPixel; overload;
    141     function GetPixel(x, y: single): TBGRAPixel; overload;
    142     function GetPixelCycle(x, y: integer): TBGRAPixel;
     198    function PtInClipRect(x, y: integer): boolean; inline;
     199    procedure SetPixel(x, y: integer; c: TColor); override;
     200    procedure SetPixel(x, y: integer; c: TBGRAPixel); override;
     201    procedure XorPixel(x, y: integer; c: TBGRAPixel); override;
     202    procedure DrawPixel(x, y: integer; c: TBGRAPixel); override;
     203    procedure DrawPixel(x, y: integer; ec: TExpandedPixel); override;
     204    procedure FastBlendPixel(x, y: integer; c: TBGRAPixel); override;
     205    procedure ErasePixel(x, y: integer; alpha: byte); override;
     206    procedure AlphaPixel(x, y: integer; alpha: byte); override;
     207    function GetPixel(x, y: integer): TBGRAPixel; override;
     208    function GetPixel(x, y: single; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; override;
     209    function GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; override;
     210    function GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter;
     211      repeatX: boolean; repeatY: boolean): TBGRAPixel; override; overload;
    143212
    144213    {Line primitives}
    145     procedure SetHorizLine(x, y, x2: integer; c: TBGRAPixel);
    146     procedure DrawHorizLine(x, y, x2: integer; c: TBGRAPixel);
    147     procedure FastBlendHorizLine(x, y, x2: integer; c: TBGRAPixel);
    148     procedure AlphaHorizLine(x, y, x2: integer; alpha: byte);
    149     procedure SetVertLine(x, y, y2: integer; c: TBGRAPixel);
    150     procedure DrawVertLine(x, y, y2: integer; c: TBGRAPixel);
    151     procedure AlphaVertLine(x, y, y2: integer; alpha: byte);
    152     procedure FastBlendVertLine(x, y, y2: integer; c: TBGRAPixel);
     214    procedure SetHorizLine(x, y, x2: integer; c: TBGRAPixel); override;
     215    procedure XorHorizLine(x, y, x2: integer; c: TBGRAPixel); override;
     216    procedure DrawHorizLine(x, y, x2: integer; c: TBGRAPixel); override;
     217    procedure DrawHorizLine(x, y, x2: integer; ec: TExpandedPixel); override;
     218    procedure DrawHorizLine(x, y, x2: integer; texture: IBGRAScanner); override;
     219    procedure FastBlendHorizLine(x, y, x2: integer; c: TBGRAPixel); override;
     220    procedure AlphaHorizLine(x, y, x2: integer; alpha: byte); override;
     221    procedure SetVertLine(x, y, y2: integer; c: TBGRAPixel); override;
     222    procedure XorVertLine(x, y, y2: integer; c: TBGRAPixel); override;
     223    procedure DrawVertLine(x, y, y2: integer; c: TBGRAPixel); override;
     224    procedure AlphaVertLine(x, y, y2: integer; alpha: byte); override;
     225    procedure FastBlendVertLine(x, y, y2: integer; c: TBGRAPixel); override;
    153226    procedure DrawHorizLineDiff(x, y, x2: integer; c, compare: TBGRAPixel;
    154       maxDiff: byte);
     227      maxDiff: byte); override;
    155228
    156229    {Shapes}
    157     procedure DrawLine(x1, y1, x2, y2: integer; c: TBGRAPixel; DrawLastPixel: boolean);
    158     procedure DrawLineAntialias(x1, y1, x2, y2: integer; c: TBGRAPixel;
    159       DrawLastPixel: boolean); overload;
    160     procedure DrawPolyLineAntialias(points: array of TPoint; c: TBGRAPixel;
    161       DrawLastPixel: boolean); overload;
    162     procedure DrawLineAntialias(x1, y1, x2, y2: integer; c1, c2: TBGRAPixel;
    163       dashLen: integer; DrawLastPixel: boolean); overload;
    164     procedure DrawPolyLineAntialias(points: array of TPoint; c1, c2: TBGRAPixel;
    165       dashLen: integer; DrawLastPixel: boolean); overload;
    166     procedure DrawLineAntialias(x1, y1, x2, y2: single; c: TBGRAPixel;
    167       w: single; Closed: boolean); overload;
    168     procedure DrawPolyLineAntialias(points: array of TPointF; c: TBGRAPixel;
    169       w: single; Closed: boolean); overload;
    170     procedure DrawPolygonAntialias(points: array of TPointF; c: TBGRAPixel;
    171       w: single); overload;
    172     procedure EraseLineAntialias(x1, y1, x2, y2: single; alpha: byte;
    173       w: single; Closed: boolean); overload;
    174     procedure FillPolyAntialias(points: array of TPointF; c: TBGRAPixel);
    175     procedure ErasePolyAntialias(points: array of TPointF; alpha: byte);
    176     procedure EllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel; w: single);
    177     procedure FillEllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel);
    178     procedure EraseEllipseAntialias(x, y, rx, ry: single; alpha: byte);
    179     procedure Rectangle(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode);
    180     procedure Rectangle(x, y, x2, y2: integer; BorderColor, FillColor: TBGRAPixel;
    181       mode: TDrawMode);
    182     procedure Rectangle(x, y, x2, y2: integer; c: TColor);
    183     procedure Rectangle(r: TRect; c: TBGRAPixel; mode: TDrawMode);
    184     procedure Rectangle(r: TRect; BorderColor, FillColor: TBGRAPixel;
    185       mode: TDrawMode);
    186     procedure Rectangle(r: TRect; c: TColor);
    187     procedure RectangleAntialias(x, y, x2, y2: single; c: TBGRAPixel;
    188       w: single); overload;
    189     procedure RectangleAntialias(x, y, x2, y2: single; c: TBGRAPixel;
    190       w: single; back: TBGRAPixel); overload;
    191     procedure FillRect(r: TRect; c: TColor);
    192     procedure FillRect(r: TRect; c: TBGRAPixel; mode: TDrawMode);
    193     procedure FillRect(x, y, x2, y2: integer; c: TColor);
    194     procedure FillRect(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode);
    195     procedure FillRectAntialias(x, y, x2, y2: single; c: TBGRAPixel);
    196     procedure AlphaFillRect(x, y, x2, y2: integer; alpha: byte);
    197     procedure RoundRect(X1, Y1, X2, Y2: integer; RX, RY: integer;
    198       BorderColor, FillColor: TBGRAPixel);
    199     procedure TextOut(x, y: integer; s: string; c: TBGRAPixel;
    200       align: TAlignment); overload;
    201     procedure TextOut(x, y: integer; s: string; c: TBGRAPixel); overload;
    202     procedure TextOut(x, y: integer; s: string; c: TColor); overload;
    203     procedure TextRect(ARect: TRect; x, y: integer; s: string;
    204       style: TTextStyle; c: TBGRAPixel); overload;
    205     function TextSize(s: string): TSize;
     230    procedure DrawLine(x1, y1, x2, y2: integer; c: TBGRAPixel; DrawLastPixel: boolean); override;
     231    procedure DrawLineAntialias(x1, y1, x2, y2: integer; c: TBGRAPixel; DrawLastPixel: boolean); override;
     232    procedure DrawLineAntialias(x1, y1, x2, y2: integer; c1, c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean); override;
     233    procedure DrawLineAntialias(x1, y1, x2, y2: single; c: TBGRAPixel; w: single); override;
     234    procedure DrawLineAntialias(x1, y1, x2, y2: single; texture: IBGRAScanner; w: single); override;
     235    procedure DrawLineAntialias(x1, y1, x2, y2: single; c: TBGRAPixel; w: single; Closed: boolean); override;
     236    procedure DrawLineAntialias(x1, y1, x2, y2: single; texture: IBGRAScanner; w: single; Closed: boolean); override;
     237
     238    procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single); override;
     239    procedure DrawPolyLineAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single); override;
     240    procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single; Closed: boolean); override;
     241    procedure DrawPolygonAntialias(const points: array of TPointF; c: TBGRAPixel; w: single); override;
     242    procedure DrawPolygonAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single); override;
     243
     244    procedure EraseLineAntialias(x1, y1, x2, y2: single; alpha: byte; w: single); override;
     245    procedure EraseLineAntialias(x1, y1, x2, y2: single; alpha: byte; w: single; Closed: boolean); override;
     246    procedure ErasePolyLineAntialias(const points: array of TPointF; alpha: byte; w: single); override;
     247
     248    procedure FillTriangleLinearColor(pt1,pt2,pt3: TPointF; c1,c2,c3: TBGRAPixel); override;
     249    procedure FillTriangleLinearColorAntialias(pt1,pt2,pt3: TPointF; c1,c2,c3: TBGRAPixel); override;
     250    procedure FillTriangleLinearMapping(pt1,pt2,pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF; TextureInterpolation: Boolean= True); override;
     251    procedure FillTriangleLinearMappingLightness(pt1,pt2,pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF; light1,light2,light3: word; TextureInterpolation: Boolean= True); override;
     252    procedure FillTriangleLinearMappingAntialias(pt1,pt2,pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF); override;
     253
     254    procedure FillQuadLinearColor(pt1,pt2,pt3,pt4: TPointF; c1,c2,c3,c4: TBGRAPixel); override;
     255    procedure FillQuadLinearColorAntialias(pt1,pt2,pt3,pt4: TPointF; c1,c2,c3,c4: TBGRAPixel); override;
     256    procedure FillQuadLinearMapping(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; TextureInterpolation: Boolean= True); override;
     257    procedure FillQuadLinearMappingLightness(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; light1,light2,light3,light4: word; TextureInterpolation: Boolean= True); override;
     258    procedure FillQuadLinearMappingAntialias(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF); override;
     259    procedure FillQuadPerspectiveMapping(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF); override;
     260    procedure FillQuadPerspectiveMappingAntialias(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF); override;
     261
     262    procedure FillPolyLinearMapping(const points: array of TPointF; texture: IBGRAScanner; texCoords: array of TPointF; TextureInterpolation: Boolean); override;
     263    procedure FillPolyLinearMappingLightness(const points: array of TPointF; texture: IBGRAScanner; texCoords: array of TPointF; lightnesses: array of word; TextureInterpolation: Boolean); override;
     264    procedure FillPolyLinearColor(const points: array of TPointF; AColors: array of TBGRAPixel); override;
     265    procedure FillPolyPerspectiveMapping(const points: array of TPointF; const pointsZ: array of single; texture: IBGRAScanner; texCoords: array of TPointF; TextureInterpolation: Boolean); override;
     266    procedure FillPolyPerspectiveMappingLightness(const points: array of TPointF; const pointsZ: array of single; texture: IBGRAScanner; texCoords: array of TPointF; lightnesses: array of word; TextureInterpolation: Boolean); override;
     267    procedure FillPoly(const points: array of TPointF; c: TBGRAPixel; drawmode: TDrawMode); override;
     268    procedure FillPoly(const points: array of TPointF; texture: IBGRAScanner; drawmode: TDrawMode); override;
     269    procedure FillPolyAntialias(const points: array of TPointF; c: TBGRAPixel); override;
     270    procedure FillPolyAntialias(const points: array of TPointF; texture: IBGRAScanner); override;
     271    procedure ErasePoly(const points: array of TPointF; alpha: byte); override;
     272    procedure ErasePolyAntialias(const points: array of TPointF; alpha: byte); override;
     273
     274    procedure EllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel; w: single); override;
     275    procedure EllipseAntialias(x, y, rx, ry: single; texture: IBGRAScanner; w: single); override;
     276    procedure EllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel; w: single; back: TBGRAPixel); override;
     277    procedure FillEllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel); override;
     278    procedure FillEllipseAntialias(x, y, rx, ry: single; texture: IBGRAScanner); override;
     279    procedure FillEllipseLinearColorAntialias(x, y, rx, ry: single; outercolor, innercolor: TBGRAPixel); override;
     280    procedure EraseEllipseAntialias(x, y, rx, ry: single; alpha: byte); override;
     281
     282    procedure Rectangle(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); override;
     283    procedure Rectangle(x, y, x2, y2: integer; BorderColor, FillColor: TBGRAPixel; mode: TDrawMode); override;
     284    procedure RectangleAntialias(x, y, x2, y2: single; c: TBGRAPixel; w: single; back: TBGRAPixel); override;
     285    procedure RectangleAntialias(x, y, x2, y2: single; texture: IBGRAScanner; w: single); override;
     286
     287    procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; c: TBGRAPixel; w: single; options: TRoundRectangleOptions = []); override;
     288    procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; texture: IBGRAScanner; w: single; options: TRoundRectangleOptions = []); override;
     289    procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; pencolor: TBGRAPixel; w: single; fillcolor: TBGRAPixel; options: TRoundRectangleOptions = []); override;
     290    procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; penTexture: IBGRAScanner; w: single; fillTexture: IBGRAScanner; options: TRoundRectangleOptions = []); override;
     291
     292    procedure FillRect(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); override;
     293    procedure FillRect(x, y, x2, y2: integer; texture: IBGRAScanner; mode: TDrawMode); override;
     294    procedure FillRectAntialias(x, y, x2, y2: single; c: TBGRAPixel); override;
     295    procedure EraseRectAntialias(x, y, x2, y2: single; alpha: byte); override;
     296    procedure FillRectAntialias(x, y, x2, y2: single; texture: IBGRAScanner); override;
     297    procedure FillRoundRectAntialias(x,y,x2,y2,rx,ry: single; c: TBGRAPixel; options: TRoundRectangleOptions = []); override;
     298    procedure FillRoundRectAntialias(x,y,x2,y2,rx,ry: single; texture: IBGRAScanner; options: TRoundRectangleOptions = []); override;
     299    procedure EraseRoundRectAntialias(x,y,x2,y2,rx,ry: single; alpha: byte; options: TRoundRectangleOptions = []); override;
     300    procedure AlphaFillRect(x, y, x2, y2: integer; alpha: byte); override;
     301    procedure RoundRect(X1, Y1, X2, Y2: integer; DX, DY: integer;
     302      BorderColor, FillColor: TBGRAPixel); override;
     303
     304    procedure TextOutAngle(x, y, orientation: integer; s: string; c: TBGRAPixel; align: TAlignment); override;
     305    procedure TextOutAngle(x, y, orientation: integer; s: string; texture: IBGRAScanner; align: TAlignment); override;
     306    procedure TextOut(x, y: integer; s: string; texture: IBGRAScanner; align: TAlignment); override;
     307    procedure TextOut(x, y: integer; s: string; c: TBGRAPixel; align: TAlignment); override;
     308    procedure TextRect(ARect: TRect; x, y: integer; s: string; style: TTextStyle; c: TBGRAPixel); override;
     309    procedure TextRect(ARect: TRect; x, y: integer; s: string; style: TTextStyle; texture: IBGRAScanner); override;
     310    function TextSize(s: string): TSize; override;
    206311
    207312    {Spline}
    208     function ComputeClosedSpline(points: array of TPointF): ArrayOfTPointF;
    209     function ComputeOpenedSpline(points: array of TPointF): ArrayOfTPointF;
     313    function ComputeClosedSpline(const APoints: array of TPointF; AStyle: TSplineStyle): ArrayOfTPointF; override;
     314    function ComputeOpenedSpline(const APoints: array of TPointF; AStyle: TSplineStyle): ArrayOfTPointF; override;
     315
     316    function ComputeBezierCurve(const ACurve: TCubicBezierCurve): ArrayOfTPointF; override;
     317    function ComputeBezierCurve(const ACurve: TQuadraticBezierCurve): ArrayOfTPointF; override;
     318    function ComputeBezierSpline(const ASpline: array of TCubicBezierCurve): ArrayOfTPointF; override;
     319    function ComputeBezierSpline(const ASpline: array of TQuadraticBezierCurve): ArrayOfTPointF; override;
     320
     321    function ComputeWidePolyline(const points: array of TPointF; w: single): ArrayOfTPointF; override;
     322    function ComputeWidePolyline(const points: array of TPointF; w: single; Closed: boolean): ArrayOfTPointF; override;
     323    function ComputeWidePolygon(const points: array of TPointF; w: single): ArrayOfTPointF; override;
     324
     325    function ComputeEllipse(x,y,rx,ry: single): ArrayOfTPointF; override;
     326    function ComputeEllipse(x,y,rx,ry,w: single): ArrayOfTPointF; override;
     327    function ComputeArc65536(x,y,rx,ry: single; start65536,end65536: word): ArrayOfTPointF; override;
     328    function ComputeArcRad(x,y,rx,ry: single; startRad,endRad: single): ArrayOfTPointF; override;
     329    function ComputeRoundRect(x1,y1,x2,y2,rx,ry: single): ArrayOfTPointF; override;
     330    function ComputeRoundRect(x1,y1,x2,y2,rx,ry: single; options: TRoundRectangleOptions): ArrayOfTPointF; override;
     331    function ComputePie65536(x,y,rx,ry: single; start65536,end65536: word): ArrayOfTPointF; override;
     332    function ComputePieRad(x,y,rx,ry: single; startRad,endRad: single): ArrayOfTPointF; override;
    210333
    211334    {Filling}
    212     procedure FillTransparent;
    213     procedure ApplyGlobalOpacity(alpha: byte);
    214     procedure Fill(c: TColor); overload;
    215     procedure Fill(c: TBGRAPixel); overload;
    216     procedure Fill(c: TBGRAPixel; start, Count: integer); overload;
    217     procedure DrawPixels(c: TBGRAPixel; start, Count: integer);
    218     procedure AlphaFill(alpha: byte); overload;
    219     procedure AlphaFill(alpha: byte; start, Count: integer); overload;
    220     procedure ReplaceColor(before, after: TColor); overload;
    221     procedure ReplaceColor(before, after: TBGRAPixel); overload;
    222     procedure ReplaceTransparent(after: TBGRAPixel); overload;
    223     procedure FloodFill(X, Y: integer; Color: TBGRAPixel;
    224       mode: TFloodfillMode; Tolerance: byte = 0);
    225     procedure ParallelFloodFill(X, Y: integer; Dest: TBGRADefaultBitmap; Color: TBGRAPixel;
    226       mode: TFloodfillMode; Tolerance: byte = 0);
     335    procedure NoClip; override;
     336    procedure Fill(texture: IBGRAScanner; mode: TDrawMode); override;
     337    procedure Fill(texture: IBGRAScanner); override;
     338    procedure Fill(c: TBGRAPixel; start, Count: integer); override;
     339    procedure DrawPixels(c: TBGRAPixel; start, Count: integer); override;
     340    procedure AlphaFill(alpha: byte; start, Count: integer); override;
     341    procedure FillMask(x,y: integer; AMask: TBGRACustomBitmap; color: TBGRAPixel); override;
     342    procedure FillMask(x,y: integer; AMask: TBGRACustomBitmap; texture: IBGRAScanner); override;
     343    procedure FillClearTypeMask(x,y: integer; xThird: integer; AMask: TBGRACustomBitmap; color: TBGRAPixel; ARGBOrder: boolean = true); override;
     344    procedure FillClearTypeMask(x,y: integer; xThird: integer; AMask: TBGRACustomBitmap; texture: IBGRAScanner; ARGBOrder: boolean = true); override;
     345    procedure ReplaceColor(before, after: TColor); override;
     346    procedure ReplaceColor(before, after: TBGRAPixel); override;
     347    procedure ReplaceTransparent(after: TBGRAPixel); override;
     348    procedure ParallelFloodFill(X, Y: integer; Dest: TBGRACustomBitmap; Color: TBGRAPixel;
     349      mode: TFloodfillMode; Tolerance: byte = 0); override;
    227350    procedure GradientFill(x, y, x2, y2: integer; c1, c2: TBGRAPixel;
    228351      gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode;
    229       gammaColorCorrection: boolean = True; Sinus: Boolean=False);
     352      gammaColorCorrection: boolean = True; Sinus: Boolean=False); override;
     353    procedure GradientFill(x, y, x2, y2: integer; gradient: TBGRACustomGradient;
     354      gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode;
     355      Sinus: Boolean=False); override;
     356    function CreateBrushTexture(ABrushStyle: TBrushStyle; APatternColor, ABackgroundColor: TBGRAPixel;
     357                AWidth: integer = 8; AHeight: integer = 8; APenWidth: single = 1): TBGRACustomBitmap; override;
     358    procedure ScanMoveTo(X,Y: Integer); override;
     359    function ScanNextPixel: TBGRAPixel; override;
     360    function ScanAt(X,Y: Single): TBGRAPixel; override;
     361    function IsScanPutPixelsDefined: boolean; override;
     362    procedure ScanPutPixels(pdest: PBGRAPixel; count: integer; mode: TDrawMode); override;
    230363
    231364    {Canvas drawing functions}
    232365    procedure DataDrawTransparent(ACanvas: TCanvas; Rect: TRect;
    233       AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); virtual;
     366      AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); override;
    234367    procedure DataDrawOpaque(ACanvas: TCanvas; Rect: TRect; AData: Pointer;
    235       ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); virtual;
    236     procedure GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer); virtual;
    237     procedure Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean = True); virtual;
    238     procedure Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean = True); virtual;
    239     procedure DrawPart(ARect: TRect; Canvas: TCanvas; x, y: integer; Opaque: boolean);
    240     function GetPart(ARect: TRect): TBGRADefaultBitmap;
    241     procedure InvalidateBitmap; inline; //call if you modify with Scanline
    242     procedure LoadFromBitmapIfNeeded;   //call to ensure that bitmap data is up to date
     368      ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); override;
     369    procedure GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer); override;
     370    procedure Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean = True); override;
     371    procedure Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean = True); override;
     372    procedure InvalidateBitmap; override;         //call if you modify with Scanline
     373    procedure LoadFromBitmapIfNeeded; override;   //call to ensure that bitmap data is up to date
    243374
    244375    {BGRA bitmap functions}
    245     procedure PutImage(x, y: integer; Source: TBGRADefaultBitmap; mode: TDrawMode);
    246     procedure BlendImage(x, y: integer; Source: TBGRADefaultBitmap;
    247       operation: TBlendOperation);
    248     function Duplicate: TBGRADefaultBitmap; virtual;
    249     function Equals(comp: TBGRADefaultBitmap): boolean;
    250     function Equals(comp: TBGRAPixel): boolean;
     376    procedure PutImage(x, y: integer; Source: TBGRACustomBitmap; mode: TDrawMode; AOpacity: byte = 255); override;
     377    procedure PutImageAngle(x,y: single; Source: TBGRACustomBitmap; angle: single; imageCenterX: single = 0; imageCenterY: single = 0; AOpacity: Byte=255); override;
     378    procedure PutImageAffine(Origin,HAxis,VAxis: TPointF; Source: TBGRACustomBitmap; AOpacity: Byte=255); override;
     379    procedure BlendImage(x, y: integer; Source: TBGRACustomBitmap; operation: TBlendOperation); override;
     380
     381    function GetPart(ARect: TRect): TBGRACustomBitmap; override;
     382    function GetPtrBitmap(Top,Bottom: Integer): TBGRACustomBitmap; override;
     383    function Duplicate(DuplicateProperties: Boolean = False) : TBGRACustomBitmap; override;
     384    procedure CopyPropertiesTo(ABitmap: TBGRADefaultBitmap);
     385    function Equals(comp: TBGRACustomBitmap): boolean; override;
     386    function Equals(comp: TBGRAPixel): boolean; override;
     387    function GetImageBounds(Channel: TChannel = cAlpha): TRect; override;
     388    function GetImageBounds(Channels: TChannels): TRect; override;
     389    function MakeBitmapCopy(BackgroundColor: TColor): TBitmap; override;
     390
    251391    function Resample(newWidth, newHeight: integer;
    252       mode: TResampleMode = rmFineResample): TBGRADefaultBitmap;
    253     procedure VerticalFlip;
    254     procedure HorizontalFlip;
    255     function RotateCW: TBGRADefaultBitmap;
    256     function RotateCCW: TBGRADefaultBitmap;
    257     procedure Negative;
    258     procedure LinearNegative;
    259     procedure SwapRedBlue;
    260     procedure GrayscaleToAlpha;
    261     procedure AlphaToGrayscale;
    262     procedure ApplyMask(mask: TBGRADefaultBitmap);
    263     function GetImageBounds(Channel: TChannel = cAlpha): TRect;
    264     function MakeBitmapCopy(BackgroundColor: TColor): TBitmap;
     392      mode: TResampleMode = rmFineResample): TBGRACustomBitmap; override;
     393    procedure VerticalFlip; override;
     394    procedure HorizontalFlip; override;
     395    function RotateCW: TBGRACustomBitmap; override;
     396    function RotateCCW: TBGRACustomBitmap; override;
     397    procedure Negative; override;
     398    procedure LinearNegative; override;
     399    procedure SwapRedBlue; override;
     400    procedure GrayscaleToAlpha; override;
     401    procedure AlphaToGrayscale; override;
     402    procedure ApplyMask(mask: TBGRACustomBitmap); override;
     403    procedure ApplyGlobalOpacity(alpha: byte); override;
    265404
    266405    {Filters}
    267     function FilterSmartZoom3(Option: TMedianOption): TBGRADefaultBitmap;
    268     function FilterMedian(Option: TMedianOption): TBGRADefaultBitmap;
    269     function FilterSmooth: TBGRADefaultBitmap;
    270     function FilterSharpen: TBGRADefaultBitmap;
    271     function FilterContour: TBGRADefaultBitmap;
     406    function FilterSmartZoom3(Option: TMedianOption): TBGRACustomBitmap; override;
     407    function FilterMedian(Option: TMedianOption): TBGRACustomBitmap; override;
     408    function FilterSmooth: TBGRACustomBitmap; override;
     409    function FilterSharpen: TBGRACustomBitmap; override;
     410    function FilterContour: TBGRACustomBitmap; override;
    272411    function FilterBlurRadial(radius: integer;
    273       blurType: TRadialBlurType): TBGRADefaultBitmap;
     412      blurType: TRadialBlurType): TBGRACustomBitmap; override;
     413    function FilterPixelate(pixelSize: integer; useResample: boolean; filter: TResampleFilter = rfLinear): TBGRACustomBitmap; override;
    274414    function FilterBlurMotion(distance: integer; angle: single;
    275       oriented: boolean): TBGRADefaultBitmap;
    276     function FilterCustomBlur(mask: TBGRADefaultBitmap): TBGRADefaultBitmap;
    277     function FilterEmboss(angle: single): TBGRADefaultBitmap;
    278     function FilterEmbossHighlight(FillSelection: boolean): TBGRADefaultBitmap;
    279     function FilterGrayscale: TBGRADefaultBitmap;
    280     function FilterNormalize(eachChannel: boolean = True): TBGRADefaultBitmap;
    281     function FilterRotate(origin: TPointF; angle: single): TBGRADefaultBitmap;
    282     function FilterSphere: TBGRADefaultBitmap;
    283     function FilterCylinder: TBGRADefaultBitmap;
    284     function FilterPlane: TBGRADefaultBitmap;
    285 
    286     property Data: PBGRAPixel Read GetDataPtr;
    287     property Width: integer Read FWidth;
    288     property Height: integer Read FHeight;
    289     property NbPixels: integer Read FNbPixels;
    290     property Empty: boolean Read CheckEmpty;
    291 
    292     property ScanLine[y: integer]: PBGRAPixel Read GetScanLine;
    293     property RefCount: integer Read FRefCount;
    294     property Bitmap: TBitmap Read GetBitmap;
    295     //don't forget to call InvalidateBitmap before if you changed something with Scanline
    296     property HasTransparentPixels: boolean Read GetHasTransparentPixels;
    297     property AverageColor: TColor Read GetAverageColor;
    298     property AveragePixel: TBGRAPixel Read GetAveragePixel;
    299     property LineOrder: TRawImageLineOrder Read FLineOrder;
    300     property Canvas: TCanvas Read GetCanvas;
    301     property CanvasOpacity: byte Read FCanvasOpacity Write SetCanvasOpacity;
    302     property CanvasAlphaCorrection: boolean
    303       Read GetCanvasAlphaCorrection Write SetCanvasAlphaCorrection;
    304 
    305     property FontHeight: integer Read FFontHeight Write SetFontHeight;
    306   end;
    307 
    308 type
     415      oriented: boolean): TBGRACustomBitmap; override;
     416    function FilterCustomBlur(mask: TBGRACustomBitmap): TBGRACustomBitmap; override;
     417    function FilterEmboss(angle: single): TBGRACustomBitmap; override;
     418    function FilterEmbossHighlight(FillSelection: boolean): TBGRACustomBitmap; override;
     419    function FilterGrayscale: TBGRACustomBitmap; override;
     420    function FilterNormalize(eachChannel: boolean = True): TBGRACustomBitmap; override;
     421    function FilterRotate(origin: TPointF; angle: single): TBGRACustomBitmap; override;
     422    function FilterSphere: TBGRACustomBitmap; override;
     423    function FilterTwirl(ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap; override;
     424    function FilterCylinder: TBGRACustomBitmap; override;
     425    function FilterPlane: TBGRACustomBitmap; override;
     426
     427    property CanvasBGRA: TBGRACanvas read GetCanvasBGRA;
     428    property Canvas2D: TBGRACanvas2D read GetCanvas2D;
     429  end;
     430
    309431  { TBGRAPtrBitmap }
    310432
     
    315437  public
    316438    constructor Create(AWidth, AHeight: integer; AData: Pointer); overload;
    317     function Duplicate: TBGRADefaultBitmap; override;
     439    function Duplicate(DuplicateProperties: Boolean = False): TBGRACustomBitmap; override;
    318440    procedure SetDataPtr(AData: Pointer);
    319441    property LineOrder: TRawImageLineOrder Read FLineOrder Write FLineOrder;
     
    323445  DefaultTextStyle: TTextStyle;
    324446
     447procedure BGRAGradientFill(bmp: TBGRACustomBitmap; x, y, x2, y2: integer;
     448  c1, c2: TBGRAPixel; gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode;
     449  gammaColorCorrection: boolean = True; Sinus: Boolean=False);
     450
    325451implementation
    326452
    327 uses FPWritePng, Math, LCLIntf, LCLType, BGRAPolygon, BGRAResample,
    328   BGRAFilters, BGRABlend, BGRAPaintNet,
    329   FPReadPcx, FPWritePcx, FPReadXPM, FPWriteXPM;
     453uses Math, LCLIntf, LCLType,
     454  BGRABlend, BGRAFilters, BGRAPen, BGRAText, BGRATextFX, BGRAGradientScanner,
     455  BGRAResample, BGRATransform, BGRAPolygon, BGRAPolygonAliased,
     456  BGRAPath, FPReadPcx, FPWritePcx, FPReadXPM, FPWriteXPM;
    330457
    331458type
     
    375502end;
    376503
     504function TBGRADefaultBitmap.GetCustomPenStyle: TBGRAPenStyle;
     505begin
     506  result := DuplicatePenStyle(FCustomPenStyle);
     507end;
     508
    377509procedure TBGRADefaultBitmap.SetCanvasAlphaCorrection(const AValue: boolean);
    378510begin
     
    386518end;
    387519
     520procedure TBGRADefaultBitmap.SetCanvasDrawModeFP(const AValue: TDrawMode);
     521begin
     522  FCanvasDrawModeFP := AValue;
     523  Case AValue of
     524  dmLinearBlend: FCanvasPixelProcFP := @FastBlendPixel;
     525  dmDrawWithTransparency: FCanvasPixelProcFP := @DrawPixel;
     526  dmXor: FCanvasPixelProcFP:= @XorPixel;
     527  else FCanvasPixelProcFP := @SetPixel;
     528  end;
     529end;
     530
     531function TBGRADefaultBitmap.GetCanvasDrawModeFP: TDrawMode;
     532begin
     533  Result:= FCanvasDrawModeFP;
     534end;
     535
     536procedure TBGRADefaultBitmap.SetCustomPenStyle(const AValue: TBGRAPenStyle);
     537begin
     538  FCustomPenStyle := DuplicatePenStyle(AValue);
     539end;
     540
     541procedure TBGRADefaultBitmap.SetPenStyle(const AValue: TPenStyle);
     542begin
     543  Case AValue of
     544  psSolid: CustomPenStyle := SolidPenStyle;
     545  psDash: CustomPenStyle := DashPenStyle;
     546  psDot: CustomPenStyle := DotPenStyle;
     547  psDashDot: CustomPenStyle := DashDotPenStyle;
     548  psDashDotDot: CustomPenStyle := DashDotDotPenStyle;
     549  else CustomPenStyle := ClearPenStyle;
     550  end;
     551  FPenStyle := AValue;
     552end;
     553
     554function TBGRADefaultBitmap.GetPenStyle: TPenStyle;
     555begin
     556  Result:= FPenStyle;
     557end;
     558
     559{ Update font properties to internal TFont object }
    388560procedure TBGRADefaultBitmap.UpdateFont;
    389561begin
     
    394566  if FFont.Height <> FFontHeight * FFontHeightSign then
    395567    FFont.Height := FFontHeight * FFontHeightSign;
     568  if FFont.Orientation <> FontOrientation then
     569    FFont.Orientation := FontOrientation;
     570  if FontQuality = fqSystemClearType then
     571    FFont.Quality := fqCleartype
     572  else
     573    FFont.Quality := FontDefaultQuality;
    396574end;
    397575
    398576procedure TBGRADefaultBitmap.SetFontHeight(AHeight: integer);
    399577begin
    400   if AHeight < 0 then
    401     raise ERangeError.Create('Font height must be positive');
    402578  FFontHeight := AHeight;
    403579end;
    404580
     581function TBGRADefaultBitmap.GetFontFullHeight: integer;
     582begin
     583  if FontHeight < 0 then
     584    result := -FontHeight
     585  else
     586    result := TextSize('Hg').cy;
     587end;
     588
     589procedure TBGRADefaultBitmap.SetFontFullHeight(AHeight: integer);
     590begin
     591  if AHeight > 0 then
     592    FontHeight := -AHeight
     593  else
     594    FontHeight := 1;
     595end;
     596
     597function TBGRADefaultBitmap.GetFontPixelMetric: TFontPixelMetric;
     598var fxFont: TFont;
     599begin
     600  UpdateFont;
     601  if FontQuality = fqSystem then
     602    result := BGRAText.GetFontPixelMetric(FFont)
     603  else
     604  begin
     605    FxFont := TFont.Create;
     606    FxFont.Assign(FFont);
     607    FxFont.Height := fxFont.Height*FontAntialiasingLevel;
     608    Result:= BGRAText.GetFontPixelMetric(FxFont);
     609    if Result.Baseline <> -1 then Result.Baseline:= round((Result.Baseline-1)/FontAntialiasingLevel);
     610    if Result.CapLine <> -1 then Result.CapLine:= round(Result.CapLine/FontAntialiasingLevel);
     611    if Result.DescentLine <> -1 then Result.DescentLine:= round((Result.DescentLine-1)/FontAntialiasingLevel);
     612    if Result.Lineheight <> -1 then Result.Lineheight:= round(Result.Lineheight/FontAntialiasingLevel);
     613    if Result.xLine <> -1 then Result.xLine:= round(Result.xLine/FontAntialiasingLevel);
     614  end;
     615end;
     616
     617{ Get scanline without checking bounds nor updated from TBitmap }
    405618function TBGRADefaultBitmap.GetScanlineFast(y: integer): PBGRAPixel; inline;
    406619begin
     
    423636
    424637{------------------------- Reference counter functions ------------------------}
    425 
    426 function TBGRADefaultBitmap.NewReference: TBGRADefaultBitmap;
     638{ These functions are not related to reference counting for interfaces :
     639  a reference must be explicitely freed with FreeReference }
     640
     641{ Add a new reference and gives a pointer to it }
     642function TBGRADefaultBitmap.NewReference: TBGRACustomBitmap;
    427643begin
    428644  Inc(FRefCount);
     
    430646end;
    431647
     648{ Free the current reference, and free the bitmap if necessary }
    432649procedure TBGRADefaultBitmap.FreeReference;
    433650begin
     
    445662end;
    446663
    447 function TBGRADefaultBitmap.GetUnique: TBGRADefaultBitmap;
     664{ Make sure there is only one copy of the bitmap and return
     665  the new pointer for it. If the bitmap is already unique,
     666  then it does nothing }
     667function TBGRADefaultBitmap.GetUnique: TBGRACustomBitmap;
    448668begin
    449669  if FRefCount > 1 then
     
    456676end;
    457677
    458 function TBGRADefaultBitmap.NewBitmap(AWidth, AHeight: integer): TBGRADefaultBitmap;
     678{ Creates a new bitmap. Internally, it uses the same type so that if you
     679  use an optimized version, you get a new bitmap with the same optimizations }
     680function TBGRADefaultBitmap.NewBitmap(AWidth, AHeight: integer): TBGRACustomBitmap;
    459681var
    460682  BGRAClass: TBGRABitmapAny;
     
    466688end;
    467689
    468 function TBGRADefaultBitmap.NewBitmap(Filename: string): TBGRADefaultBitmap;
     690function TBGRADefaultBitmap.NewBitmap(AWidth, AHeight: integer;
     691  Color: TBGRAPixel): TBGRACustomBitmap;
     692var
     693  BGRAClass: TBGRABitmapAny;
     694begin
     695  BGRAClass := TBGRABitmapAny(self.ClassType);
     696  if BGRAClass = TBGRAPtrBitmap then
     697    BGRAClass := TBGRADefaultBitmap;
     698  Result      := BGRAClass.Create(AWidth, AHeight, Color);
     699end;
     700
     701{ Creates a new bitmap and loads it contents from a file }
     702function TBGRADefaultBitmap.NewBitmap(Filename: string): TBGRACustomBitmap;
    469703var
    470704  BGRAClass: TBGRABitmapAny;
     
    476710{----------------------- TFPCustomImage override ------------------------------}
    477711
     712{ Creates a new bitmap, initialize properties and bitmap data }
    478713constructor TBGRADefaultBitmap.Create(AWidth, AHeight: integer);
    479714begin
     
    484719end;
    485720
    486 
     721{ Set the size of the current bitmap. All data is lost during the process }
    487722procedure TBGRADefaultBitmap.SetSize(AWidth, AHeight: integer);
    488723begin
     
    497732  FHeight   := AHeight;
    498733  FNbPixels := AWidth * AHeight;
    499   if FNbPixels < 0 then
     734  if FNbPixels < 0 then // 2 Go limit
    500735    raise EOutOfMemory.Create('Image too big');
    501736  FreeBitmap;
    502737  ReallocData;
     738  NoClip;
    503739end;
    504740
     
    515751  Init;
    516752  inherited Create(ABitmap.Width, ABitmap.Height);
    517   LoadFromRawImage(ABitmap.RawImage,0);
     753  Assign(ABitmap);
    518754end;
    519755
     
    535771begin
    536772  FreeData;
     773  FFont.Free;
    537774  FBitmap.Free;
     775  FCanvasFP.Free;
     776  FCanvasBGRA.Free;
     777  FCanvas2D.Free;
    538778  inherited Destroy;
    539779end;
     
    553793end;
    554794
    555 procedure TBGRADefaultBitmap.Assign(Bitmap: TBitmap);
     795procedure TBGRADefaultBitmap.Assign(ABitmap: TBitmap);
     796var TempBmp: TBitmap;
     797    ConvertOk: boolean;
    556798begin
    557799  DiscardBitmapChange;
    558   SetSize(Bitmap.Width, bitmap.Height);
    559   GetImageFromCanvas(Bitmap.Canvas, 0, 0);
    560 end;
    561 
    562 procedure TBGRADefaultBitmap.Assign(MemBitmap: TBGRADefaultBitmap);
     800  SetSize(ABitmap.Width, ABitmap.Height);
     801  if not LoadFromRawImage(ABitmap.RawImage,0,False,False) then
     802  begin //try to convert
     803    TempBmp := TBitmap.Create;
     804    TempBmp.Width := ABitmap.Width;
     805    TempBmp.Height := ABitmap.Height;
     806    TempBmp.Canvas.Draw(0,0,ABitmap);
     807    ConvertOk := LoadFromRawImage(TempBmp.RawImage,0,False,False);
     808    TempBmp.Free;
     809    if not ConvertOk then
     810      raise Exception.Create('Unable to convert image to 24 bit');
     811  end;
     812  If Empty then AlphaFill(255); // if bitmap seems to be empty, assume
     813                                // it is an opaque bitmap without alpha channel
     814end;
     815
     816procedure TBGRADefaultBitmap.Assign(MemBitmap: TBGRACustomBitmap);
    563817begin
    564818  DiscardBitmapChange;
     
    567821end;
    568822
     823procedure TBGRADefaultBitmap.Serialize(AStream: TStream);
     824var lWidth,lHeight: integer;
     825begin
     826  lWidth := NtoLE(Width);
     827  lHeight := NtoLE(Height);
     828  AStream.Write(lWidth,sizeof(lWidth));
     829  AStream.Write(lHeight,sizeof(lHeight));
     830  AStream.Write(Data^, NbPixels*sizeof(TBGRAPixel));
     831end;
     832
     833{$hints off}
     834procedure TBGRADefaultBitmap.Deserialize(AStream: TStream);
     835var lWidth,lHeight: integer;
     836begin
     837  AStream.Read(lWidth,sizeof(lWidth));
     838  AStream.Read(lHeight,sizeof(lHeight));
     839  lWidth := LEtoN(lWidth);
     840  lHeight := LEtoN(lHeight);
     841  SetSize(lWidth,lHeight);
     842  AStream.Read(Data^, NbPixels*sizeof(TBGRAPixel));
     843end;
     844{$hints on}
     845
     846class procedure TBGRADefaultBitmap.SerializeEmpty(AStream: TStream);
     847var zero: integer;
     848begin
     849  zero := 0;
     850  AStream.Write(zero,sizeof(zero));
     851  AStream.Write(zero,sizeof(zero));
     852end;
     853
    569854procedure TBGRADefaultBitmap.LoadFromFile(const filename: string);
    570855var
    571   tempBitmap: TBGRADefaultBitmap;
    572 begin
    573   if IsPaintDotNetFile(filename) then
    574   begin
    575     tempBitmap := LoadPaintDotNetFile(filename);
    576     Assign(tempBitmap);
    577     tempBitmap.Free;
    578   end
    579   else
    580   begin
     856  OldDrawMode: TDrawMode;
     857begin
     858  OldDrawMode := CanvasDrawModeFP;
     859  CanvasDrawModeFP := dmSet;
     860  ClipRect := rect(0,0,Width,Height);
     861  try
    581862    inherited LoadFromfile(filename);
     863  finally
     864    CanvasDrawModeFP := OldDrawMode;
    582865    ClearTransparentPixels;
    583866  end;
     
    588871  ext:    string;
    589872  writer: TFPCustomImageWriter;
    590   pngWriter: TFPWriterPNG;
    591873begin
    592874  ext := AnsiLowerCase(ExtractFileExt(filename));
    593875
     876  { When saving to PNG, define some parameters so that the
     877    image be readable by most programs }
    594878  if ext = '.png' then
    595   begin
    596     pngWriter := TFPWriterPNG.Create;
    597     pngWriter.Indexed := False;
    598     pngWriter.UseAlpha := HasTransparentPixels;
    599     pngWriter.WordSized := false;
    600     writer    := pngWriter;
    601   end else
    602   if (ext='.xpm') and (Width*Height > 32768) then
     879    writer := CreateAdaptedPngWriter
     880  else
     881  if (ext='.xpm') and (Width*Height > 32768) then //xpm is slow so avoid big images
    603882    raise exception.Create('Image is too big to be saved as XPM') else
    604883      writer := nil;
    605884
    606   if writer <> nil then
     885  if writer <> nil then //use custom writer if defined
    607886  begin
    608887    inherited SaveToFile(Filename, writer);
     
    613892end;
    614893
     894procedure TBGRADefaultBitmap.SaveToStreamAsPng(Str: TStream);
     895var writer: TFPWriterPNG;
     896begin
     897  writer := CreateAdaptedPngWriter;
     898  SaveToStream(Str,writer);
     899  writer.Free;
     900end;
     901
     902{------------------------- Clipping -------------------------------}
     903
     904{ Check if a point is in the clipping rectangle }
     905function TBGRADefaultBitmap.PtInClipRect(x, y: integer): boolean;
     906begin
     907  result := (x >= FClipRect.Left) and (y >= FClipRect.Top) and (x < FClipRect.Right) and (y < FClipRect.Bottom);
     908end;
     909
     910procedure TBGRADefaultBitmap.NoClip;
     911begin
     912  FClipRect := rect(0,0,FWidth,FHeight);
     913end;
     914
     915procedure TBGRADefaultBitmap.Fill(texture: IBGRAScanner; mode: TDrawMode);
     916begin
     917  FillRect(FClipRect.Left,FClipRect.Top,FClipRect.Right,FClipRect.Bottom,texture,mode);
     918end;
     919
     920function TBGRADefaultBitmap.GetClipRect: TRect;
     921begin
     922  Result:= FClipRect;
     923end;
     924
     925procedure TBGRADefaultBitmap.SetClipRect(const AValue: TRect);
     926begin
     927  IntersectRect(FClipRect,AValue,Rect(0,0,FWidth,FHeight));
     928end;
     929
    615930{-------------------------- Pixel functions -----------------------------------}
    616931
    617932procedure TBGRADefaultBitmap.SetPixel(x, y: integer; c: TBGRAPixel);
    618933begin
    619   if (x < 0) or (x >= Width) or (y < 0) or (y >= Height) then
    620     exit;
    621   (Scanline[y] +x)^ := c;
     934  if not PtInClipRect(x,y) then exit;
     935  LoadFromBitmapIfNeeded;
     936  (GetScanlineFast(y) +x)^ := c;
    622937  InvalidateBitmap;
    623938end;
    624939
     940procedure TBGRADefaultBitmap.XorPixel(x, y: integer; c: TBGRAPixel);
     941var
     942  p : PDWord;
     943begin
     944  if not PtInClipRect(x,y) then exit;
     945  LoadFromBitmapIfNeeded;
     946  p := PDWord(GetScanlineFast(y) +x);
     947  p^ := p^ xor DWord(c);
     948  InvalidateBitmap;
     949end;
     950
    625951procedure TBGRADefaultBitmap.SetPixel(x, y: integer; c: TColor);
    626952var
    627953  p: PByte;
    628954begin
    629   if (x < 0) or (x >= Width) or (y < 0) or (y >= Height) then
    630     exit;
    631   p  := PByte(Scanline[y] + x);
     955  if not PtInClipRect(x,y) then exit;
     956  LoadFromBitmapIfNeeded;
     957  p  := PByte(GetScanlineFast(y) + x);
    632958  p^ := c shr 16;
    633959  Inc(p);
     
    642968procedure TBGRADefaultBitmap.DrawPixel(x, y: integer; c: TBGRAPixel);
    643969begin
    644   if (x < 0) or (x >= Width) or (y < 0) or (y >= Height) then
    645     exit;
    646   DrawPixelInline(Scanline[y] + x, c);
     970  if not PtInClipRect(x,y) then exit;
     971  LoadFromBitmapIfNeeded;
     972  DrawPixelInlineWithAlphaCheck(GetScanlineFast(y) + x, c);
    647973  InvalidateBitmap;
    648974end;
    649975
     976procedure TBGRADefaultBitmap.DrawPixel(x, y: integer; ec: TExpandedPixel);
     977begin
     978  if not PtInClipRect(x,y) then exit;
     979  LoadFromBitmapIfNeeded;
     980  DrawExpandedPixelInlineWithAlphaCheck(GetScanlineFast(y) + x, ec);
     981  InvalidateBitmap;
     982end;
     983
    650984procedure TBGRADefaultBitmap.FastBlendPixel(x, y: integer; c: TBGRAPixel);
    651985begin
    652   if (x < 0) or (x >= Width) or (y < 0) or (y >= Height) then
    653     exit;
    654   FastBlendPixelInline(Scanline[y] + x, c);
     986  if not PtInClipRect(x,y) then exit;
     987  LoadFromBitmapIfNeeded;
     988  FastBlendPixelInline(GetScanlineFast(y) + x, c);
    655989  InvalidateBitmap;
    656990end;
     
    658992procedure TBGRADefaultBitmap.ErasePixel(x, y: integer; alpha: byte);
    659993begin
    660   if (x < 0) or (x >= Width) or (y < 0) or (y >= Height) then
    661     exit;
    662   ErasePixelInline(Scanline[y] + x, alpha);
     994  if not PtInClipRect(x,y) then exit;
     995  LoadFromBitmapIfNeeded;
     996  ErasePixelInline(GetScanlineFast(y) + x, alpha);
    663997  InvalidateBitmap;
    664998end;
     
    6661000procedure TBGRADefaultBitmap.AlphaPixel(x, y: integer; alpha: byte);
    6671001begin
    668   if (x < 0) or (x >= Width) or (y < 0) or (y >= Height) then
    669     exit;
     1002  if not PtInClipRect(x,y) then exit;
     1003  LoadFromBitmapIfNeeded;
    6701004  if alpha = 0 then
    671     (Scanline[y] +x)^ := BGRAPixelTransparent
     1005    (GetScanlineFast(y) +x)^ := BGRAPixelTransparent
    6721006  else
    673     (Scanline[y] +x)^.alpha := alpha;
     1007    (GetScanlineFast(y) +x)^.alpha := alpha;
    6741008  InvalidateBitmap;
    6751009end;
     
    6771011function TBGRADefaultBitmap.GetPixel(x, y: integer): TBGRAPixel;
    6781012begin
    679   if (x < 0) or (x >= Width) or (y < 0) or (y >= Height) then
     1013  if (x < 0) or (x >= Width) or (y < 0) or (y >= Height) then //it is possible to read pixels outside of the cliprect
    6801014    Result := BGRAPixelTransparent
    6811015  else
    682     Result := (Scanline[y] + x)^;
     1016  begin
     1017    LoadFromBitmapIfNeeded;
     1018    Result := (GetScanlineFast(y) + x)^;
     1019  end;
    6831020end;
    6841021
    6851022{$hints off}
    686 function TBGRADefaultBitmap.GetPixel(x, y: single): TBGRAPixel;
    687 var
    688   ix, iy, w: integer;
    689   rSum, gSum, bSum, rgbDiv: cardinal;
    690   aSum, aDiv: cardinal;
     1023{ This function compute an interpolated pixel at floating point coordinates }
     1024function TBGRADefaultBitmap.GetPixel(x, y: single; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel;
     1025var
     1026  ix, iy: integer;
     1027  w1,w2,w3,w4,alphaW: cardinal;
     1028  rSum, gSum, bSum: cardinal; //rgbDiv = aSum
     1029  aSum: cardinal;
    6911030  c:    TBGRAPixel;
    6921031  scan: PBGRAPixel;
    693 begin
    694   if (frac(x) = 0) and (frac(y) = 0) then
    695   begin
    696     Result := GetPixel(round(x), round(y));
     1032  factX,factY: single;
     1033  iFactX,iFactY: integer;
     1034begin
     1035  ix := floor(x);
     1036  iy := floor(y);
     1037  factX := x-ix; //distance from integer coordinate
     1038  factY := y-iy;
     1039
     1040  //if the coordinate is integer, then call standard GetPixel function
     1041  if (factX = 0) and (factY = 0) then
     1042  begin
     1043    Result := GetPixel(ix, iy);
    6971044    exit;
    6981045  end;
    6991046  LoadFromBitmapIfNeeded;
     1047
     1048  rSum   := 0;
     1049  gSum   := 0;
     1050  bSum   := 0;
     1051  aSum   := 0;
     1052
     1053  //apply interpolation filter
     1054  factX := FineInterpolation( factX, AResampleFilter );
     1055  factY := FineInterpolation( factY, AResampleFilter );
     1056
     1057  iFactX := round(factX*256); //integer values for fractionnal part
     1058  iFactY := round(factY*256);
     1059
     1060  w4 := (iFactX*iFactY+127) shr 8;
     1061  w3 := iFactY-w4;
     1062  w1 := (256-iFactX)-w3;
     1063  w2 := iFactX-w4;
     1064
     1065  { For each pixel around the coordinate, compute
     1066    the weight for it and multiply values by it before
     1067    adding to the sum }
     1068  if (iy >= 0) and (iy < Height) then
     1069  begin
     1070    scan := GetScanlineFast(iy);
     1071
     1072    if (ix >= 0) and (ix < Width) then
     1073    begin
     1074      c      := (scan + ix)^;
     1075      alphaW := c.alpha * w1;
     1076      aSum   += alphaW;
     1077      rSum   += c.red * alphaW;
     1078      gSum   += c.green * alphaW;
     1079      bSum   += c.blue * alphaW;
     1080    end;
     1081
     1082    Inc(ix);
     1083    if (ix >= 0) and (ix < Width) then
     1084    begin
     1085      c      := (scan + ix)^;
     1086      alphaW := c.alpha * w2;
     1087      aSum   += alphaW;
     1088      rSum   += c.red * alphaW;
     1089      gSum   += c.green * alphaW;
     1090      bSum   += c.blue * alphaW;
     1091    end;
     1092  end
     1093  else
     1094  begin
     1095    Inc(ix);
     1096  end;
     1097
     1098  Inc(iy);
     1099  if (iy >= 0) and (iy < Height) then
     1100  begin
     1101    scan := GetScanlineFast(iy);
     1102
     1103    if (ix >= 0) and (ix < Width) then
     1104    begin
     1105      c      := (scan + ix)^;
     1106      alphaW := c.alpha * w4;
     1107      aSum   += alphaW;
     1108      rSum   += c.red * alphaW;
     1109      gSum   += c.green * alphaW;
     1110      bSum   += c.blue * alphaW;
     1111    end;
     1112
     1113    Dec(ix);
     1114    if (ix >= 0) and (ix < Width) then
     1115    begin
     1116      c      := (scan + ix)^;
     1117      alphaW := c.alpha * w3;
     1118      aSum   += alphaW;
     1119      rSum   += c.red * alphaW;
     1120      gSum   += c.green * alphaW;
     1121      bSum   += c.blue * alphaW;
     1122    end;
     1123  end;
     1124
     1125  if aSum = 0 then //if there is no alpha
     1126    Result := BGRAPixelTransparent
     1127  else
     1128  begin
     1129    Result.red   := (rSum + aSum shr 1) div aSum;
     1130    Result.green := (gSum + aSum shr 1) div aSum;
     1131    Result.blue  := (bSum + aSum shr 1) div aSum;
     1132    Result.alpha := (aSum + 128) shr 8;
     1133  end;
     1134end;
     1135
     1136{ Same as GetPixel(single,single,TResampleFilter) but with coordinate cycle, supposing the image repeats itself in both directions }
     1137function TBGRADefaultBitmap.GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel;
     1138var
     1139  ix, iy, ixMod1,ixMod2: integer;
     1140  w1,w2,w3,w4,alphaW: cardinal;
     1141  bSum, gSum, rSum, rgbDiv: cardinal;
     1142  aSum: cardinal;
     1143
     1144  c:    TBGRAPixel;
     1145  scan: PBGRAPixel;
     1146  factX,factY: single;
     1147  iFactX,iFactY: integer;
     1148begin
     1149  ix := floor(x);
     1150  iy := floor(y);
     1151  factX := x-ix;
     1152  factY := y-iy;
     1153
     1154  if (factX = 0) and (factY = 0) then
     1155  begin
     1156    Result := GetPixelCycle(ix, iy);
     1157    exit;
     1158  end;
     1159  LoadFromBitmapIfNeeded;
     1160
     1161  factX := FineInterpolation( factX, AResampleFilter );
     1162  factY := FineInterpolation( factY, AResampleFilter );
     1163
     1164  iFactX := round(factX*256);
     1165  iFactY := round(factY*256);
     1166
     1167
     1168  w4 := (iFactX*iFactY+127) shr 8;
     1169  w3 := iFactY-w4;
     1170  w1 := (256-iFactX)-w3;
     1171  w2 := iFactX-w4;
    7001172
    7011173  rSum   := 0;
     
    7031175  bSum   := 0;
    7041176  rgbDiv := 0;
     1177
    7051178  aSum   := 0;
    706   aDiv   := 0;
    707 
    708   ix := floor(x);
    709   iy := floor(y);
    710 
    711   if (iy >= 0) and (iy < Height) then
    712   begin
    713     scan := GetScanlineFast(iy);
    714 
    715     if (ix >= 0) and (ix < Width) then
    716     begin
    717       c      := (scan + ix)^;
    718       w      := round((1 - (x - ix)) * (1 - (y - iy)) * 255);
    719       aDiv   += w;
    720       aSum   += c.alpha * w;
    721       c.alpha := c.alpha * w div 255;
    722       rSum   += c.red * c.alpha;
    723       gSum   += c.green * c.alpha;
    724       bSum   += c.blue * c.alpha;
    725       rgbDiv += c.alpha;
    726     end;
    727 
    728     Inc(ix);
    729     if (ix >= 0) and (ix < Width) then
    730     begin
    731       c      := (scan + ix)^;
    732       w      := round((1 - (ix - x)) * (1 - (y - iy)) * 255);
    733       aDiv   += w;
    734       aSum   += c.alpha * w;
    735       c.alpha := c.alpha * w div 255;
    736       rSum   += c.red * c.alpha;
    737       gSum   += c.green * c.alpha;
    738       bSum   += c.blue * c.alpha;
    739       rgbDiv += c.alpha;
    740     end;
    741   end
    742   else
    743     Inc(ix);
     1179
     1180  scan := GetScanlineFast(PositiveMod(iy,Height));
     1181
     1182  ixMod1 := PositiveMod(ix,Width); //apply cycle
     1183  c      := (scan + ixMod1)^;
     1184  alphaW := c.alpha * w1;
     1185  aSum   += alphaW;
     1186
     1187  rSum   += c.red * alphaW;
     1188  gSum   += c.green * alphaW;
     1189  bSum   += c.blue * alphaW;
     1190  rgbDiv += alphaW;
     1191
     1192  Inc(ix);
     1193  ixMod2 := PositiveMod(ix,Width); //apply cycle
     1194  c      := (scan + ixMod2)^;
     1195  alphaW := c.alpha * w2;
     1196  aSum   += alphaW;
     1197
     1198  rSum   += c.red * alphaW;
     1199  gSum   += c.green * alphaW;
     1200  bSum   += c.blue * alphaW;
     1201  rgbDiv += alphaW;
    7441202
    7451203  Inc(iy);
    746   if (iy >= 0) and (iy < Height) then
    747   begin
    748     scan := GetScanlineFast(iy);
    749 
    750     if (ix >= 0) and (ix < Width) then
    751     begin
    752       c      := (scan + ix)^;
    753       w      := round((1 - (ix - x)) * (1 - (iy - y)) * 255);
    754       aDiv   += w;
    755       aSum   += c.alpha * w;
    756       c.alpha := c.alpha * w div 255;
    757       rSum   += c.red * c.alpha;
    758       gSum   += c.green * c.alpha;
    759       bSum   += c.blue * c.alpha;
    760       rgbDiv += c.alpha;
    761     end;
    762 
    763     Dec(ix);
    764     if (ix >= 0) and (ix < Width) then
    765     begin
    766       c      := (scan + ix)^;
    767       w      := round((1 - (x - ix)) * (1 - (iy - y)) * 255);
    768       aDiv   += w;
    769       aSum   += c.alpha * w;
    770       c.alpha := c.alpha * w div 255;
    771       rSum   += c.red * c.alpha;
    772       gSum   += c.green * c.alpha;
    773       bSum   += c.blue * c.alpha;
    774       rgbDiv += c.alpha;
    775     end;
    776   end;
    777 
    778   if (rgbDiv = 0) or (aDiv = 0) then
     1204  scan := GetScanlineFast(PositiveMod(iy,Height));
     1205
     1206  c      := (scan + ixMod2)^;
     1207  alphaW := c.alpha * w4;
     1208  aSum   += alphaW;
     1209
     1210  rSum   += c.red * alphaW;
     1211  gSum   += c.green * alphaW;
     1212  bSum   += c.blue * alphaW;
     1213  rgbDiv += alphaW;
     1214
     1215  c      := (scan + ixMod1)^;
     1216  alphaW := c.alpha * w3;
     1217  aSum   += alphaW;
     1218
     1219  rSum   += c.red * alphaW;
     1220  gSum   += c.green * alphaW;
     1221  bSum   += c.blue * alphaW;
     1222  rgbDiv += alphaW;
     1223
     1224  if (rgbDiv = 0) then
    7791225    Result := BGRAPixelTransparent
    7801226  else
     
    7831229    Result.green := (gSum + rgbDiv shr 1) div rgbDiv;
    7841230    Result.blue  := (bSum + rgbDiv shr 1) div rgbDiv;
    785     Result.alpha := (aSum + aDiv shr 1) div aDiv;
    786   end;
     1231    Result.alpha := (aSum + 128) shr 8;
     1232  end;
     1233end;
     1234
     1235function TBGRADefaultBitmap.GetPixelCycle(x, y: single;
     1236  AResampleFilter: TResampleFilter; repeatX: boolean; repeatY: boolean
     1237  ): TBGRAPixel;
     1238var
     1239  alpha: byte;
     1240begin
     1241  alpha := 255;
     1242  if not repeatX then
     1243  begin
     1244    if (x < -0.5) or (x > Width-0.5) then
     1245    begin
     1246      result := BGRAPixelTransparent;
     1247      exit;
     1248    end;
     1249    if x < 0 then
     1250      alpha := round((0.5+x)*510)
     1251    else
     1252    if x > Width-1 then
     1253      alpha := round((Width-0.5-x)*510);
     1254  end;
     1255  if not repeatY then
     1256  begin
     1257    if (y < -0.5) or (y > Height-0.5) then
     1258    begin
     1259      result := BGRAPixelTransparent;
     1260      exit;
     1261    end;
     1262    if y < 0 then
     1263      alpha := round((0.5+y)*2*alpha)
     1264    else
     1265    if y > Height-1 then
     1266      alpha := round((Height-0.5-y)*2*alpha);
     1267  end;
     1268  result := GetPixelCycle(x,y,AResampleFilter);
     1269  if alpha<>255 then
     1270    result.alpha := ApplyOpacity(result.alpha,alpha);
    7871271end;
    7881272
    7891273{$hints on}
    790 
    791 function TBGRADefaultBitmap.GetPixelCycle(x, y: integer): TBGRAPixel;
    792 begin
    793   if (Width = 0) or (Height = 0) then
    794     Result := BGRAPixelTransparent
    795   else
    796   begin
    797     x := x mod Width;
    798     if x < 0 then
    799       Inc(x, Width);
    800     y := y mod Height;
    801     if y < 0 then
    802       Inc(y, Height);
    803     Result := (Scanline[y] + x)^;
    804   end;
    805 end;
    8061274
    8071275procedure TBGRADefaultBitmap.InvalidateBitmap;
     
    8271295end;
    8281296
    829 procedure TBGRADefaultBitmap.LoadFromRawImage(ARawImage: TRawImage;
    830   DefaultOpacity: byte; AlwaysReplaceAlpha: boolean);
    831 var
    832   psource_byte, pdest_byte: PByte;
    833   n, x, y, delta: integer;
    834   psource_pix, pdest_pix: PBGRAPixel;
    835   sourceval:      longword;
    836   OpacityOrMask:  longword;
     1297function TBGRADefaultBitmap.GetCanvasFP: TFPImageCanvas;
     1298begin
     1299  {$warnings off}
     1300  if FCanvasFP = nil then
     1301    FCanvasFP := TFPImageCanvas.Create(self);
     1302  {$warnings on}
     1303  result := FCanvasFP;
     1304end;
     1305
     1306{ Load raw image data. It must be 32bit or 24 bits per pixel}
     1307function TBGRADefaultBitmap.LoadFromRawImage(ARawImage: TRawImage;
     1308  DefaultOpacity: byte; AlwaysReplaceAlpha: boolean; RaiseErrorOnInvalidPixelFormat: boolean): boolean;
     1309var
     1310  psource_byte, pdest_byte,
     1311  psource_first, pdest_first: PByte;
     1312  psource_delta, pdest_delta: integer;
     1313
     1314  n: integer;
     1315  mustSwapRedBlue, mustReverse32: boolean;
     1316
     1317  procedure CopyAndSwapIfNecessary(psrc: PBGRAPixel; pdest: PBGRAPixel; count: integer);
     1318  begin
     1319    if mustReverse32 then
     1320    begin
     1321      while count > 0 do
     1322      begin
     1323        pdest^.blue := psrc^.alpha;
     1324        pdest^.green := psrc^.red;
     1325        pdest^.red := psrc^.green;
     1326        pdest^.alpha := psrc^.blue;
     1327        dec(count);
     1328        inc(pdest);
     1329        inc(psrc);
     1330      end;
     1331    end else
     1332    if mustSwapRedBlue then
     1333    begin
     1334      while count > 0 do
     1335      begin
     1336        pdest^.red := psrc^.blue;
     1337        pdest^.green := psrc^.green;
     1338        pdest^.blue := psrc^.red;
     1339        pdest^.alpha := psrc^.alpha;
     1340        dec(count);
     1341        inc(pdest);
     1342        inc(psrc);
     1343      end;
     1344    end else
     1345      move(psrc^,pdest^,count*sizeof(TBGRAPixel));
     1346  end;
     1347
     1348  procedure CopyRGBAndSwapIfNecessary(psrc: PByte; pdest: PBGRAPixel; count: integer);
     1349  begin
     1350    if mustSwapRedBlue then
     1351    begin
     1352      while count > 0 do
     1353      begin
     1354        pdest^.blue := (psource_byte+2)^;
     1355        pdest^.green := (psource_byte+1)^;
     1356        pdest^.red := psource_byte^;
     1357        pdest^.alpha := DefaultOpacity;
     1358        inc(psrc,3);
     1359        inc(pdest);
     1360        dec(count);
     1361      end;
     1362    end else
     1363    begin
     1364      while count > 0 do
     1365      begin
     1366        PWord(pdest)^ := PWord(psource_byte)^;
     1367        pdest^.red := (psource_byte+2)^;
     1368        pdest^.alpha := DefaultOpacity;
     1369        inc(psrc,3);
     1370        inc(pdest);
     1371        dec(count);
     1372      end;
     1373    end;
     1374  end;
     1375
     1376  procedure CopyAndSwapIfNecessaryAndSetAlpha(psrc: PBGRAPixel; pdest: PBGRAPixel; count: integer);
     1377  begin
     1378    if mustReverse32 then
     1379    begin
     1380      while count > 0 do
     1381      begin
     1382        pdest^.blue := psrc^.alpha;
     1383        pdest^.green := psrc^.red;
     1384        pdest^.red := psrc^.green;
     1385        pdest^.alpha := DefaultOpacity; //use default opacity
     1386        inc(psrc);
     1387        inc(pdest);
     1388        dec(count);
     1389      end;
     1390    end else
     1391    if mustSwapRedBlue then
     1392    begin
     1393      while count > 0 do
     1394      begin
     1395        pdest^.red := psrc^.blue;
     1396        pdest^.green := psrc^.green;
     1397        pdest^.blue := psrc^.red;
     1398        pdest^.alpha := DefaultOpacity; //use default opacity
     1399        inc(psrc);
     1400        inc(pdest);
     1401        dec(count);
     1402      end;
     1403    end else
     1404    begin
     1405      while count > 0 do
     1406      begin
     1407        PWord(pdest)^ := PWord(psource_byte)^;
     1408        pdest^.red := psrc^.red;
     1409        pdest^.alpha := DefaultOpacity; //use default opacity
     1410        inc(psrc);
     1411        inc(pdest);
     1412        dec(count);
     1413      end;
     1414    end;
     1415  end;
     1416
     1417  procedure CopyAndSwapIfNecessaryAndReplaceAlpha(psrc: PBGRAPixel; pdest: PBGRAPixel; count: integer);
     1418  var OpacityOrMask, OpacityAndMask, sourceval: Longword;
     1419  begin
     1420    OpacityOrMask := NtoLE(longword(DefaultOpacity) shl 24);
     1421    OpacityAndMask := NtoLE($FFFFFF);
     1422    if mustReverse32 then
     1423    begin
     1424      OpacityAndMask := NtoBE($FFFFFF);
     1425      while count > 0 do
     1426      begin
     1427        sourceval := plongword(psrc)^ and OpacityAndMask;
     1428        if (sourceval <> 0) and (psrc^.blue{=alpha} = 0) then //if not black but transparent
     1429        begin
     1430          pdest^.blue := psrc^.alpha;
     1431          pdest^.green := psrc^.red;
     1432          pdest^.red := psrc^.green;
     1433          pdest^.alpha := DefaultOpacity; //use default opacity
     1434        end
     1435        else
     1436        begin
     1437          pdest^.blue := psrc^.alpha;
     1438          pdest^.green := psrc^.red;
     1439          pdest^.red := psrc^.green;
     1440          pdest^.alpha := psrc^.blue;
     1441        end;
     1442        dec(count);
     1443        inc(pdest);
     1444        inc(psrc);
     1445      end;
     1446    end else
     1447    if mustSwapRedBlue then
     1448    begin
     1449      while count > 0 do
     1450      begin
     1451        sourceval := plongword(psrc)^ and OpacityAndMask;
     1452        if (sourceval <> 0) and (psrc^.alpha = 0) then //if not black but transparent
     1453        begin
     1454          pdest^.red := psrc^.blue;
     1455          pdest^.green := psrc^.green;
     1456          pdest^.blue := psrc^.red;
     1457          pdest^.alpha := DefaultOpacity; //use default opacity
     1458        end
     1459        else
     1460        begin
     1461          pdest^.red := psrc^.blue;
     1462          pdest^.green := psrc^.green;
     1463          pdest^.blue := psrc^.red;
     1464          pdest^.alpha := psrc^.alpha;
     1465        end;
     1466        dec(count);
     1467        inc(pdest);
     1468        inc(psrc);
     1469      end;
     1470    end else
     1471    begin
     1472      while count > 0 do
     1473      begin
     1474        sourceval := plongword(psrc)^ and OpacityAndMask;
     1475        if (sourceval <> 0) and (psrc^.alpha = 0) then //if not black but transparent
     1476          plongword(pdest)^ := sourceval or OpacityOrMask //use default opacity
     1477        else
     1478          pdest^ := psrc^;
     1479        dec(count);
     1480        inc(pdest);
     1481        inc(psrc);
     1482      end;
     1483    end;
     1484  end;
     1485
    8371486begin
    8381487  if (ARawImage.Description.Width <> cardinal(Width)) or
    8391488    (ARawImage.Description.Height <> cardinal(Height)) then
    840   begin
    8411489    raise Exception.Create('Bitmap size is inconsistant');
    842   end
     1490
     1491  DiscardBitmapChange;
     1492  if (Height=0) or (Width=0) then
     1493  begin
     1494    result := true;
     1495    exit;
     1496  end;
     1497
     1498  if ARawImage.Description.LineOrder = riloTopToBottom then
     1499  begin
     1500    psource_first := ARawImage.Data;
     1501    psource_delta := ARawImage.Description.BytesPerLine;
     1502  end else
     1503  begin
     1504    psource_first := ARawImage.Data + (ARawImage.Description.Height-1) * ARawImage.Description.BytesPerLine;
     1505    psource_delta := -ARawImage.Description.BytesPerLine;
     1506  end;
     1507
     1508  if ((ARawImage.Description.RedShift = 0) and
     1509    (ARawImage.Description.BlueShift = 16) and
     1510    (ARawImage.Description.ByteOrder = riboLSBFirst)) or
     1511    ((ARawImage.Description.RedShift = 24) and
     1512    (ARawImage.Description.BlueShift = 8) and
     1513    (ARawImage.Description.ByteOrder = riboMSBFirst)) then
     1514    mustSwapRedBlue:= true
    8431515  else
     1516  begin
     1517    mustSwapRedBlue:= false;
     1518    if ((ARawImage.Description.RedShift = 8) and
     1519      (ARawImage.Description.GreenShift = 16) and
     1520      (ARawImage.Description.BlueShift = 24) and
     1521      (ARawImage.Description.ByteOrder = riboLSBFirst)) or
     1522      ((ARawImage.Description.RedShift = 16) and
     1523      (ARawImage.Description.GreenShift = 8) and
     1524      (ARawImage.Description.BlueShift = 0) and
     1525      (ARawImage.Description.ByteOrder = riboMSBFirst)) then
     1526        mustReverse32 := true
     1527      else
     1528        mustReverse32 := false;
     1529  end;
     1530
     1531  if self.LineOrder = riloTopToBottom then
     1532  begin
     1533    pdest_first := PByte(self.Data);
     1534    pdest_delta := self.Width*sizeof(TBGRAPixel);
     1535  end else
     1536  begin
     1537    pdest_first := PByte(self.Data) + (self.Height-1)*self.Width*sizeof(TBGRAPixel);
     1538    pdest_delta := -self.Width*sizeof(TBGRAPixel);
     1539  end;
     1540
     1541  { 32 bits per pixel }
    8441542  if (ARawImage.Description.BitsPerPixel = 32) and
    845     (ARawImage.DataSize = longword(NbPixels) * sizeof(TBGRAPixel)) then
    846   begin
     1543    (ARawImage.DataSize >= longword(NbPixels) * 4) then
     1544  begin
     1545    { If there is an alpha channel }
    8471546    if (ARawImage.Description.AlphaPrec = 8) and not AlwaysReplaceAlpha then
    8481547    begin
    849       psource_pix := PBGRAPixel(ARawImage.Data);
    850       pdest_pix   := FData;
    8511548      if DefaultOpacity = 0 then
    852         move(psource_pix^, pdest_pix^, NbPixels * sizeof(TBGRAPixel))
     1549      begin
     1550        if ARawImage.Description.LineOrder = FLineOrder then
     1551          CopyAndSwapIfNecessary(PBGRAPixel(ARawImage.Data), FData, NbPixels) else
     1552        begin
     1553          psource_byte := psource_first;
     1554          pdest_byte := pdest_first;
     1555          for n := FHeight-1 downto 0 do
     1556          begin
     1557            CopyAndSwapIfNecessary(PBGRAPixel(psource_byte), PBGRAPixel(pdest_byte), FWidth);
     1558            inc(psource_byte, psource_delta);
     1559            inc(pdest_byte, pdest_delta);
     1560          end;
     1561        end;
     1562      end
    8531563      else
    8541564      begin
    855         OpacityOrMask := longword(DefaultOpacity) shl 24;
    856         for n := NbPixels - 1 downto 0 do
     1565        psource_byte := psource_first;
     1566        pdest_byte := pdest_first;
     1567        for n := FHeight-1 downto 0 do
    8571568        begin
    858           sourceval := plongword(psource_pix)^ and $FFFFFF;
    859           if (sourceval <> 0) and (psource_pix^.alpha = 0) then
    860           begin
    861             plongword(pdest_pix)^ := sourceval or OpacityOrMask;
    862             InvalidateBitmap;
    863           end
    864           else
    865             pdest_pix^ := psource_pix^;
    866           Inc(pdest_pix);
    867           Inc(psource_pix);
     1569          CopyAndSwapIfNecessaryAndReplaceAlpha(PBGRAPixel(psource_byte), PBGRAPixel(pdest_byte), FWidth);
     1570          inc(psource_byte, psource_delta);
     1571          inc(pdest_byte, pdest_delta);
    8681572        end;
    8691573      end;
    8701574    end
    8711575    else
    872     begin
    873       psource_byte := ARawImage.Data;
    874       pdest_byte   := PByte(FData);
    875       for n := NbPixels - 1 downto 0 do
     1576    begin { If there isn't any alpha channel }
     1577      psource_byte := psource_first;
     1578      pdest_byte := pdest_first;
     1579      for n := FHeight-1 downto 0 do
    8761580      begin
    877         PWord(pdest_byte)^ := PWord(psource_byte)^;
    878         Inc(pdest_byte, 2);
    879         Inc(psource_byte, 2);
    880         pdest_byte^ := psource_byte^;
    881         Inc(pdest_byte);
    882         Inc(psource_byte, 2);
    883         pdest_byte^ := DefaultOpacity;
    884         Inc(pdest_byte);
     1581        CopyAndSwapIfNecessaryAndSetAlpha(PBGRAPixel(psource_byte), PBGRAPixel(pdest_byte), FWidth);
     1582        inc(psource_byte, psource_delta);
     1583        inc(pdest_byte, pdest_delta);
    8851584      end;
    8861585    end;
    8871586  end
    8881587  else
     1588  { 24 bit per pixel }
    8891589  if (ARawImage.Description.BitsPerPixel = 24) then
    8901590  begin
    891     psource_byte := ARawImage.Data;
    892     pdest_byte := PByte(FData);
    893     delta := integer(ARawImage.Description.BytesPerLine) - FWidth * 3;
    894     for y := 0 to FHeight - 1 do
    895     begin
    896       for x := 0 to FWidth - 1 do
    897       begin
    898         PWord(pdest_byte)^ := PWord(psource_byte)^;
    899         Inc(pdest_byte, 2);
    900         Inc(psource_byte, 2);
    901         pdest_byte^ := psource_byte^;
    902         Inc(pdest_byte);
    903         Inc(psource_byte);
    904         pdest_byte^ := DefaultOpacity;
    905         Inc(pdest_byte);
    906       end;
    907       Inc(psource_byte, delta);
     1591    psource_byte := psource_first;
     1592    pdest_byte := pdest_first;
     1593    for n := FHeight-1 downto 0 do
     1594    begin
     1595      CopyRGBAndSwapIfNecessary(psource_byte, PBGRAPixel(pdest_byte), FWidth);
     1596      inc(psource_byte, psource_delta);
     1597      inc(pdest_byte, pdest_delta);
    9081598    end;
    9091599  end
    9101600  else
    911     raise Exception.Create('Invalid raw image format (' + IntToStr(
    912       ARawImage.Description.Depth) + ' found)');
    913   DiscardBitmapChange;
    914   if (ARawImage.Description.RedShift = 0) and
    915     (ARawImage.Description.BlueShift = 16) then
    916     SwapRedBlue;
    917   if ARawImage.Description.LineOrder <> FLineOrder then
    918     VerticalFlip;
     1601  begin
     1602    if RaiseErrorOnInvalidPixelFormat then
     1603      raise Exception.Create('Invalid raw image format (' + IntToStr(
     1604        ARawImage.Description.Depth) + ' found)') else
     1605    begin
     1606      result := false;
     1607      exit;
     1608    end;
     1609  end;
     1610
     1611  InvalidateBitmap;
     1612  result := true;
    9191613end;
    9201614
     
    9381632end;
    9391633
     1634{ Initialize properties }
    9401635procedure TBGRADefaultBitmap.Init;
    941 var
    942   HeightP1, HeightM1: integer;
    9431636begin
    9441637  FRefCount  := 1;
    9451638  FBitmap    := nil;
     1639  FCanvasFP  := nil;
     1640  FCanvasBGRA := nil;
     1641  CanvasDrawModeFP := dmDrawWithTransparency;
    9461642  FData      := nil;
    9471643  FWidth     := 0;
     
    9511647  FAlphaCorrectionNeeded := False;
    9521648  FEraseMode := False;
     1649  FillMode := fmWinding;
    9531650
    9541651  FFont     := TFont.Create;
    9551652  FontName  := 'Arial';
    9561653  FontStyle := [];
     1654  FontAntialias := False;
    9571655  FFontHeight := 20;
    958   FFontHeightSign := 1;
    959   HeightP1  := TextSize('Hg').cy;
    960   FFontHeightSign := -1;
    961   HeightM1  := TextSize('Hg').cy;
    962 
    963   if HeightP1 > HeightM1 then
    964     FFontHeightSign := 1
    965   else
    966     FFontHeightSign := -1;
     1656  FFontHeightSign := GetFontHeightSign(FFont);
     1657
     1658  PenStyle := psSolid;
     1659  LineCap := pecRound;
     1660  JoinStyle := pjsBevel;
     1661  JoinMiterLimit := 2;
     1662  ResampleFilter := rfHalfCosine;
     1663  ScanInterpolationFilter := rfLinear;
     1664  ScanOffset := Point(0,0);
    9671665end;
    9681666
    9691667procedure TBGRADefaultBitmap.SetInternalColor(x, y: integer; const Value: TFPColor);
    970 var
    971   p: PByte;
    972 begin
    973   if (x < 0) or (y < 0) or (x >= Width) or (y >= Height) then
    974     exit;
    975   p  := PByte(Scanline[y] + x);
    976   p^ := Value.blue shr 8;
    977   Inc(p);
    978   p^ := Value.green shr 8;
    979   Inc(p);
    980   p^ := Value.red shr 8;
    981   Inc(p);
    982   p^ := Value.alpha shr 8;
     1668begin
     1669  FCanvasPixelProcFP(x,y, FPColorToBGRA(Value));
     1670end;
     1671
     1672function TBGRADefaultBitmap.GetInternalColor(x, y: integer): TFPColor;
     1673begin
     1674  if (x < 0) or (y < 0) or (x >= Width) or (y >= Height) then exit;
     1675  result := BGRAToFPColor((Scanline[y] + x)^);
     1676end;
     1677
     1678procedure TBGRADefaultBitmap.SetInternalPixel(x, y: integer; Value: integer);
     1679var
     1680  c: TFPColor;
     1681begin
     1682  if not PtInClipRect(x,y) then exit;
     1683  c  := Palette.Color[Value];
     1684  (Scanline[y] + x)^ := FPColorToBGRA(c);
    9831685  InvalidateBitmap;
    9841686end;
    9851687
    986 {$hints off}
    987 function TBGRADefaultBitmap.GetInternalColor(x, y: integer): TFPColor;
    988 var
    989   p: PByte;
    990   v: byte;
    991 begin
    992   if (x < 0) or (y < 0) or (x >= Width) or (y >= Height) then
    993     exit;
    994   p := PByte(Scanline[y] + x);
    995   v := p^;
    996   Result.blue := v shl 8 + v;
    997   Inc(p);
    998   v := p^;
    999   Result.green := v shl 8 + v;
    1000   Inc(p);
    1001   v := p^;
    1002   Result.red := v shl 8 + v;
    1003   Inc(p);
    1004   v := p^;
    1005   Result.alpha := v shl 8 + v;
    1006 end;
    1007 
    1008 {$hints on}
    1009 
    1010 procedure TBGRADefaultBitmap.SetInternalPixel(x, y: integer; Value: integer);
    1011 var
    1012   p: PByte;
     1688function TBGRADefaultBitmap.GetInternalPixel(x, y: integer): integer;
     1689var
    10131690  c: TFPColor;
    10141691begin
    1015   if (x < 0) or (y < 0) or (x >= Width) or (y >= Height) then
    1016     exit;
    1017   c  := Palette.Color[Value];
    1018   p  := PByte(Scanline[y] + x);
    1019   p^ := c.blue shr 8;
    1020   Inc(p);
    1021   p^ := c.green shr 8;
    1022   Inc(p);
    1023   p^ := c.red shr 8;
    1024   Inc(p);
    1025   p^ := c.alpha shr 8;
    1026   InvalidateBitmap;
    1027 end;
    1028 
    1029 {$hints off}
    1030 function TBGRADefaultBitmap.GetInternalPixel(x, y: integer): integer;
    1031 var
    1032   p: PByte;
    1033   v: byte;
    1034   c: TFPColor;
    1035 begin
    1036   if (x < 0) or (y < 0) or (x >= Width) or (y >= Height) then
    1037     exit;
    1038   p      := PByte(Scanline[y] + x);
    1039   v      := p^;
    1040   c.blue := v shl 8 + v;
    1041   Inc(p);
    1042   v := p^;
    1043   c.green := v shl 8 + v;
    1044   Inc(p);
    1045   v     := p^;
    1046   c.red := v shl 8 + v;
    1047   Inc(p);
    1048   v      := p^;
    1049   c.alpha := v shl 8 + v;
     1692  if (x < 0) or (y < 0) or (x >= Width) or (y >= Height) then exit;
     1693  c := BGRAToFPColor((Scanline[y] + x)^);
    10501694  Result := palette.IndexOf(c);
    10511695end;
    1052 
    1053 {$hints on}
    10541696
    10551697procedure TBGRADefaultBitmap.Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean);
     
    10861728{---------------------------- Line primitives ---------------------------------}
    10871729
    1088 procedure TBGRADefaultBitmap.SetHorizLine(x, y, x2: integer; c: TBGRAPixel);
     1730function TBGRADefaultBitmap.CheckHorizLineBounds(var x,y,x2: integer): boolean; inline;
    10891731var
    10901732  temp: integer;
     
    10961738    x2   := temp;
    10971739  end;
    1098   if (x >= Width) or (x2 < 0) or (y < 0) or (y >= Height) then
     1740  if (x >= FClipRect.Right) or (x2 < FClipRect.Left) or (y < FClipRect.Top) or (y >= FClipRect.Bottom) then
     1741  begin
     1742    result := false;
    10991743    exit;
    1100   if x < 0 then
    1101     x := 0;
    1102   if x2 >= Width then
    1103     x2 := Width - 1;
     1744  end;
     1745  if x < FClipRect.Left then
     1746    x := FClipRect.Left;
     1747  if x2 >= FClipRect.Right then
     1748    x2 := FClipRect.Right - 1;
     1749  result := true;
     1750end;
     1751
     1752procedure TBGRADefaultBitmap.SetHorizLine(x, y, x2: integer; c: TBGRAPixel);
     1753begin
     1754  if not CheckHorizLineBounds(x,y,x2) then exit;
    11041755  FillInline(scanline[y] + x, c, x2 - x + 1);
    11051756  InvalidateBitmap;
    11061757end;
    11071758
     1759procedure TBGRADefaultBitmap.XorHorizLine(x, y, x2: integer; c: TBGRAPixel);
     1760begin
     1761  if not CheckHorizLineBounds(x,y,x2) then exit;
     1762  XorInline(scanline[y] + x, c, x2 - x + 1);
     1763  InvalidateBitmap;
     1764end;
     1765
    11081766procedure TBGRADefaultBitmap.DrawHorizLine(x, y, x2: integer; c: TBGRAPixel);
    1109 var
    1110   temp: integer;
    1111 begin
    1112   if (x2 < x) then
    1113   begin
    1114     temp := x;
    1115     x    := x2;
    1116     x2   := temp;
    1117   end;
    1118   if (x >= Width) or (x2 < 0) or (y < 0) or (y >= Height) then
    1119     exit;
    1120   if x < 0 then
    1121     x := 0;
    1122   if x2 >= Width then
    1123     x2 := Width - 1;
     1767begin
     1768  if not CheckHorizLineBounds(x,y,x2) then exit;
    11241769  DrawPixelsInline(scanline[y] + x, c, x2 - x + 1);
    11251770  InvalidateBitmap;
    11261771end;
    11271772
     1773procedure TBGRADefaultBitmap.DrawHorizLine(x, y, x2: integer; ec: TExpandedPixel
     1774  );
     1775begin
     1776  if not CheckHorizLineBounds(x,y,x2) then exit;
     1777  DrawExpandedPixelsInline(scanline[y] + x, ec, x2 - x + 1);
     1778  InvalidateBitmap;
     1779end;
     1780
     1781procedure TBGRADefaultBitmap.DrawHorizLine(x, y, x2: integer;
     1782  texture: IBGRAScanner);
     1783begin
     1784  if not CheckHorizLineBounds(x,y,x2) then exit;
     1785  texture.ScanMoveTo(x,y);
     1786  ScannerPutPixels(texture,scanline[y] + x, x2 - x + 1,dmDrawWithTransparency);
     1787  InvalidateBitmap;
     1788end;
     1789
    11281790procedure TBGRADefaultBitmap.FastBlendHorizLine(x, y, x2: integer; c: TBGRAPixel);
    1129 var
    1130   temp: integer;
    1131 begin
    1132   if (x2 < x) then
    1133   begin
    1134     temp := x;
    1135     x    := x2;
    1136     x2   := temp;
    1137   end;
    1138   if (x >= Width) or (x2 < 0) or (y < 0) or (y >= Height) then
    1139     exit;
    1140   if x < 0 then
    1141     x := 0;
    1142   if x2 >= Width then
    1143     x2 := Width - 1;
     1791begin
     1792  if not CheckHorizLineBounds(x,y,x2) then exit;
    11441793  FastBlendPixelsInline(scanline[y] + x, c, x2 - x + 1);
    11451794  InvalidateBitmap;
     
    11471796
    11481797procedure TBGRADefaultBitmap.AlphaHorizLine(x, y, x2: integer; alpha: byte);
    1149 var
    1150   temp: integer;
    11511798begin
    11521799  if alpha = 0 then
     
    11551802    exit;
    11561803  end;
    1157   if (x2 < x) then
    1158   begin
    1159     temp := x;
    1160     x    := x2;
    1161     x2   := temp;
    1162   end;
    1163   if (x >= Width) or (x2 < 0) or (y < 0) or (y >= Height) then
    1164     exit;
    1165   if x < 0 then
    1166     x := 0;
    1167   if x2 >= Width then
    1168     x2 := Width - 1;
     1804  if not CheckHorizLineBounds(x,y,x2) then exit;
    11691805  AlphaFillInline(scanline[y] + x, alpha, x2 - x + 1);
    11701806  InvalidateBitmap;
    11711807end;
    11721808
    1173 procedure TBGRADefaultBitmap.SetVertLine(x, y, y2: integer; c: TBGRAPixel);
    1174 var
    1175   temp, n, delta: integer;
    1176   p: PBGRAPixel;
    1177 begin
    1178   if (y2 < y) then
    1179   begin
    1180     temp := y;
    1181     y    := y2;
    1182     y2   := temp;
    1183   end;
    1184   if (y >= Height) or (y2 < 0) or (x < 0) or (x >= Width) then
    1185     exit;
    1186   if y < 0 then
    1187     y := 0;
    1188   if y2 >= Height then
    1189     y2 := Height - 1;
    1190   p    := scanline[y] + x;
     1809function TBGRADefaultBitmap.CheckVertLineBounds(var x,y,y2: integer; out delta: integer): boolean; inline;
     1810var
     1811  temp: integer;
     1812begin
    11911813  if FLineOrder = riloBottomToTop then
    11921814    delta := -Width
    11931815  else
    11941816    delta := Width;
    1195   for n := y2 - y downto 0 do
    1196   begin
    1197     p^ := c;
    1198     Inc(p, delta);
    1199   end;
    1200   InvalidateBitmap;
    1201 end;
    1202 
    1203 procedure TBGRADefaultBitmap.DrawVertLine(x, y, y2: integer; c: TBGRAPixel);
    1204 var
    1205   temp, n, delta: integer;
    1206   p: PBGRAPixel;
    1207 begin
     1817
    12081818  if (y2 < y) then
    12091819  begin
     
    12121822    y2   := temp;
    12131823  end;
    1214   if (y >= Height) or (y2 < 0) or (x < 0) or (x >= Width) then
     1824
     1825  if y < FClipRect.Top then
     1826    y := FClipRect.Top;
     1827  if y2 >= FClipRect.Bottom then
     1828    y2 := FClipRect.Bottom - 1;
     1829
     1830  if (y >= FClipRect.Bottom) or (y2 < FClipRect.Top) or (x < FClipRect.Left) or (x >= FClipRect.Right) then
     1831  begin
     1832    result := false;
    12151833    exit;
    1216   if y < 0 then
    1217     y := 0;
    1218   if y2 >= Height then
    1219     y2 := Height - 1;
     1834  end;
     1835
     1836  result := true;
     1837end;
     1838
     1839procedure TBGRADefaultBitmap.SetVertLine(x, y, y2: integer; c: TBGRAPixel);
     1840var
     1841  n, delta: integer;
     1842  p: PBGRAPixel;
     1843begin
     1844  if not CheckVertLineBounds(x,y,y2,delta) then exit;
    12201845  p    := scanline[y] + x;
    1221   if FLineOrder = riloBottomToTop then
    1222     delta := -Width
    1223   else
    1224     delta := Width;
    12251846  for n := y2 - y downto 0 do
    12261847  begin
    1227     DrawPixelInline(p, c);
     1848    p^ := c;
    12281849    Inc(p, delta);
    12291850  end;
     
    12311852end;
    12321853
     1854procedure TBGRADefaultBitmap.XorVertLine(x, y, y2: integer; c: TBGRAPixel);
     1855var
     1856  n, delta: integer;
     1857  p: PBGRAPixel;
     1858begin
     1859  if not CheckVertLineBounds(x,y,y2,delta) then exit;
     1860  p    := scanline[y] + x;
     1861  for n := y2 - y downto 0 do
     1862  begin
     1863    PDword(p)^ := PDword(p)^ xor DWord(c);
     1864    Inc(p, delta);
     1865  end;
     1866  InvalidateBitmap;
     1867end;
     1868
     1869procedure TBGRADefaultBitmap.DrawVertLine(x, y, y2: integer; c: TBGRAPixel);
     1870var
     1871  n, delta: integer;
     1872  p: PBGRAPixel;
     1873begin
     1874  if c.alpha = 255 then
     1875  begin
     1876    SetVertLine(x,y,y2,c);
     1877    exit;
     1878  end;
     1879  if not CheckVertLineBounds(x,y,y2,delta) or (c.alpha=0) then exit;
     1880  p    := scanline[y] + x;
     1881  for n := y2 - y downto 0 do
     1882  begin
     1883    DrawPixelInlineNoAlphaCheck(p, c);
     1884    Inc(p, delta);
     1885  end;
     1886  InvalidateBitmap;
     1887end;
     1888
    12331889procedure TBGRADefaultBitmap.AlphaVertLine(x, y, y2: integer; alpha: byte);
    12341890var
    1235   temp, n, delta: integer;
     1891  n, delta: integer;
    12361892  p: PBGRAPixel;
    12371893begin
     
    12411897    exit;
    12421898  end;
    1243   if (y2 < y) then
     1899  if not CheckVertLineBounds(x,y,y2,delta) then exit;
     1900  p    := scanline[y] + x;
     1901  for n := y2 - y downto 0 do
     1902  begin
     1903    p^.alpha := alpha;
     1904    Inc(p, delta);
     1905  end;
     1906  InvalidateBitmap;
     1907end;
     1908
     1909procedure TBGRADefaultBitmap.FastBlendVertLine(x, y, y2: integer; c: TBGRAPixel);
     1910var
     1911  n, delta: integer;
     1912  p: PBGRAPixel;
     1913begin
     1914  if not CheckVertLineBounds(x,y,y2,delta) then exit;
     1915  p    := scanline[y] + x;
     1916  for n := y2 - y downto 0 do
     1917  begin
     1918    FastBlendPixelInline(p, c);
     1919    Inc(p, delta);
     1920  end;
     1921  InvalidateBitmap;
     1922end;
     1923
     1924procedure TBGRADefaultBitmap.DrawHorizLineDiff(x, y, x2: integer;
     1925  c, compare: TBGRAPixel; maxDiff: byte);
     1926begin
     1927  if not CheckHorizLineBounds(x,y,x2) then exit;
     1928  DrawPixelsInlineDiff(scanline[y] + x, c, x2 - x + 1, compare, maxDiff);
     1929  InvalidateBitmap;
     1930end;
     1931
     1932{---------------------------- Lines ---------------------------------}
     1933{ Call appropriate functions }
     1934
     1935procedure TBGRADefaultBitmap.DrawLine(x1, y1, x2, y2: integer;
     1936  c: TBGRAPixel; DrawLastPixel: boolean);
     1937begin
     1938  BGRADrawLineAliased(self,x1,y1,x2,y2,c,DrawLastPixel);
     1939end;
     1940
     1941procedure TBGRADefaultBitmap.DrawLineAntialias(x1, y1, x2, y2: integer;
     1942  c: TBGRAPixel; DrawLastPixel: boolean);
     1943begin
     1944  BGRADrawLineAntialias(self,x1,y1,x2,y2,c,DrawLastPixel);
     1945end;
     1946
     1947procedure TBGRADefaultBitmap.DrawLineAntialias(x1, y1, x2, y2: integer;
     1948  c1, c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean);
     1949begin
     1950  BGRADrawLineAntialias(self,x1,y1,x2,y2,c1,c2,dashLen,DrawLastPixel);
     1951end;
     1952
     1953procedure TBGRADefaultBitmap.DrawLineAntialias(x1, y1, x2, y2: single;
     1954  c: TBGRAPixel; w: single);
     1955begin
     1956  BGRAPolyLine(self,[PointF(x1,y1),PointF(x2,y2)],w,c,LineCap,JoinStyle,FCustomPenStyle,[],nil,JoinMiterLimit);
     1957end;
     1958
     1959procedure TBGRADefaultBitmap.DrawLineAntialias(x1, y1, x2, y2: single;
     1960  texture: IBGRAScanner; w: single);
     1961begin
     1962  BGRAPolyLine(self,[PointF(x1,y1),PointF(x2,y2)],w,BGRAPixelTransparent,LineCap,JoinStyle,FCustomPenStyle,[],texture,JoinMiterLimit);
     1963end;
     1964
     1965procedure TBGRADefaultBitmap.DrawLineAntialias(x1, y1, x2, y2: single;
     1966  c: TBGRAPixel; w: single; closed: boolean);
     1967var
     1968  options: TBGRAPolyLineOptions;
     1969begin
     1970  if not closed then options := [plRoundCapOpen] else options := [];
     1971  BGRAPolyLine(self,[PointF(x1,y1),PointF(x2,y2)],w,c,pecRound,pjsRound,FCustomPenStyle,options,nil,JoinMiterLimit);
     1972end;
     1973
     1974procedure TBGRADefaultBitmap.DrawLineAntialias(x1, y1, x2, y2: single;
     1975  texture: IBGRAScanner; w: single; Closed: boolean);
     1976var
     1977  options: TBGRAPolyLineOptions;
     1978  c: TBGRAPixel;
     1979begin
     1980  if not closed then
     1981  begin
     1982    options := [plRoundCapOpen];
     1983    c := BGRAWhite; //needed for alpha junction
     1984  end else
     1985  begin
     1986    options := [];
     1987    c := BGRAPixelTransparent;
     1988  end;
     1989  BGRAPolyLine(self,[PointF(x1,y1),PointF(x2,y2)],w,c,pecRound,pjsRound,FCustomPenStyle,options,texture,JoinMiterLimit);
     1990end;
     1991
     1992procedure TBGRADefaultBitmap.DrawPolyLineAntialias(const points: array of TPointF;
     1993  c: TBGRAPixel; w: single);
     1994begin
     1995  BGRAPolyLine(self,points,w,c,LineCap,JoinStyle,FCustomPenStyle,[],nil,JoinMiterLimit);
     1996end;
     1997
     1998procedure TBGRADefaultBitmap.DrawPolyLineAntialias(
     1999  const points: array of TPointF; texture: IBGRAScanner; w: single);
     2000begin
     2001  BGRAPolyLine(self,points,w,BGRAPixelTransparent,LineCap,JoinStyle,FCustomPenStyle,[],texture,JoinMiterLimit);
     2002end;
     2003
     2004procedure TBGRADefaultBitmap.DrawPolyLineAntialias(const points: array of TPointF;
     2005  c: TBGRAPixel; w: single; Closed: boolean);
     2006var
     2007  options: TBGRAPolyLineOptions;
     2008begin
     2009  if not closed then options := [plRoundCapOpen] else options := [];
     2010  BGRAPolyLine(self,points,w,c,pecRound,JoinStyle,FCustomPenStyle,options,nil,JoinMiterLimit);
     2011end;
     2012
     2013procedure TBGRADefaultBitmap.DrawPolygonAntialias(const points: array of TPointF;
     2014  c: TBGRAPixel; w: single);
     2015begin
     2016   BGRAPolyLine(self,points,w,c,LineCap,JoinStyle,FCustomPenStyle,[plCycle],nil,JoinMiterLimit);
     2017end;
     2018
     2019procedure TBGRADefaultBitmap.DrawPolygonAntialias(
     2020  const points: array of TPointF; texture: IBGRAScanner; w: single);
     2021begin
     2022  BGRAPolyLine(self,points,w,BGRAPixelTransparent,LineCap,JoinStyle,FCustomPenStyle,[plCycle],texture,JoinMiterLimit);
     2023end;
     2024
     2025procedure TBGRADefaultBitmap.EraseLineAntialias(x1, y1, x2, y2: single;
     2026  alpha: byte; w: single; Closed: boolean);
     2027begin
     2028  FEraseMode := True;
     2029  DrawLineAntialias(x1, y1, x2, y2, BGRA(0, 0, 0, alpha), w, Closed);
     2030  FEraseMode := False;
     2031end;
     2032
     2033procedure TBGRADefaultBitmap.ErasePolyLineAntialias(const points: array of TPointF;
     2034  alpha: byte; w: single);
     2035begin
     2036  FEraseMode := True;
     2037  DrawPolyLineAntialias(points, BGRA(0,0,0,alpha),w);
     2038  FEraseMode := False;
     2039end;
     2040
     2041{------------------------ Shapes ----------------------------------------------}
     2042{ Call appropriate functions }
     2043
     2044procedure TBGRADefaultBitmap.FillTriangleLinearColor(pt1, pt2, pt3: TPointF;
     2045  c1, c2, c3: TBGRAPixel);
     2046begin
     2047  FillPolyLinearColor([pt1,pt2,pt3],[c1,c2,c3]);
     2048end;
     2049
     2050procedure TBGRADefaultBitmap.FillTriangleLinearColorAntialias(pt1, pt2,
     2051  pt3: TPointF; c1, c2, c3: TBGRAPixel);
     2052var
     2053  grad: TBGRAGradientTriangleScanner;
     2054begin
     2055  grad := TBGRAGradientTriangleScanner.Create(pt1,pt2,pt3, c1,c2,c3);
     2056  FillPolyAntialias([pt1,pt2,pt3],grad);
     2057  grad.Free;
     2058end;
     2059
     2060procedure TBGRADefaultBitmap.FillTriangleLinearMapping(pt1, pt2, pt3: TPointF;
     2061  texture: IBGRAScanner; tex1, tex2, tex3: TPointF; TextureInterpolation: Boolean= True);
     2062begin
     2063  FillPolyLinearMapping([pt1,pt2,pt3],texture,[tex1,tex2,tex3],TextureInterpolation);
     2064end;
     2065
     2066procedure TBGRADefaultBitmap.FillTriangleLinearMappingLightness(pt1, pt2,
     2067  pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF; light1,
     2068  light2, light3: word; TextureInterpolation: Boolean);
     2069begin
     2070  FillPolyLinearMappingLightness([pt1,pt2,pt3],texture,[tex1,tex2,tex3],[light1,light2,light3],TextureInterpolation);
     2071end;
     2072
     2073procedure TBGRADefaultBitmap.FillTriangleLinearMappingAntialias(pt1, pt2,
     2074  pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF);
     2075var
     2076  mapping: TBGRATriangleLinearMapping;
     2077begin
     2078  mapping := TBGRATriangleLinearMapping.Create(texture, pt1,pt2,pt3, tex1, tex2, tex3);
     2079  FillPolyAntialias([pt1,pt2,pt3],mapping);
     2080  mapping.Free;
     2081end;
     2082
     2083procedure TBGRADefaultBitmap.FillQuadLinearColor(pt1, pt2, pt3, pt4: TPointF;
     2084  c1, c2, c3, c4: TBGRAPixel);
     2085var
     2086  center: TPointF;
     2087  centerColor: TBGRAPixel;
     2088  multi: TBGRAMultishapeFiller;
     2089begin
     2090  if not IsConvex([pt1,pt2,pt3,pt4]) then //need to merge colors
     2091  begin
     2092    multi := TBGRAMultishapeFiller.Create;
     2093    multi.AddQuadLinearColor(pt1,pt2,pt3,pt4,c1,c2,c3,c4);
     2094    multi.Antialiasing:= false;
     2095    multi.Draw(self);
     2096    multi.Free;
     2097    exit;
     2098  end;
     2099  center := (pt1+pt2+pt3+pt4)*(1/4);
     2100  centerColor := GammaCompression( MergeBGRA(MergeBGRA(GammaExpansion(c1),GammaExpansion(c2)),
     2101                    MergeBGRA(GammaExpansion(c3),GammaExpansion(c4))) );
     2102  FillTriangleLinearColor(pt1,pt2,center, c1,c2,centerColor);
     2103  FillTriangleLinearColor(pt2,pt3,center, c2,c3,centerColor);
     2104  FillTriangleLinearColor(pt3,pt4,center, c3,c4,centerColor);
     2105  FillTriangleLinearColor(pt4,pt1,center, c4,c1,centerColor);
     2106end;
     2107
     2108procedure TBGRADefaultBitmap.FillQuadLinearColorAntialias(pt1, pt2, pt3,
     2109  pt4: TPointF; c1, c2, c3, c4: TBGRAPixel);
     2110var multi : TBGRAMultishapeFiller;
     2111begin
     2112  multi := TBGRAMultishapeFiller.Create;
     2113  multi.AddQuadLinearColor(pt1, pt2, pt3, pt4, c1, c2, c3, c4);
     2114  multi.Draw(self);
     2115  multi.free;
     2116end;
     2117
     2118procedure TBGRADefaultBitmap.FillQuadLinearMapping(pt1, pt2, pt3, pt4: TPointF;
     2119  texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; TextureInterpolation: Boolean= True);
     2120var
     2121  center: TPointF;
     2122  centerTex: TPointF;
     2123begin
     2124  center := (pt1+pt2+pt3+pt4)*(1/4);
     2125  centerTex := (tex1+tex2+tex3+tex4)*(1/4);
     2126  FillTriangleLinearMapping(pt1,pt2,center, texture,tex1,tex2,centerTex, TextureInterpolation);
     2127  FillTriangleLinearMapping(pt2,pt3,center, texture,tex2,tex3,centerTex, TextureInterpolation);
     2128  FillTriangleLinearMapping(pt3,pt4,center, texture,tex3,tex4,centerTex, TextureInterpolation);
     2129  FillTriangleLinearMapping(pt4,pt1,center, texture,tex4,tex1,centerTex, TextureInterpolation);
     2130end;
     2131
     2132procedure TBGRADefaultBitmap.FillQuadLinearMappingLightness(pt1, pt2, pt3,
     2133  pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; light1,
     2134  light2, light3, light4: word; TextureInterpolation: Boolean);
     2135var
     2136  center: TPointF;
     2137  centerTex: TPointF;
     2138  centerLight: word;
     2139begin
     2140  center := (pt1+pt2+pt3+pt4)*(1/4);
     2141  centerTex := (tex1+tex2+tex3+tex4)*(1/4);
     2142  centerLight := (light1+light2+light3+light4) div 4;
     2143  FillTriangleLinearMappingLightness(pt1,pt2,center, texture,tex1,tex2,centerTex, light1,light2,centerLight, TextureInterpolation);
     2144  FillTriangleLinearMappingLightness(pt2,pt3,center, texture,tex2,tex3,centerTex, light2,light3,centerLight, TextureInterpolation);
     2145  FillTriangleLinearMappingLightness(pt3,pt4,center, texture,tex3,tex4,centerTex, light3,light4,centerLight, TextureInterpolation);
     2146  FillTriangleLinearMappingLightness(pt4,pt1,center, texture,tex4,tex1,centerTex, light4,light1,centerLight, TextureInterpolation);
     2147end;
     2148
     2149procedure TBGRADefaultBitmap.FillQuadLinearMappingAntialias(pt1, pt2, pt3,
     2150  pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF);
     2151var multi : TBGRAMultishapeFiller;
     2152begin
     2153  multi := TBGRAMultishapeFiller.Create;
     2154  multi.AddQuadLinearMapping(pt1, pt2, pt3, pt4, texture, tex1,tex2,tex3,tex4);
     2155  multi.Draw(self);
     2156  multi.free;
     2157end;
     2158
     2159procedure TBGRADefaultBitmap.FillQuadPerspectiveMapping(pt1, pt2, pt3,
     2160  pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF);
     2161var
     2162  persp: TBGRAPerspectiveScannerTransform;
     2163begin
     2164  persp := TBGRAPerspectiveScannerTransform.Create(texture,[tex1,tex2,tex3,tex4],[pt1,pt2,pt3,pt4]);
     2165  FillPoly([pt1,pt2,pt3,pt4],persp,dmDrawWithTransparency);
     2166  persp.Free;
     2167end;
     2168
     2169procedure TBGRADefaultBitmap.FillQuadPerspectiveMappingAntialias(pt1, pt2, pt3,
     2170  pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF);
     2171var
     2172  persp: TBGRAPerspectiveScannerTransform;
     2173begin
     2174  persp := TBGRAPerspectiveScannerTransform.Create(texture,[tex1,tex2,tex3,tex4],[pt1,pt2,pt3,pt4]);
     2175  FillPolyAntialias([pt1,pt2,pt3,pt4],persp);
     2176  persp.Free;
     2177end;
     2178
     2179procedure TBGRADefaultBitmap.FillPolyLinearMapping(const points: array of TPointF;
     2180  texture: IBGRAScanner; texCoords: array of TPointF;
     2181  TextureInterpolation: Boolean);
     2182begin
     2183  PolygonLinearTextureMappingAliased(self,points,texture,texCoords,TextureInterpolation, FillMode = fmWinding);
     2184end;
     2185
     2186procedure TBGRADefaultBitmap.FillPolyLinearMappingLightness(
     2187  const points: array of TPointF; texture: IBGRAScanner;
     2188  texCoords: array of TPointF; lightnesses: array of word;
     2189  TextureInterpolation: Boolean);
     2190begin
     2191  PolygonLinearTextureMappingAliasedWithLightness(self,points,texture,texCoords,TextureInterpolation,lightnesses,FillMode = fmWinding);
     2192end;
     2193
     2194procedure TBGRADefaultBitmap.FillPolyLinearColor(
     2195  const points: array of TPointF; AColors: array of TBGRAPixel);
     2196begin
     2197  PolygonLinearColorGradientAliased(self,points,AColors, FillMode = fmWinding);
     2198end;
     2199
     2200procedure TBGRADefaultBitmap.FillPolyPerspectiveMapping(
     2201  const points: array of TPointF; const pointsZ: array of single;
     2202  texture: IBGRAScanner; texCoords: array of TPointF;
     2203  TextureInterpolation: Boolean);
     2204begin
     2205  PolygonPerspectiveTextureMappingAliased(self,points,pointsZ,texture,texCoords,TextureInterpolation, FillMode = fmWinding);
     2206end;
     2207
     2208procedure TBGRADefaultBitmap.FillPolyPerspectiveMappingLightness(
     2209  const points: array of TPointF; const pointsZ: array of single;
     2210  texture: IBGRAScanner; texCoords: array of TPointF;
     2211  lightnesses: array of word; TextureInterpolation: Boolean);
     2212begin
     2213  PolygonPerspectiveTextureMappingAliasedWithLightness(self,points,pointsZ,texture,texCoords,TextureInterpolation,lightnesses, FillMode = fmWinding);
     2214end;
     2215
     2216procedure TBGRADefaultBitmap.FillPoly(const points: array of TPointF;
     2217  c: TBGRAPixel; drawmode: TDrawMode);
     2218begin
     2219  BGRAPolygon.FillPolyAliased(self, points, c, FEraseMode, FillMode = fmWinding, drawmode);
     2220end;
     2221
     2222procedure TBGRADefaultBitmap.FillPoly(const points: array of TPointF;
     2223  texture: IBGRAScanner; drawmode: TDrawMode);
     2224begin
     2225  BGRAPolygon.FillPolyAliasedWithTexture(self, points, texture, FillMode = fmWinding, drawmode);
     2226end;
     2227
     2228procedure TBGRADefaultBitmap.EraseLineAntialias(x1, y1, x2, y2: single;
     2229  alpha: byte; w: single);
     2230begin
     2231  FEraseMode := True;
     2232  DrawLineAntialias(x1,y1,x2,y2, BGRA(0,0,0,alpha),w);
     2233  FEraseMode := False;
     2234end;
     2235
     2236procedure TBGRADefaultBitmap.FillPolyAntialias(const points: array of TPointF; c: TBGRAPixel);
     2237begin
     2238  BGRAPolygon.FillPolyAntialias(self, points, c, FEraseMode, FillMode = fmWinding);
     2239end;
     2240
     2241procedure TBGRADefaultBitmap.FillPolyAntialias(const points: array of TPointF;
     2242  texture: IBGRAScanner);
     2243begin
     2244  BGRAPolygon.FillPolyAntialiasWithTexture(self, points, texture, FillMode = fmWinding);
     2245end;
     2246
     2247procedure TBGRADefaultBitmap.ErasePoly(const points: array of TPointF;
     2248  alpha: byte);
     2249begin
     2250  BGRAPolygon.FillPolyAliased(self, points, BGRA(0, 0, 0, alpha), True, FillMode = fmWinding, dmDrawWithTransparency);
     2251end;
     2252
     2253procedure TBGRADefaultBitmap.ErasePolyAntialias(const points: array of TPointF; alpha: byte);
     2254begin
     2255  FEraseMode := True;
     2256  FillPolyAntialias(points, BGRA(0, 0, 0, alpha));
     2257  FEraseMode := False;
     2258end;
     2259
     2260procedure TBGRADefaultBitmap.EllipseAntialias(x, y, rx, ry: single;
     2261  c: TBGRAPixel; w: single);
     2262begin
     2263  if IsClearPenStyle(FCustomPenStyle) or (c.alpha = 0) then exit;
     2264  if IsSolidPenStyle(FCustomPenStyle) then
     2265    BGRAPolygon.BorderEllipseAntialias(self, x, y, rx, ry, w, c, FEraseMode)
     2266  else
     2267    DrawPolygonAntialias(ComputeEllipse(x,y,rx,ry),c,w);
     2268end;
     2269
     2270procedure TBGRADefaultBitmap.EllipseAntialias(x, y, rx, ry: single;
     2271  texture: IBGRAScanner; w: single);
     2272begin
     2273  if IsClearPenStyle(FCustomPenStyle) then exit;
     2274  if IsSolidPenStyle(FCustomPenStyle) then
     2275    BGRAPolygon.BorderEllipseAntialiasWithTexture(self, x, y, rx, ry, w, texture)
     2276  else
     2277    DrawPolygonAntialias(ComputeEllipse(x,y,rx,ry),texture,w);
     2278end;
     2279
     2280procedure TBGRADefaultBitmap.EllipseAntialias(x, y, rx, ry: single;
     2281  c: TBGRAPixel; w: single; back: TBGRAPixel);
     2282var multi: TBGRAMultishapeFiller;
     2283    hw: single;
     2284begin
     2285  if w=0 then exit;
     2286  rx := abs(rx);
     2287  ry := abs(ry);
     2288  hw := w/2;
     2289  if (rx <= hw) or (ry <= hw) then
     2290  begin
     2291    FillEllipseAntialias(x,y,rx+hw,ry+hw,c);
     2292    exit;
     2293  end;
     2294  { use multishape filler for fine junction between polygons }
     2295  multi := TBGRAMultishapeFiller.Create;
     2296  if not IsClearPenStyle(FCustomPenStyle) and (c.alpha <> 0) then
     2297  begin
     2298    if IsSolidPenStyle(FCustomPenStyle) then
     2299    begin
     2300      multi.AddEllipse(x,y,rx-hw,ry-hw,back);
     2301      multi.AddEllipseBorder(x,y,rx,ry,w,c)
     2302    end
     2303    else
     2304    begin
     2305      multi.AddEllipse(x,y,rx,ry,back);
     2306      multi.AddPolygon(ComputeWidePolygon(ComputeEllipse(x,y,rx,ry),w),c);
     2307      multi.PolygonOrder := poLastOnTop;
     2308    end;
     2309  end;
     2310  multi.Draw(self);
     2311  multi.Free;
     2312end;
     2313
     2314procedure TBGRADefaultBitmap.FillEllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel);
     2315begin
     2316  BGRAPolygon.FillEllipseAntialias(self, x, y, rx, ry, c, FEraseMode);
     2317end;
     2318
     2319procedure TBGRADefaultBitmap.FillEllipseAntialias(x, y, rx, ry: single;
     2320  texture: IBGRAScanner);
     2321begin
     2322  BGRAPolygon.FillEllipseAntialiasWithTexture(self, x, y, rx, ry, texture);
     2323end;
     2324
     2325procedure TBGRADefaultBitmap.FillEllipseLinearColorAntialias(x, y, rx,
     2326  ry: single; outercolor, innercolor: TBGRAPixel);
     2327var
     2328    grad: TBGRAGradientScanner;
     2329    affine: TBGRAAffineScannerTransform;
     2330begin
     2331  if (rx=0) or (ry=0) then exit;
     2332  if rx=ry then
     2333  begin
     2334    grad := TBGRAGradientScanner.Create(innercolor,outercolor,gtRadial,PointF(x,y),PointF(x+rx,y),True);
     2335    FillEllipseAntialias(x,y,rx,ry,grad);
     2336    grad.Free;
     2337  end else
     2338  begin
     2339    grad := TBGRAGradientScanner.Create(innercolor,outercolor,gtRadial,PointF(0,0),PointF(1,0),True);
     2340    affine := TBGRAAffineScannerTransform.Create(grad);
     2341    affine.Scale(rx,ry);
     2342    affine.Translate(x,y);
     2343    FillEllipseAntialias(x,y,rx,ry,affine);
     2344    affine.Free;
     2345    grad.Free;
     2346  end;
     2347end;
     2348
     2349procedure TBGRADefaultBitmap.EraseEllipseAntialias(x, y, rx, ry: single; alpha: byte);
     2350begin
     2351  FEraseMode := True;
     2352  FillEllipseAntialias(x, y, rx, ry, BGRA(0, 0, 0, alpha));
     2353  FEraseMode := False;
     2354end;
     2355
     2356procedure TBGRADefaultBitmap.RectangleAntialias(x, y, x2, y2: single;
     2357  c: TBGRAPixel; w: single; back: TBGRAPixel);
     2358var
     2359  bevel: single;
     2360  multi: TBGRAMultishapeFiller;
     2361  hw: single;
     2362begin
     2363  if IsClearPenStyle(FCustomPenStyle) or (c.alpha=0) or (w=0) then
     2364  begin
     2365    if back <> BGRAPixelTransparent then
     2366      FillRectAntialias(x,y,x2,y2,back);
     2367    exit;
     2368  end;
     2369
     2370  hw := w/2;
     2371  if not CheckAntialiasRectBounds(x,y,x2,y2,w) then
     2372  begin
     2373    if JoinStyle = pjsBevel then
     2374    begin
     2375      bevel := (2-sqrt(2))*hw;
     2376      FillRoundRectAntialias(x - hw, y - hw, x2 + hw, y2 + hw, bevel,bevel, c, [rrTopLeftBevel, rrTopRightBevel, rrBottomLeftBevel, rrBottomRightBevel]);
     2377    end else
     2378    if JoinStyle = pjsRound then
     2379     FillRoundRectAntialias(x - hw, y - hw, x2 + hw, y2 + hw, hw,hw, c)
     2380    else
     2381     FillRectAntialias(x - hw, y - hw, x2 + hw, y2 + hw, c);
     2382    exit;
     2383  end;
     2384
     2385  { use multishape filler for fine junction between polygons }
     2386  multi := TBGRAMultishapeFiller.Create;
     2387  multi.FillMode := FillMode;
     2388  if (JoinStyle = pjsMiter) and IsSolidPenStyle(FCustomPenStyle) then
     2389    multi.AddRectangleBorder(x,y,x2,y2,w,c)
     2390  else
     2391    multi.AddPolygon(ComputeWidePolygon([Pointf(x,y),Pointf(x2,y),Pointf(x2,y2),Pointf(x,y2)],w),c);
     2392
     2393  if (frac(x + hw) = 0.5) and (frac(y + hw)=0.5) and (frac(x2 - hw)=0.5) and (frac(y2 - hw)=0.5) then
     2394    FillRect(ceil(x + hw), ceil(y + hw), ceil(x2 - hw), ceil(y2 - hw), back, dmDrawWithTransparency)
     2395  else
     2396    multi.AddRectangle(x + hw, y + hw, x2 - hw, y2 - hw, back);
     2397  multi.Draw(self);
     2398  multi.Free;
     2399end;
     2400
     2401procedure TBGRADefaultBitmap.RectangleAntialias(x, y, x2, y2: single;
     2402  texture: IBGRAScanner; w: single);
     2403var
     2404  bevel,hw: single;
     2405  multi: TBGRAMultishapeFiller;
     2406begin
     2407  if IsClearPenStyle(FCustomPenStyle) or (w=0) then exit;
     2408
     2409  hw := w/2;
     2410  if not CheckAntialiasRectBounds(x,y,x2,y2,w) then
     2411  begin
     2412    if JoinStyle = pjsBevel then
     2413    begin
     2414      bevel := (2-sqrt(2))*hw;
     2415      FillRoundRectAntialias(x - hw, y - hw, x2 + hw, y2 + hw, bevel,bevel, texture, [rrTopLeftBevel, rrTopRightBevel, rrBottomLeftBevel, rrBottomRightBevel]);
     2416    end else
     2417    if JoinStyle = pjsRound then
     2418     FillRoundRectAntialias(x - hw, y - hw, x2 + hw, y2 + hw, hw,hw, texture)
     2419    else
     2420     FillRectAntialias(x - hw, y - hw, x2 + hw, y2 + hw, texture);
     2421    exit;
     2422  end;
     2423
     2424  { use multishape filler for fine junction between polygons }
     2425  multi := TBGRAMultishapeFiller.Create;
     2426  multi.FillMode := FillMode;
     2427  if (JoinStyle = pjsMiter) and IsSolidPenStyle(FCustomPenStyle) then
     2428    multi.AddRectangleBorder(x,y,x2,y2,w, texture)
     2429  else
     2430    multi.AddPolygon(ComputeWidePolygon([Pointf(x,y),Pointf(x2,y),Pointf(x2,y2),Pointf(x,y2)],w), texture);
     2431  multi.Draw(self);
     2432  multi.Free;
     2433end;
     2434
     2435procedure TBGRADefaultBitmap.RoundRectAntialias(x, y, x2, y2, rx, ry: single;
     2436   c: TBGRAPixel; w: single; options: TRoundRectangleOptions);
     2437begin
     2438  if IsClearPenStyle(FCustomPenStyle) or (c.alpha = 0) then exit;
     2439  if IsSolidPenStyle(FCustomPenStyle) then
     2440    BGRAPolygon.BorderRoundRectangleAntialias(self,x,y,x2,y2,rx,ry,w,options,c,False)
     2441  else
     2442    DrawPolygonAntialias(BGRAPath.ComputeRoundRect(x,y,x2,y2,rx,ry,options),c,w);
     2443end;
     2444
     2445procedure TBGRADefaultBitmap.RoundRectAntialias(x, y, x2, y2, rx, ry: single;
     2446  pencolor: TBGRAPixel; w: single; fillcolor: TBGRAPixel;
     2447  options: TRoundRectangleOptions);
     2448var
     2449  multi: TBGRAMultishapeFiller;
     2450begin
     2451  if IsClearPenStyle(FCustomPenStyle) or (pencolor.alpha = 0) then
     2452  begin
     2453    FillRoundRectAntialias(x,y,x2,y2,rx,ry,fillColor,options);
     2454    exit;
     2455  end;
     2456  if IsSolidPenStyle(FCustomPenStyle) then
     2457    BGRAPolygon.BorderAndFillRoundRectangleAntialias(self,x,y,x2,y2,rx,ry,w,options,pencolor,fillcolor,nil,nil,False)
     2458  else
     2459  begin
     2460    multi := TBGRAMultishapeFiller.Create;
     2461    multi.PolygonOrder := poLastOnTop;
     2462    multi.AddRoundRectangle(x,y,x2,y2,rx,ry,fillColor,options);
     2463    multi.AddPolygon(ComputeWidePolygon(BGRAPath.ComputeRoundRect(x,y,x2,y2,rx,ry,options),w),pencolor);
     2464    multi.Draw(self);
     2465    multi.Free;
     2466  end;
     2467end;
     2468
     2469procedure TBGRADefaultBitmap.RoundRectAntialias(x, y, x2, y2, rx, ry: single;
     2470  penTexture: IBGRAScanner; w: single; fillTexture: IBGRAScanner;
     2471  options: TRoundRectangleOptions);
     2472var
     2473  multi: TBGRAMultishapeFiller;
     2474begin
     2475  if IsClearPenStyle(FCustomPenStyle) then
     2476  begin
     2477    FillRoundRectAntialias(x,y,x2,y2,rx,ry,fillTexture,options);
     2478    exit;
     2479  end else
     2480  if IsSolidPenStyle(FCustomPenStyle) then
     2481    BGRAPolygon.BorderAndFillRoundRectangleAntialias(self,x,y,x2,y2,rx,ry,w,options,BGRAPixelTransparent,BGRAPixelTransparent,pentexture,filltexture,False)
     2482  else
     2483  begin
     2484    multi := TBGRAMultishapeFiller.Create;
     2485    multi.PolygonOrder := poLastOnTop;
     2486    multi.AddRoundRectangle(x,y,x2,y2,rx,ry,fillTexture,options);
     2487    multi.AddPolygon(ComputeWidePolygon(ComputeRoundRect(x,y,x2,y2,rx,ry,options),w),penTexture);
     2488    multi.Draw(self);
     2489    multi.Free;
     2490  end;
     2491end;
     2492
     2493procedure TBGRADefaultBitmap.RoundRectAntialias(x, y, x2, y2, rx, ry: single;
     2494  texture: IBGRAScanner; w: single; options: TRoundRectangleOptions);
     2495begin
     2496  if IsClearPenStyle(FCustomPenStyle) then exit;
     2497  if IsSolidPenStyle(FCustomPenStyle) then
     2498    BGRAPolygon.BorderRoundRectangleAntialiasWithTexture(self,x,y,x2,y2,rx,ry,w,options,texture)
     2499  else
     2500    DrawPolygonAntialias(BGRAPath.ComputeRoundRect(x,y,x2,y2,rx,ry,options),texture,w);
     2501end;
     2502
     2503function TBGRADefaultBitmap.CheckRectBounds(var x, y, x2, y2: integer; minsize: integer): boolean; inline;
     2504var
     2505  temp: integer;
     2506begin
     2507  //swap coordinates if needed
     2508  if (x > x2) then
     2509  begin
     2510    temp := x;
     2511    x    := x2;
     2512    x2   := temp;
     2513  end;
     2514  if (y > y2) then
    12442515  begin
    12452516    temp := y;
     
    12472518    y2   := temp;
    12482519  end;
    1249   if (y >= Height) or (y2 < 0) or (x < 0) or (x >= Width) then
     2520  if (x2 - x <= minsize) or (y2 - y <= minsize) then
     2521  begin
     2522    result := false;
    12502523    exit;
    1251   if y < 0 then
    1252     y := 0;
    1253   if y2 >= Height then
    1254     y2 := Height - 1;
    1255   p    := scanline[y] + x;
    1256   if FLineOrder = riloBottomToTop then
    1257     delta := -Width
    1258   else
    1259     delta := Width;
    1260   for n := y2 - y downto 0 do
    1261   begin
    1262     p^.alpha := alpha;
    1263     Inc(p, delta);
    1264   end;
    1265   InvalidateBitmap;
    1266 end;
    1267 
    1268 procedure TBGRADefaultBitmap.FastBlendVertLine(x, y, y2: integer; c: TBGRAPixel);
    1269 var
    1270   temp, n, delta: integer;
    1271   p: PBGRAPixel;
    1272 begin
    1273   if (y2 < y) then
    1274   begin
    1275     temp := y;
    1276     y    := y2;
    1277     y2   := temp;
    1278   end;
    1279   if (y >= Height) or (y2 < 0) or (x < 0) or (x >= Width) then
    1280     exit;
    1281   if y < 0 then
    1282     y := 0;
    1283   if y2 >= Height then
    1284     y2 := Height - 1;
    1285   p    := scanline[y] + x;
    1286   if FLineOrder = riloBottomToTop then
    1287     delta := -Width
    1288   else
    1289     delta := Width;
    1290   for n := y2 - y downto 0 do
    1291   begin
    1292     FastBlendPixelInline(p, c);
    1293     Inc(p, delta);
    1294   end;
    1295   InvalidateBitmap;
    1296 end;
    1297 
    1298 procedure TBGRADefaultBitmap.DrawHorizLineDiff(x, y, x2: integer;
    1299   c, compare: TBGRAPixel; maxDiff: byte);
    1300 var
    1301   temp: integer;
    1302 begin
    1303   if (x2 < x) then
    1304   begin
    1305     temp := x;
    1306     x    := x2;
    1307     x2   := temp;
    1308   end;
    1309   if (x >= Width) or (x2 < 0) or (y < 0) or (y >= Height) then
    1310     exit;
    1311   if x < 0 then
    1312     x := 0;
    1313   if x2 >= Width then
    1314     x2 := Width - 1;
    1315   DrawPixelsInlineDiff(scanline[y] + x, c, x2 - x + 1, compare, maxDiff);
    1316   InvalidateBitmap;
    1317 end;
    1318 
    1319 {---------------------------- Shapes ---------------------------------}
    1320 
    1321 procedure TBGRADefaultBitmap.DrawLine(x1, y1, x2, y2: integer;
    1322   c: TBGRAPixel; DrawLastPixel: boolean);
    1323 var
    1324   Y, X: integer;
    1325   DX, DY, SX, SY, E: integer;
    1326 begin
    1327 
    1328   if (Y1 = Y2) and (X1 = X2) then
    1329   begin
    1330     if DrawLastPixel then
    1331       DrawPixel(X1, Y1, c);
    1332     Exit;
    1333   end;
    1334 
    1335   DX := X2 - X1;
    1336   DY := Y2 - Y1;
    1337 
    1338   if DX < 0 then
    1339   begin
    1340     SX := -1;
    1341     DX := -DX;
    1342   end
    1343   else
    1344     SX := 1;
    1345 
    1346   if DY < 0 then
    1347   begin
    1348     SY := -1;
    1349     DY := -DY;
    1350   end
    1351   else
    1352     SY := 1;
    1353 
    1354   DX := DX shl 1;
    1355   DY := DY shl 1;
    1356 
    1357   X := X1;
    1358   Y := Y1;
    1359   if DX > DY then
    1360   begin
    1361     E := DY - DX shr 1;
    1362 
    1363     while X <> X2 do
    1364     begin
    1365       DrawPixel(X, Y, c);
    1366       if E >= 0 then
    1367       begin
    1368         Inc(Y, SY);
    1369         Dec(E, DX);
    1370       end;
    1371       Inc(X, SX);
    1372       Inc(E, DY);
    1373     end;
    1374   end
    1375   else
    1376   begin
    1377     E := DX - DY shr 1;
    1378 
    1379     while Y <> Y2 do
    1380     begin
    1381       DrawPixel(X, Y, c);
    1382       if E >= 0 then
    1383       begin
    1384         Inc(X, SX);
    1385         Dec(E, DY);
    1386       end;
    1387       Inc(Y, SY);
    1388       Inc(E, DX);
    1389     end;
    1390   end;
    1391 
    1392   if DrawLastPixel then
    1393     DrawPixel(X2, Y2, c);
    1394 end;
    1395 
    1396 procedure TBGRADefaultBitmap.DrawLineAntialias(x1, y1, x2, y2: integer;
    1397   c: TBGRAPixel; DrawLastPixel: boolean);
    1398 var
    1399   Y, X:  integer;
    1400   DX, DY, SX, SY, E: integer;
    1401   alpha: single;
    1402 begin
    1403 
    1404   if (Y1 = Y2) and (X1 = X2) then
    1405   begin
    1406     if DrawLastPixel then
    1407       DrawPixel(X1, Y1, c);
    1408     Exit;
    1409   end;
    1410 
    1411   DX := X2 - X1;
    1412   DY := Y2 - Y1;
    1413 
    1414   if DX < 0 then
    1415   begin
    1416     SX := -1;
    1417     DX := -DX;
    1418   end
    1419   else
    1420     SX := 1;
    1421 
    1422   if DY < 0 then
    1423   begin
    1424     SY := -1;
    1425     DY := -DY;
    1426   end
    1427   else
    1428     SY := 1;
    1429 
    1430   DX := DX shl 1;
    1431   DY := DY shl 1;
    1432 
    1433   X := X1;
    1434   Y := Y1;
    1435 
    1436   if DX > DY then
    1437   begin
    1438     E := 0;
    1439 
    1440     while X <> X2 do
    1441     begin
    1442       alpha := 1 - E / DX;
    1443       DrawPixel(X, Y, BGRA(c.red, c.green, c.blue, round(c.alpha * sqrt(alpha))));
    1444       DrawPixel(X, Y + SY, BGRA(c.red, c.green, c.blue,
    1445         round(c.alpha * sqrt(1 - alpha))));
    1446       Inc(E, DY);
    1447       if E >= DX then
    1448       begin
    1449         Inc(Y, SY);
    1450         Dec(E, DX);
    1451       end;
    1452       Inc(X, SX);
    1453     end;
    1454   end
    1455   else
    1456   begin
    1457     E := 0;
    1458 
    1459     while Y <> Y2 do
    1460     begin
    1461       alpha := 1 - E / DY;
    1462       DrawPixel(X, Y, BGRA(c.red, c.green, c.blue, round(c.alpha * sqrt(alpha))));
    1463       DrawPixel(X + SX, Y, BGRA(c.red, c.green, c.blue,
    1464         round(c.alpha * sqrt(1 - alpha))));
    1465       Inc(E, DX);
    1466       if E >= DY then
    1467       begin
    1468         Inc(X, SX);
    1469         Dec(E, DY);
    1470       end;
    1471       Inc(Y, SY);
    1472     end;
    1473   end;
    1474   if DrawLastPixel then
    1475     DrawPixel(X2, Y2, c);
    1476 end;
    1477 
    1478 procedure TBGRADefaultBitmap.DrawPolyLineAntialias(points: array of TPoint;
    1479   c: TBGRAPixel; DrawLastPixel: boolean);
    1480 var i: integer;
    1481 begin
    1482    if length(points) = 1 then
    1483    begin
    1484      if DrawLastPixel then DrawPixel(points[0].x,points[0].y,c);
    1485    end
    1486    else
    1487      for i := 0 to high(points)-1 do
    1488        DrawLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y,c,DrawLastPixel and (i=high(points)-1));
    1489 end;
    1490 
    1491 procedure TBGRADefaultBitmap.DrawLineAntialias(x1, y1, x2, y2: integer;
    1492   c1, c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean);
    1493 var
    1494   Y, X:  integer;
    1495   DX, DY, SX, SY, E: integer;
    1496   alpha: single;
    1497   c:     TBGRAPixel;
    1498   DashPos: integer;
    1499 begin
    1500 
    1501   c := c1;
    1502   DashPos := 0;
    1503 
    1504   if (Y1 = Y2) and (X1 = X2) then
    1505   begin
    1506     if DrawLastPixel then
    1507       DrawPixel(X1, Y1, c);
    1508     Exit;
    1509   end;
    1510 
    1511   DX := X2 - X1;
    1512   DY := Y2 - Y1;
    1513 
    1514   if DX < 0 then
    1515   begin
    1516     SX := -1;
    1517     DX := -DX;
    1518   end
    1519   else
    1520     SX := 1;
    1521 
    1522   if DY < 0 then
    1523   begin
    1524     SY := -1;
    1525     DY := -DY;
    1526   end
    1527   else
    1528     SY := 1;
    1529 
    1530   DX := DX shl 1;
    1531   DY := DY shl 1;
    1532 
    1533   X := X1;
    1534   Y := Y1;
    1535 
    1536   if DX > DY then
    1537   begin
    1538     E := 0;
    1539 
    1540     while X <> X2 do
    1541     begin
    1542       alpha := 1 - E / DX;
    1543       DrawPixel(X, Y, BGRA(c.red, c.green, c.blue, round(c.alpha * sqrt(alpha))));
    1544       DrawPixel(X, Y + SY, BGRA(c.red, c.green, c.blue,
    1545         round(c.alpha * sqrt(1 - alpha))));
    1546       Inc(E, DY);
    1547       if E >= DX then
    1548       begin
    1549         Inc(Y, SY);
    1550         Dec(E, DX);
    1551       end;
    1552       Inc(X, SX);
    1553 
    1554       Inc(DashPos);
    1555       if DashPos = DashLen then
    1556         c := c2
    1557       else
    1558       if DashPos = DashLen + DashLen then
    1559       begin
    1560         c := c1;
    1561         DashPos := 0;
    1562       end;
    1563     end;
    1564   end
    1565   else
    1566   begin
    1567     E := 0;
    1568 
    1569     while Y <> Y2 do
    1570     begin
    1571       alpha := 1 - E / DY;
    1572       DrawPixel(X, Y, BGRA(c.red, c.green, c.blue, round(c.alpha * sqrt(alpha))));
    1573       DrawPixel(X + SX, Y, BGRA(c.red, c.green, c.blue,
    1574         round(c.alpha * sqrt(1 - alpha))));
    1575       Inc(E, DX);
    1576       if E >= DY then
    1577       begin
    1578         Inc(X, SX);
    1579         Dec(E, DY);
    1580       end;
    1581       Inc(Y, SY);
    1582 
    1583       Inc(DashPos);
    1584       if DashPos = DashLen then
    1585         c := c2
    1586       else
    1587       if DashPos = DashLen + DashLen then
    1588       begin
    1589         c := c1;
    1590         DashPos := 0;
    1591       end;
    1592     end;
    1593   end;
    1594   if DrawLastPixel then
    1595     DrawPixel(X2, Y2, c);
    1596 end;
    1597 
    1598 procedure TBGRADefaultBitmap.DrawPolyLineAntialias(points: array of TPoint; c1,
    1599   c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean);
    1600 var i: integer;
    1601 begin
    1602    if length(points) = 1 then
    1603    begin
    1604      if DrawLastPixel then DrawPixel(points[0].x,points[0].y,c1);
    1605    end
    1606    else
    1607      for i := 0 to high(points)-1 do
    1608        DrawLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y,c1,c2,dashLen,DrawLastPixel and (i=high(points)-1));
    1609 end;
    1610 
    1611 procedure TBGRADefaultBitmap.DrawLineAntialias(x1, y1, x2, y2: single;
    1612   c: TBGRAPixel; w: single; closed: boolean);
    1613 var
    1614   dx, dy, d, hx, hy, wx, wy, t, t2, t3: single;
    1615   nbInter, i: integer;
    1616 
    1617   poly: array of tpointf;
    1618   alphaFactor: single;
    1619 begin
    1620   if (w <= 0) then
    1621     exit;
    1622   if (w = 1) and (frac(x1) = 0) and (frac(y1) = 0) and (frac(x2) = 0) and
    1623     (frac(y2) = 0) then
    1624   begin
    1625     DrawLineAntialias(round(x1), round(y1), round(x2), round(y2), c, closed);
    1626     exit;
    1627   end;
    1628 
    1629   dx := x2 - x1;
    1630   dy := y2 - y1;
    1631   if (dx = 0) and (dy = 0) then
    1632   begin
    1633     if closed then
    1634       FillEllipseAntialias(x1, y1, w / 2, w / 2, c);
    1635     exit;
    1636   end;
    1637 
    1638   d  := sqrt(sqr(dx) + sqr(dy));
    1639   dx /= d;
    1640   dy /= d;
    1641   hx := dy * w / 2;
    1642   hy := -dx * w / 2;
    1643   wx := dx * w / 2;
    1644   wy := dy * w / 2;
    1645 
    1646   nbInter := (ceil(w) + 1) * 2;
    1647   setlength(poly, 4 + nbInter * 2);
    1648   poly[0] := pointf(x1 + hx, y1 + hy);
    1649   poly[1] := pointf(x2 + hx, y2 + hy);
    1650 
    1651   if closed then
    1652   begin
    1653     for i := 0 to nbInter - 1 do
    1654     begin
    1655       t  := 1 - (i + 1) / (nbInter + 1) * 2;
    1656       t2 := sqrt(1 - sqr(t));
    1657       poly[2 + i] := pointf(x2 + t * hx + t2 * wx, y2 + t * hy + t2 * wy);
    1658     end;
    1659   end
    1660   else
    1661   begin
    1662     if c.alpha=255 then alphaFactor := 1 else
    1663     begin
    1664       alphaFactor := sqr(c.alpha / 255) / 2.5;
    1665       if (c.alpha > 220) then
    1666       begin
    1667         t := sqr(sqr((c.alpha-220)/(255-220)));
    1668         alphaFactor := alphaFactor*(1-t)+0.8*t;
    1669       end;
    1670     end;
    1671     for i := 0 to nbInter - 1 do
    1672     begin
    1673       t  := 1 - (i + 1) / (nbInter + 1) * 2;
    1674       t2 := sqrt(1 - sqr(t));
    1675       t3 := (1 - t2) * 0.7;
    1676       poly[2 + i] := pointf(x2 + t * hx - t2 * wx + dx * (alphaFactor + t3),
    1677         y2 + t * hy - t2 * wy + dy * (alphaFactor + t3));
    1678     end;
    1679   end;
    1680 
    1681   poly[2 + nbinter] := pointf(x2 - hx, y2 - hy);
    1682   poly[3 + nbinter] := pointf(x1 - hx, y1 - hy);
    1683 
    1684   for i := 0 to nbInter - 1 do
    1685   begin
    1686     t  := (i + 1) / (nbInter + 1) * 2 - 1;
    1687     t2 := sqrt(1 - sqr(t));
    1688     poly[4 + nbinter + i] := pointf(x1 + t * hx - t2 * wx, y1 + t * hy - t2 * wy);
    1689   end;
    1690 
    1691   FillPolyAntialias(poly, c);
    1692 end;
    1693 
    1694 procedure TBGRADefaultBitmap.DrawPolyLineAntialias(points: array of TPointF;
    1695   c: TBGRAPixel; w: single; Closed: boolean);
    1696 var i: integer;
    1697 begin
    1698    if length(points) = 1 then
    1699    begin
    1700      if Closed then DrawLineAntialias(points[0].x,points[0].y,points[0].x,points[0].y,c,w,true);
    1701    end
    1702    else
    1703      for i := 0 to high(points)-1 do
    1704        DrawLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y,c,w,Closed and (i=high(points)-1));
    1705 end;
    1706 
    1707 procedure TBGRADefaultBitmap.DrawPolygonAntialias(points: array of TPointF;
    1708   c: TBGRAPixel; w: single);
    1709 var i: integer;
    1710 begin
    1711    if length(points) = 1 then
    1712    begin
    1713      DrawLineAntialias(points[0].x,points[0].y,points[0].x,points[0].y,c,w,true);
    1714    end
    1715    else
    1716    if length(points) > 1 then
    1717    begin
    1718      for i := 0 to high(points)-1 do
    1719        DrawLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y,c,w,False);
    1720      DrawLineAntialias(points[high(points)].x,points[high(points)].Y,points[0].x,points[0].y,c,w,False);
    1721    end;
    1722 end;
    1723 
    1724 procedure TBGRADefaultBitmap.EraseLineAntialias(x1, y1, x2, y2: single;
    1725   alpha: byte; w: single; Closed: boolean);
    1726 begin
    1727   FEraseMode := True;
    1728   DrawLineAntialias(x1, y1, x2, y2, BGRA(0, 0, 0, alpha), w, Closed);
    1729   FEraseMode := False;
    1730 end;
    1731 
    1732 procedure TBGRADefaultBitmap.FillPolyAntialias(points: array of TPointF; c: TBGRAPixel);
    1733 begin
    1734   BGRAPolygon.FillPolyAntialias(self, points, c, FEraseMode);
    1735 end;
    1736 
    1737 procedure TBGRADefaultBitmap.ErasePolyAntialias(points: array of TPointF; alpha: byte);
    1738 begin
    1739   FEraseMode := True;
    1740   FillPolyAntialias(points, BGRA(0, 0, 0, alpha));
    1741   FEraseMode := False;
    1742 end;
    1743 
    1744 procedure TBGRADefaultBitmap.EllipseAntialias(x, y, rx, ry: single;
    1745   c: TBGRAPixel; w: single);
    1746 begin
    1747   BGRAPolygon.BorderEllipseAntialias(self, x, y, rx, ry, w, c, FEraseMode);
    1748 end;
    1749 
    1750 procedure TBGRADefaultBitmap.FillEllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel);
    1751 begin
    1752   BGRAPolygon.FillEllipseAntialias(self, x, y, rx, ry, c, FEraseMode);
    1753 end;
    1754 
    1755 procedure TBGRADefaultBitmap.EraseEllipseAntialias(x, y, rx, ry: single; alpha: byte);
    1756 begin
    1757   FEraseMode := True;
    1758   FillEllipseAntialias(x, y, rx, ry, BGRA(0, 0, 0, alpha));
    1759   FEraseMode := False;
    1760 end;
    1761 
    1762 {------------------------ Shapes ----------------------------------------------}
    1763 
    1764 procedure TBGRADefaultBitmap.Rectangle(x, y, x2, y2: integer; c: TColor);
    1765 begin
    1766   Rectangle(x, y, x2, y2, ColorToBGRA(c), dmSet);
    1767 end;
    1768 
    1769 procedure TBGRADefaultBitmap.Rectangle(r: TRect; c: TBGRAPixel; mode: TDrawMode);
    1770 begin
    1771   Rectangle(r.left, r.top, r.right, r.bottom, c, mode);
    1772 end;
    1773 
    1774 procedure TBGRADefaultBitmap.Rectangle(r: TRect; BorderColor, FillColor: TBGRAPixel;
    1775   mode: TDrawMode);
    1776 begin
    1777   Rectangle(r.left, r.top, r.right, r.bottom, BorderColor, FillColor, mode);
    1778 end;
    1779 
    1780 procedure TBGRADefaultBitmap.Rectangle(r: TRect; c: TColor);
    1781 begin
    1782   Rectangle(r.left, r.top, r.right, r.bottom, c);
    1783 end;
    1784 
    1785 procedure TBGRADefaultBitmap.RectangleAntialias(x, y, x2, y2: single;
    1786   c: TBGRAPixel; w: single);
    1787 begin
    1788   RectangleAntialias(x, y, x2, y2, c, w, BGRAPixelTransparent);
    1789 end;
    1790 
    1791 procedure TBGRADefaultBitmap.RectangleAntialias(x, y, x2, y2: single;
    1792   c: TBGRAPixel; w: single; back: TBGRAPixel);
    1793 var
    1794   poly: array of TPointF;
    1795   temp: single;
    1796 begin
    1797   if (x > x2) then
    1798   begin
    1799     temp := x;
    1800     x    := x2;
    1801     x2   := temp;
    1802   end;
    1803   if (y > y2) then
    1804   begin
    1805     temp := y;
    1806     y    := y2;
    1807     y2   := temp;
    1808   end;
    1809 
    1810   if (x2 - x <= w) or (y2 - y <= w) then
    1811   begin
    1812     FillRectAntialias(x - w / 2, y - w / 2, x2 + w / 2, y2 + w / 2, c);
    1813     exit;
    1814   end;
    1815   w /= 2;
    1816 
    1817   setlength(poly, 9);
    1818   poly[0] := pointf(x - w, y - w);
    1819   poly[1] := pointf(x2 + w, y - w);
    1820   poly[2] := pointf(x2 + w, y2 + w);
    1821   poly[3] := pointf(x - w, y2 + w);
    1822   poly[4] := EmptyPointF;
    1823   poly[5] := pointf(x + w, y + w);
    1824   poly[6] := pointf(x2 - w, y + w);
    1825   poly[7] := pointf(x2 - w, y2 - w);
    1826   poly[8] := pointf(x + w, y2 - w);
    1827   FillPolyAntialias(poly, c);
    1828 
    1829   if back.alpha <> 0 then
    1830     FillRectAntialias(x + w, y + w, x2 - w, y2 - w, back);
    1831 end;
    1832 
    1833 procedure TBGRADefaultBitmap.FillRect(r: TRect; c: TColor);
    1834 begin
    1835   FillRect(r.Left, r.top, r.right, r.bottom, c);
    1836 end;
    1837 
    1838 procedure TBGRADefaultBitmap.FillRect(r: TRect; c: TBGRAPixel; mode: TDrawMode);
    1839 begin
    1840   FillRect(r.Left, r.top, r.right, r.bottom, c, mode);
     2524  end else
     2525    result := true;
    18412526end;
    18422527
    18432528procedure TBGRADefaultBitmap.Rectangle(x, y, x2, y2: integer;
    18442529  c: TBGRAPixel; mode: TDrawMode);
    1845 var
    1846   temp: integer;
    1847 begin
    1848   if (x > x2) then
    1849   begin
    1850     temp := x;
    1851     x    := x2;
    1852     x2   := temp;
    1853   end;
    1854   if (y > y2) then
    1855   begin
    1856     temp := y;
    1857     y    := y2;
    1858     y2   := temp;
    1859   end;
    1860   if (x2 - x <= 1) or (y2 - y <= 1) then
    1861     exit;
     2530begin
     2531  if not CheckRectBounds(x,y,x2,y2,1) then exit;
    18622532  case mode of
    18632533    dmFastBlend:
     
    18912561      end;
    18922562    end;
     2563    dmXor:
     2564    begin
     2565      XorHorizLine(x, y, x2 - 1, c);
     2566      XorHorizLine(x, y2 - 1, x2 - 1, c);
     2567      if y2 - y > 2 then
     2568      begin
     2569        XorVertLine(x, y + 1, y2 - 2, c);
     2570        XorVertLine(x2 - 1, y + 1, y2 - 2, c);
     2571      end;
     2572    end;
    18932573    dmSetExceptTransparent: if (c.alpha = 255) then
    18942574        Rectangle(x, y, x2, y2, c, dmSet);
     
    18982578procedure TBGRADefaultBitmap.Rectangle(x, y, x2, y2: integer;
    18992579  BorderColor, FillColor: TBGRAPixel; mode: TDrawMode);
     2580begin
     2581  if not CheckRectBounds(x,y,x2,y2,1) then exit;
     2582  Rectangle(x, y, x2, y2, BorderColor, mode);
     2583  FillRect(x + 1, y + 1, x2 - 1, y2 - 1, FillColor, mode);
     2584end;
     2585
     2586function TBGRADefaultBitmap.CheckClippedRectBounds(var x, y, x2, y2: integer): boolean; inline;
    19002587var
    19012588  temp: integer;
     
    19132600    y2   := temp;
    19142601  end;
    1915   if (x2 - x <= 1) or (y2 - y <= 1) then
     2602  if (x >= FClipRect.Right) or (x2 <= FClipRect.Left) or (y >= FClipRect.Bottom) or (y2 <= FClipRect.Top) then
     2603  begin
     2604    result := false;
    19162605    exit;
    1917 
    1918   Rectangle(x, y, x2, y2, BorderColor, mode);
    1919   FillRect(x + 1, y + 1, x2 - 1, y2 - 1, FillColor, mode);
    1920 end;
    1921 
    1922 procedure TBGRADefaultBitmap.FillRect(x, y, x2, y2: integer; c: TColor);
    1923 begin
    1924   FillRect(x, y, x2, y2, ColorToBGRA(c), dmSet);
     2606  end;
     2607  if x < FClipRect.Left then
     2608    x := FClipRect.Left;
     2609  if x2 > FClipRect.Right then
     2610    x2 := FClipRect.Right;
     2611  if y < FClipRect.Top then
     2612    y := FClipRect.Top;
     2613  if y2 > FClipRect.Bottom then
     2614    y2 := FClipRect.Bottom;
     2615  if (x2 - x <= 0) or (y2 - y <= 0) then
     2616  begin
     2617    result := false;
     2618    exit;
     2619  end else
     2620    result := true;
    19252621end;
    19262622
     
    19282624  mode: TDrawMode);
    19292625var
    1930   temp, yb, tx, delta: integer;
     2626  yb, tx, delta: integer;
    19312627  p: PBGRAPixel;
    19322628begin
    1933   if (x > x2) then
    1934   begin
    1935     temp := x;
    1936     x    := x2;
    1937     x2   := temp;
    1938   end;
    1939   if (y > y2) then
    1940   begin
    1941     temp := y;
    1942     y    := y2;
    1943     y2   := temp;
    1944   end;
    1945   if (x >= Width) or (x2 <= 0) or (y >= Height) or (y2 <= 0) then
    1946     exit;
    1947   if x < 0 then
    1948     x := 0;
    1949   if x2 > Width then
    1950     x2 := Width;
    1951   if y < 0 then
    1952     y := 0;
    1953   if y2 > Height then
    1954     y2 := Height;
    1955   if (x2 - x <= 0) or (y2 - y <= 0) then
    1956     exit;
     2629  if not CheckClippedRectBounds(x,y,x2,y2) then exit;
    19572630  tx := x2 - x;
    19582631  Dec(x2);
    19592632  Dec(y2);
    19602633
    1961   case mode of
    1962     dmFastBlend:
    1963     begin
    1964       p := Scanline[y] + x;
    1965       if FLineOrder = riloBottomToTop then
    1966         delta := -Width
    1967       else
    1968         delta := Width;
    1969       for yb := y2 - y downto 0 do
    1970       begin
    1971         FastBlendPixelsInline(p, c, tx);
    1972         Inc(p, delta);
    1973       end;
    1974       InvalidateBitmap;
     2634  if mode = dmSetExceptTransparent then
     2635  begin
     2636    if (c.alpha = 255) then
     2637      FillRect(x, y, x2, y2, c, dmSet);
     2638  end else
     2639  begin
     2640    if (mode <> dmSet) and (c.alpha = 0) then exit;
     2641
     2642    p := Scanline[y] + x;
     2643    if FLineOrder = riloBottomToTop then
     2644      delta := -Width
     2645    else
     2646      delta := Width;
     2647
     2648    case mode of
     2649      dmFastBlend:
     2650        for yb := y2 - y downto 0 do
     2651        begin
     2652          FastBlendPixelsInline(p, c, tx);
     2653          Inc(p, delta);
     2654        end;
     2655      dmDrawWithTransparency:
     2656        for yb := y2 - y downto 0 do
     2657        begin
     2658          DrawPixelsInline(p, c, tx);
     2659          Inc(p, delta);
     2660        end;
     2661      dmSet:
     2662        for yb := y2 - y downto 0 do
     2663        begin
     2664          FillInline(p, c, tx);
     2665          Inc(p, delta);
     2666        end;
     2667      dmXor:
     2668        for yb := y2 - y downto 0 do
     2669        begin
     2670          XorInline(p, c, tx);
     2671          Inc(p, delta);
     2672        end;
    19752673    end;
    1976     dmDrawWithTransparency:
    1977     begin
    1978       p := Scanline[y] + x;
    1979       if FLineOrder = riloBottomToTop then
    1980         delta := -Width
    1981       else
    1982         delta := Width;
    1983       for yb := y2 - y downto 0 do
    1984       begin
    1985         DrawPixelsInline(p, c, tx);
    1986         Inc(p, delta);
    1987       end;
    1988       InvalidateBitmap;
    1989     end;
    1990     dmSet:
    1991     begin
    1992       p := Scanline[y] + x;
    1993       if FLineOrder = riloBottomToTop then
    1994         delta := -Width
    1995       else
    1996         delta := Width;
    1997       for yb := y2 - y downto 0 do
    1998       begin
    1999         FillInline(p, c, tx);
    2000         Inc(p, delta);
    2001       end;
    2002       InvalidateBitmap;
    2003     end;
    2004     dmSetExceptTransparent: if (c.alpha = 255) then
    2005         FillRect(x, y, x2, y2, c, dmSet);
    2006   end;
    2007 end;
    2008 
    2009 procedure TBGRADefaultBitmap.FillRectAntialias(x, y, x2, y2: single; c: TBGRAPixel);
    2010 var
    2011   poly: array of TPointF;
    2012 begin
    2013   setlength(poly, 4);
    2014   poly[0] := pointf(x, y);
    2015   poly[1] := pointf(x2, y);
    2016   poly[2] := pointf(x2, y2);
    2017   poly[3] := pointf(x, y2);
    2018   FillPolyAntialias(poly, c);
     2674
     2675    InvalidateBitmap;
     2676  end;
     2677end;
     2678
     2679procedure TBGRADefaultBitmap.FillRect(x, y, x2, y2: integer;
     2680  texture: IBGRAScanner; mode: TDrawMode);
     2681var
     2682  yb, tx, delta: integer;
     2683  p: PBGRAPixel;
     2684begin
     2685  if not CheckClippedRectBounds(x,y,x2,y2) then exit;
     2686  tx := x2 - x;
     2687  Dec(x2);
     2688  Dec(y2);
     2689
     2690  p := Scanline[y] + x;
     2691  if FLineOrder = riloBottomToTop then
     2692    delta := -Width
     2693  else
     2694    delta := Width;
     2695
     2696  for yb := y to y2 do
     2697  begin
     2698    texture.ScanMoveTo(x,yb);
     2699    ScannerPutPixels(texture, p, tx, mode);
     2700    Inc(p, delta);
     2701  end;
     2702
     2703  InvalidateBitmap;
    20192704end;
    20202705
    20212706procedure TBGRADefaultBitmap.AlphaFillRect(x, y, x2, y2: integer; alpha: byte);
    20222707var
    2023   temp, yb, tx, delta: integer;
     2708  yb, tx, delta: integer;
    20242709  p: PBGRAPixel;
    20252710begin
     
    20302715  end;
    20312716
    2032   if (x > x2) then
    2033   begin
    2034     temp := x;
    2035     x    := x2;
    2036     x2   := temp;
    2037   end;
    2038   if (y > y2) then
    2039   begin
    2040     temp := y;
    2041     y    := y2;
    2042     y2   := temp;
    2043   end;
    2044   if (x >= Width) or (x2 <= 0) or (y >= Height) or (y2 <= 0) then
    2045     exit;
    2046   if x < 0 then
    2047     x := 0;
    2048   if x2 > Width then
    2049     x2 := Width;
    2050   if y < 0 then
    2051     y := 0;
    2052   if y2 > Height then
    2053     y2 := Height;
    2054   if (x2 - x <= 0) or (y2 - y <= 0) then
    2055     exit;
     2717  if not CheckClippedRectBounds(x,y,x2,y2) then exit;
    20562718  tx := x2 - x;
    20572719  Dec(x2);
     
    20712733end;
    20722734
     2735procedure TBGRADefaultBitmap.FillRectAntialias(x, y, x2, y2: single; c: TBGRAPixel);
     2736var tx,ty: single;
     2737begin
     2738  tx := x2-x;
     2739  ty := y2-y;
     2740  if (tx=0) or (ty=0) then exit;
     2741  if (abs(tx) > 2) and (abs(ty) > 2) then
     2742  begin
     2743    if (tx < 0) then
     2744    begin
     2745      tx := -tx;
     2746      x := x2;
     2747      x2 := x+tx;
     2748    end;
     2749    if (ty < 0) then
     2750    begin
     2751      ty := -ty;
     2752      y := y2;
     2753      y2 := y+ty;
     2754    end;
     2755    FillRectAntialias(x,y,x2,ceil(y)+0.5,c);
     2756    FillRectAntialias(x,ceil(y)+0.5,ceil(x)+0.5,floor(y2)-0.5,c);
     2757    FillRectAntialias(floor(x2)-0.5,ceil(y)+0.5,x2,floor(y2)-0.5,c);
     2758    FillRectAntialias(x,floor(y2)-0.5,x2,y2,c);
     2759    FillRect(ceil(x)+1,ceil(y)+1,floor(x2),floor(y2),c,dmDrawWithTransparency);
     2760  end else
     2761    FillPolyAntialias([pointf(x, y), pointf(x2, y), pointf(x2, y2), pointf(x, y2)], c);
     2762end;
     2763
     2764procedure TBGRADefaultBitmap.EraseRectAntialias(x, y, x2, y2: single;
     2765  alpha: byte);
     2766begin
     2767  ErasePolyAntialias([pointf(x, y), pointf(x2, y), pointf(x2, y2), pointf(x, y2)], alpha);
     2768end;
     2769
     2770procedure TBGRADefaultBitmap.FillRectAntialias(x, y, x2, y2: single;
     2771  texture: IBGRAScanner);
     2772begin
     2773  FillPolyAntialias([pointf(x, y), pointf(x2, y), pointf(x2, y2), pointf(x, y2)], texture);
     2774end;
     2775
     2776procedure TBGRADefaultBitmap.FillRoundRectAntialias(x, y, x2, y2, rx,ry: single;
     2777  c: TBGRAPixel; options: TRoundRectangleOptions);
     2778begin
     2779  BGRAPolygon.FillRoundRectangleAntialias(self,x,y,x2,y2,rx,ry,options,c,False);
     2780end;
     2781
     2782procedure TBGRADefaultBitmap.FillRoundRectAntialias(x, y, x2, y2, rx,
     2783  ry: single; texture: IBGRAScanner; options: TRoundRectangleOptions);
     2784begin
     2785  BGRAPolygon.FillRoundRectangleAntialiasWithTexture(self,x,y,x2,y2,rx,ry,options,texture);
     2786end;
     2787
     2788procedure TBGRADefaultBitmap.EraseRoundRectAntialias(x, y, x2, y2, rx,
     2789  ry: single; alpha: byte; options: TRoundRectangleOptions);
     2790begin
     2791  BGRAPolygon.FillRoundRectangleAntialias(self,x,y,x2,y2,rx,ry,options,BGRA(0,0,0,alpha),True);
     2792end;
     2793
    20732794procedure TBGRADefaultBitmap.RoundRect(X1, Y1, X2, Y2: integer;
    2074   RX, RY: integer; BorderColor, FillColor: TBGRAPixel);
    2075 var
    2076   CX, CY, CX1, CY1, A, B, NX, NY: single;
    2077   X, Y, EX, EY: integer;
    2078   LX1, LY1: integer;
    2079   LX2, LY2: integer;
    2080   DivSqrA, DivSqrB: single;
    2081   I, J, S: integer;
    2082   EdgeList: array of TPoint;
    2083   temp:   integer;
    2084   LX, LY: integer;
    2085 
    2086   procedure AddEdge(X, Y: integer);
    2087   begin
    2088     if (EdgeList[Y].X = -1) or (X < EdgeList[Y].X) then
    2089       EdgeList[Y].X := X;
    2090     if (EdgeList[Y].Y = -1) or (X > EdgeList[Y].Y) then
    2091       EdgeList[Y].Y := X;
    2092   end;
    2093 
    2094 begin
    2095   if (x1 > x2) then
    2096   begin
    2097     temp := x1;
    2098     x1   := x2;
    2099     x2   := temp;
    2100   end;
    2101   if (y1 > y2) then
    2102   begin
    2103     temp := y1;
    2104     y1   := y2;
    2105     y2   := temp;
    2106   end;
    2107   if (x2 - x1 <= 0) or (y2 - y1 <= 0) then
    2108     exit;
    2109   LX := x2 - x1 - RX;
    2110   LY := y2 - y1 - RY;
    2111   Dec(x2);
    2112   Dec(y2);
    2113 
    2114   if (X1 = X2) and (Y1 = Y2) then
    2115   begin
    2116     DrawPixel(X1, Y1, BorderColor);
    2117     Exit;
    2118   end;
    2119 
    2120   if (X2 - X1 = 1) or (Y2 - Y1 = 1) then
    2121   begin
    2122     FillRect(X1, Y1, X2 + 1, Y2 + 1, BorderColor, dmDrawWithTransparency);
    2123     Exit;
    2124   end;
    2125 
    2126   if (LX > X2 - X1) or (LY > Y2 - Y1) then
    2127   begin
    2128     Rectangle(X1, Y1, X2 + 1, Y2 + 1, BorderColor, dmDrawWithTransparency);
    2129     FillRect(X1 + 1, Y1 + 1, X2, Y2, FillColor, dmDrawWithTransparency);
    2130     Exit;
    2131   end;
    2132 
    2133   SetLength(EdgeList, Ceil((Y2 - Y1 + 1) / 2));
    2134   for I := 0 to Pred(High(EdgeList)) do
    2135     EdgeList[I] := Point(-1, -1);
    2136   EdgeList[High(EdgeList)] := Point(0, 0);
    2137 
    2138   A  := (X2 - X1 + 1 - LX) / 2;
    2139   B  := (Y2 - Y1 + 1 - LY) / 2;
    2140   CX := (X2 + X1 + 1) / 2;
    2141   CY := (Y2 + Y1 + 1) / 2;
    2142 
    2143   CX1 := X2 + 1 - A - Floor(CX);
    2144   CY1 := Y2 + 1 - B - Floor(CY);
    2145 
    2146   EX := Floor(Sqr(A) / Sqrt(Sqr(A) + Sqr(B)) + Frac(A));
    2147   EY := Floor(Sqr(B) / Sqrt(Sqr(A) + Sqr(B)) + Frac(B));
    2148 
    2149   DivSqrA := 1 / Sqr(A);
    2150   DivSqrB := 1 / Sqr(B);
    2151 
    2152   NY := B;
    2153   AddEdge(Floor(CX1), Round(CY1 + B) - 1);
    2154   for X := 1 to Pred(EX) do
    2155   begin
    2156     NY := B * Sqrt(1 - Sqr(X + 0.5 - Frac(A)) * DivSqrA);
    2157 
    2158     AddEdge(Floor(CX1) + X, Round(CY1 + NY) - 1);
    2159   end;
    2160 
    2161   LX1 := Floor(CX1) + Pred(EX);
    2162   LY1 := Round(CY1 + NY) - 1;
    2163 
    2164   NX := A;
    2165   AddEdge(Round(CX1 + A) - 1, Floor(CY1));
    2166   for Y := 1 to Pred(EY) do
    2167   begin
    2168     NX := A * Sqrt(1 - Sqr(Y + 0.5 - Frac(B)) * DivSqrB);
    2169 
    2170     AddEdge(Round(CX1 + NX) - 1, Floor(CY1) + Y);
    2171   end;
    2172 
    2173   LX2 := Round(CX1 + NX) - 1;
    2174   LY2 := Floor(CY1) + Pred(EY);
    2175 
    2176   if Abs(LX1 - LX2) > 1 then
    2177   begin
    2178     if Abs(LY1 - LY2) > 1 then
    2179       AddEdge(LX1 + 1, LY1 - 1)
    2180     else
    2181       AddEdge(LX1 + 1, LY1);
    2182   end
    2183   else
    2184   if Abs(LY1 - LY2) > 1 then
    2185     AddEdge(LX2, LY1 - 1);
    2186 
    2187   for I := 0 to High(EdgeList) do
    2188   begin
    2189     if EdgeList[I].X = -1 then
    2190       EdgeList[I] := Point(Round(CX1 + A) - 1, Round(CX1 + A) - 1)
    2191     else
    2192       Break;
    2193   end;
    2194 
    2195   for J := 0 to High(EdgeList) do
    2196   begin
    2197     if (J = 0) and (Frac(CY) > 0) then
    2198     begin
    2199       for I := EdgeList[J].X to EdgeList[J].Y do
    2200       begin
    2201         DrawPixel(Floor(CX) + I, Floor(CY) + J, BorderColor);
    2202         DrawPixel(Ceil(CX) - Succ(I), Floor(CY) + J, BorderColor);
    2203       end;
    2204 
    2205       DrawHorizLine(Ceil(CX) - EdgeList[J].X, Floor(CY) + J, Floor(CX) +
    2206         Pred(EdgeList[J].X), FillColor);
    2207     end
    2208     else
    2209     if (J = High(EdgeList)) then
    2210     begin
    2211       if Frac(CX) > 0 then
    2212         S := -EdgeList[J].Y
    2213       else
    2214         S := -Succ(EdgeList[J].Y);
    2215 
    2216       for I := S to EdgeList[J].Y do
    2217       begin
    2218         DrawPixel(Floor(CX) + I, Floor(CY) + J, BorderColor);
    2219         DrawPixel(Floor(CX) + I, Ceil(CY) - Succ(J), BorderColor);
    2220       end;
    2221     end
    2222     else
    2223     begin
    2224       for I := EdgeList[J].X to EdgeList[J].Y do
    2225       begin
    2226         DrawPixel(Floor(CX) + I, Floor(CY) + J, BorderColor);
    2227         DrawPixel(Floor(CX) + I, Ceil(CY) - Succ(J), BorderColor);
    2228         if Floor(CX) + I <> Ceil(CX) - Succ(I) then
    2229         begin
    2230           DrawPixel(Ceil(CX) - Succ(I), Floor(CY) + J, BorderColor);
    2231           DrawPixel(Ceil(CX) - Succ(I), Ceil(CY) - Succ(J), BorderColor);
    2232         end;
    2233       end;
    2234 
    2235       DrawHorizLine(Ceil(CX) - EdgeList[J].X, Floor(CY) + J,
    2236         Floor(CX) + Pred(EdgeList[J].X), FillColor);
    2237       DrawHorizLine(Ceil(CX) - EdgeList[J].X, Ceil(CY) - Succ(J),
    2238         Floor(CX) + Pred(EdgeList[J].X), FillColor);
    2239     end;
    2240   end;
    2241 end;
    2242 
    2243 procedure TBGRADefaultBitmap.TextOut(x, y: integer; s: string; c: TBGRAPixel);
    2244 begin
    2245   TextOut(x, y, s, c, taLeftJustify);
    2246 end;
    2247 
    2248 
    2249 {$HINTS OFF}
     2795  DX, DY: integer; BorderColor, FillColor: TBGRAPixel);
     2796begin
     2797  BGRARoundRectAliased(self,X1,Y1,X2,Y2,DX,DY,BorderColor,FillColor);
     2798end;
     2799
     2800{------------------------- Text functions ---------------------------------------}
     2801
     2802procedure TBGRADefaultBitmap.TextOutAngle(x, y, orientation: integer;
     2803  s: string; c: TBGRAPixel; align: TAlignment);
     2804begin
     2805  UpdateFont;
     2806  BGRAText.BGRATextOutAngle(self,FFont,FontQuality,x,y,orientation,s,c,nil,align);
     2807end;
     2808
     2809procedure TBGRADefaultBitmap.TextOutAngle(x, y, orientation: integer;
     2810  s: string; texture: IBGRAScanner; align: TAlignment);
     2811begin
     2812  UpdateFont;
     2813  BGRAText.BGRATextOutAngle(self,FFont,FontQuality,x,y,orientation,s,BGRAPixelTransparent,texture,align);
     2814end;
     2815
     2816procedure TBGRADefaultBitmap.TextOut(x, y: integer; s: string;
     2817  texture: IBGRAScanner; align: TAlignment);
     2818begin
     2819  UpdateFont;
     2820
     2821  if (FontQuality in[fqFineAntialiasing,fqFineClearTypeBGR,fqFineClearTypeRGB]) and (FFont.Orientation mod 3600 = 0) then
     2822    BGRATextFX.BGRATextOutImproveReadability(self,FFont,x,y,s,BGRAPixelTransparent,texture,align,
     2823     FontQuality in[fqFineClearTypeRGB,fqFineClearTypeBGR], FontQuality = fqFineClearTypeRGB) else
     2824
     2825    BGRAText.BGRATextOut(self,FFont,FontQuality,x,y,s,BGRAPixelTransparent,texture,align);
     2826end;
     2827
    22502828procedure TBGRADefaultBitmap.TextOut(x, y: integer; s: string;
    22512829  c: TBGRAPixel; align: TAlignment);
    2252 var
    2253   size:  TSize;
    2254   temp:  TBGRADefaultBitmap;
    2255   P:     PBGRAPixel;
    2256   n:     integer;
    2257   alpha: integer;
    22582830begin
    22592831  UpdateFont;
    22602832
    2261   size := TextSize(s);
    2262   if (size.cx = 0) or (size.cy = 0) then
    2263     exit;
    2264 
    2265   case align of
    2266     taLeftJustify: ;
    2267     taCenter: Dec(x, size.cx div 2);
    2268     taRightJustify: Dec(x, size.cx);
    2269   end;
    2270 
    2271   temp := NewBitmap(size.cx, size.cy);
    2272   temp.Fill(clBlack);
    2273   temp.Canvas.Font := FFont;
    2274   temp.Canvas.Font.Color := clWhite;
    2275   temp.Canvas.Brush.Style := bsClear;
    2276   temp.Canvas.TextOut(0, 0, s);
    2277   p := temp.Data;
    2278   for n := temp.NbPixels - 1 downto 0 do
    2279   begin
    2280     alpha    := P^.green;
    2281     p^.red   := c.red;
    2282     p^.green := c.green;
    2283     p^.blue  := c.blue;
    2284     p^.alpha := (c.alpha * alpha) div 255;
    2285     Inc(p);
    2286   end;
    2287   PutImage(x, y, temp, dmDrawWithTransparency);
    2288   temp.Free;
    2289 end;
    2290 
    2291 {$HINTS ON}
    2292 
    2293 procedure TBGRADefaultBitmap.TextOut(x, y: integer; s: string; c: TColor);
    2294 begin
    2295   TextOut(x, y, s, ColorToBGRA(c));
     2833  if (FontQuality in[fqFineAntialiasing,fqFineClearTypeBGR,fqFineClearTypeRGB]) and (FFont.Orientation mod 3600 = 0) then
     2834    BGRATextFX.BGRATextOutImproveReadability(self,FFont,x,y,s,c,nil,align,
     2835    FontQuality in[fqFineClearTypeRGB,fqFineClearTypeBGR], FontQuality = fqFineClearTypeRGB) else
     2836
     2837    BGRAText.BGRATextOut(self,FFont,FontQuality,x,y,s,c,nil,align);
    22962838end;
    22972839
    22982840procedure TBGRADefaultBitmap.TextRect(ARect: TRect; x, y: integer;
    22992841  s: string; style: TTextStyle; c: TBGRAPixel);
    2300 var
    2301   tx, ty: integer;
    2302   temp:   TBGRADefaultBitmap;
    2303   P:      PBGRAPixel;
    2304   n:      integer;
    2305   alpha:  integer;
    23062842begin
    23072843  UpdateFont;
    2308 
    2309   if ARect.Left < 0 then
    2310     ARect.Left := 0;
    2311   if ARect.Top < 0 then
    2312     ARect.Top := 0;
    2313   if ARect.Right > Width then
    2314     ARect.Right := Width;
    2315   if ARect.Bottom > Height then
    2316     ARect.Bottom := Height;
    2317 
    2318   tx := ARect.Right - ARect.Left;
    2319   ty := ARect.Bottom - ARect.Top;
    2320   if (tx <= 0) or (ty <= 0) then
    2321     exit;
    2322   temp := NewBitmap(tx, ty);
    2323   temp.Fill(clBlack);
    2324   temp.Canvas.Font := FFont;
    2325   temp.Canvas.Font.Color := clWhite;
    2326   temp.Canvas.Brush.Style := bsClear;
    2327   temp.Canvas.TextRect(rect(0, 0, tx, ty), x - ARect.Left, y - ARect.Top, s, style);
    2328   p := temp.Data;
    2329   for n := tx * ty - 1 downto 0 do
    2330   begin
    2331     alpha    := P^.green;
    2332     p^.red   := c.red;
    2333     p^.green := c.green;
    2334     p^.blue  := c.blue;
    2335     p^.alpha := (c.alpha * alpha) div 255;
    2336     Inc(p);
    2337   end;
    2338   PutImage(ARect.Left, ARect.Top, temp, dmDrawWithTransparency);
    2339   temp.Free;
    2340 end;
    2341 
    2342 {$hints off}
     2844  BGRAText.BGRATextRect(self,FFont,FontQuality,ARect,x,y,s,style,c,nil);
     2845end;
     2846
     2847procedure TBGRADefaultBitmap.TextRect(ARect: TRect; x, y: integer; s: string;
     2848  style: TTextStyle; texture: IBGRAScanner);
     2849begin
     2850  UpdateFont;
     2851  BGRAText.BGRATextRect(self,FFont,FontQuality,ARect,x,y,s,style,BGRAPixelTransparent,texture);
     2852end;
     2853
    23432854function TBGRADefaultBitmap.TextSize(s: string): TSize;
    2344 var
    2345   temp: TBitmap;
    23462855begin
    23472856  UpdateFont;
    2348 
    2349   temp := TBitmap.Create;
    2350   temp.Canvas.Font := FFont;
    2351   temp.Canvas.Font.GetTextSize(s, Result.cx, Result.cy);
    2352   temp.Free;
    2353 end;
    2354 
    2355 {$hints on}
    2356 
    2357 {----------------------- Spline ------------------}
    2358 
    2359 function TBGRADefaultBitmap.Spline(y0, y1, y2, y3: single; t: single): single;
    2360 var
    2361   a0, a1, a2, a3: single;
    2362   t2: single;
    2363 begin
    2364   t2     := t * t;
    2365   a0     := y3 - y2 - y0 + y1;
    2366   a1     := y0 - y1 - a0;
    2367   a2     := y2 - y0;
    2368   a3     := y1;
    2369   Result := a0 * t * t2 + a1 * t2 + a2 * t + a3;
    2370 end;
    2371 
    2372 function TBGRADefaultBitmap.ComputeClosedSpline(points: array of TPointF):
    2373 ArrayOfTPointF;
    2374 
    2375   function computePrecision(pt1, pt2, pt3, pt4: TPointF): integer;
    2376   var
    2377     len: single;
    2378   begin
    2379     len    := sqrt(sqr(pt1.x - pt2.x) + sqr(pt1.y - pt2.y));
    2380     len    := max(len, sqrt(sqr(pt3.x - pt2.x) + sqr(pt3.y - pt2.y)));
    2381     len    := max(len, sqrt(sqr(pt3.x - pt4.x) + sqr(pt3.y - pt4.y)));
    2382     Result := round(sqrt(len) * 2);
    2383   end;
    2384 
    2385 var
    2386   i, j, nb, idx, pre: integer;
    2387   ptPrev, ptPrev2, ptNext, ptNext2: TPointF;
    2388 
    2389 begin
    2390   if length(points) = 2 then
    2391   begin
    2392     setlength(Result, 2);
    2393     Result[0] := points[0];
    2394     Result[1] := points[1];
    2395     exit;
    2396   end;
    2397 
    2398   nb := 1;
    2399   for i := 0 to high(points) do
    2400   begin
    2401     ptPrev2 := points[(i + length(points) - 1) mod length(points)];
    2402     ptPrev  := points[i];
    2403     ptNext  := points[(i + 1) mod length(points)];
    2404     ptNext2 := points[(i + 2) mod length(points)];
    2405     nb      += computePrecision(ptPrev2, ptPrev, ptNext, ptNext2);
    2406   end;
    2407 
    2408   setlength(Result, nb);
    2409   Result[0] := points[0];
    2410   idx := 1;
    2411   for i := 0 to high(points) do
    2412   begin
    2413     ptPrev2 := points[(i + length(points) - 1) mod length(points)];
    2414     ptPrev  := points[i];
    2415     ptNext  := points[(i + 1) mod length(points)];
    2416     ptNext2 := points[(i + 2) mod length(points)];
    2417     pre     := computePrecision(ptPrev2, ptPrev, ptNext, ptNext2);
    2418     for j := 1 to pre - 1 do
    2419     begin
    2420       Result[idx] := pointF(spline(ptPrev2.x, ptPrev.X, ptNext.X, ptNext2.X, j / pre),
    2421         spline(ptPrev2.y, ptPrev.y, ptNext.y, ptNext2.y, j / pre));
    2422       Inc(idx);
    2423     end;
    2424     if pre <> 0 then
    2425     begin
    2426       Result[idx] := ptNext;
    2427       Inc(idx);
    2428     end;
    2429   end;
    2430 end;
    2431 
    2432 function TBGRADefaultBitmap.ComputeOpenedSpline(points: array of TPointF):
    2433 ArrayOfTPointF;
    2434 
    2435   function computePrecision(pt1, pt2, pt3, pt4: TPointF): integer;
    2436   var
    2437     len: single;
    2438   begin
    2439     len    := sqrt(sqr(pt1.x - pt2.x) + sqr(pt1.y - pt2.y));
    2440     len    := max(len, sqrt(sqr(pt3.x - pt2.x) + sqr(pt3.y - pt2.y)));
    2441     len    := max(len, sqrt(sqr(pt3.x - pt4.x) + sqr(pt3.y - pt4.y)));
    2442     Result := round(sqrt(len) * 2);
    2443   end;
    2444 
    2445 var
    2446   i, j, nb, idx, pre: integer;
    2447   ptPrev, ptPrev2, ptNext, ptNext2: TPointF;
    2448 
    2449 begin
    2450   if length(points) = 2 then
    2451   begin
    2452     setlength(Result, 2);
    2453     Result[0] := points[0];
    2454     Result[1] := points[1];
    2455     exit;
    2456   end;
    2457 
    2458   nb := 1;
    2459   for i := 0 to high(points) - 1 do
    2460   begin
    2461     ptPrev2 := points[max(0, i - 1)];
    2462     ptPrev  := points[i];
    2463     ptNext  := points[i + 1];
    2464     ptNext2 := points[min(high(points), i + 2)];
    2465     nb      += computePrecision(ptPrev2, ptPrev, ptNext, ptNext2);
    2466   end;
    2467 
    2468   setlength(Result, nb);
    2469   Result[0] := points[0];
    2470   idx := 1;
    2471   for i := 0 to high(points) - 1 do
    2472   begin
    2473     ptPrev2 := points[max(0, i - 1)];
    2474     ptPrev  := points[i];
    2475     ptNext  := points[i + 1];
    2476     ptNext2 := points[min(high(points), i + 2)];
    2477     pre     := computePrecision(ptPrev2, ptPrev, ptNext, ptNext2);
    2478     for j := 1 to pre - 1 do
    2479     begin
    2480       Result[idx] := pointF(spline(ptPrev2.x, ptPrev.X, ptNext.X, ptNext2.X, j / pre),
    2481         spline(ptPrev2.y, ptPrev.y, ptNext.y, ptNext2.y, j / pre));
    2482       Inc(idx);
    2483     end;
    2484     if pre <> 0 then
    2485     begin
    2486       Result[idx] := ptNext;
    2487       Inc(idx);
    2488     end;
    2489   end;
     2857  result := BGRAText.BGRATextSize(FFont,FontQuality,s,FontAntialiasingLevel);
     2858  if (result.cy >= 24) and FontAntialias then
     2859    result := BGRAText.BGRATextSize(FFont,FontQuality,s,4);
     2860end;
     2861
     2862{---------------------------- Curves ----------------------------------------}
     2863
     2864function TBGRADefaultBitmap.ComputeClosedSpline(const APoints: array of TPointF; AStyle: TSplineStyle): ArrayOfTPointF;
     2865begin
     2866  result := BGRAPath.ComputeClosedSpline(APoints, AStyle);
     2867end;
     2868
     2869function TBGRADefaultBitmap.ComputeOpenedSpline(const APoints: array of TPointF; AStyle: TSplineStyle): ArrayOfTPointF;
     2870begin
     2871  result := BGRAPath.ComputeOpenedSpline(APoints, AStyle);
     2872end;
     2873
     2874function TBGRADefaultBitmap.ComputeBezierCurve(const ACurve: TCubicBezierCurve
     2875  ): ArrayOfTPointF;
     2876begin
     2877  Result:= BGRAPath.ComputeBezierCurve(ACurve);
     2878end;
     2879
     2880function TBGRADefaultBitmap.ComputeBezierCurve(
     2881  const ACurve: TQuadraticBezierCurve): ArrayOfTPointF;
     2882begin
     2883  Result:= BGRAPath.ComputeBezierCurve(ACurve);
     2884end;
     2885
     2886function TBGRADefaultBitmap.ComputeBezierSpline(
     2887  const ASpline: array of TCubicBezierCurve): ArrayOfTPointF;
     2888begin
     2889  Result:= BGRAPath.ComputeBezierSpline(ASpline);
     2890end;
     2891
     2892function TBGRADefaultBitmap.ComputeBezierSpline(
     2893  const ASpline: array of TQuadraticBezierCurve): ArrayOfTPointF;
     2894begin
     2895  Result:= BGRAPath.ComputeBezierSpline(ASpline);
     2896end;
     2897
     2898function TBGRADefaultBitmap.ComputeWidePolyline(const points: array of TPointF;
     2899  w: single): ArrayOfTPointF;
     2900begin
     2901  Result:= BGRAPen.ComputeWidePolylinePoints(points,w,BGRAWhite,LineCap,JoinStyle,FCustomPenStyle,[],JoinMiterLimit);
     2902end;
     2903
     2904function TBGRADefaultBitmap.ComputeWidePolyline(const points: array of TPointF;
     2905  w: single; Closed: boolean): ArrayOfTPointF;
     2906var
     2907  options: TBGRAPolyLineOptions;
     2908begin
     2909  if not closed then options := [plRoundCapOpen] else options := [];
     2910  Result:= BGRAPen.ComputeWidePolylinePoints(points,w,BGRAWhite,pecRound,pjsRound,FCustomPenStyle,options,JoinMiterLimit);
     2911end;
     2912
     2913function TBGRADefaultBitmap.ComputeWidePolygon(const points: array of TPointF;
     2914  w: single): ArrayOfTPointF;
     2915begin
     2916  Result:= BGRAPen.ComputeWidePolylinePoints(points,w,BGRAWhite,LineCap,JoinStyle,FCustomPenStyle,[plCycle],JoinMiterLimit);
     2917end;
     2918
     2919function TBGRADefaultBitmap.ComputeEllipse(x, y, rx, ry: single
     2920  ): ArrayOfTPointF;
     2921begin
     2922  result := BGRAPath.ComputeEllipse(x,y,rx,ry);
     2923end;
     2924
     2925function TBGRADefaultBitmap.ComputeEllipse(x, y, rx, ry, w: single
     2926  ): ArrayOfTPointF;
     2927begin
     2928  result := ComputeWidePolygon(ComputeEllipse(x,y,rx,ry),w);
     2929end;
     2930
     2931function TBGRADefaultBitmap.ComputeArc65536(x, y, rx, ry: single; start65536,
     2932  end65536: word): ArrayOfTPointF;
     2933begin
     2934  result := BGRAPath.ComputeArc65536(x,y,rx,ry,start65536,end65536);
     2935end;
     2936
     2937function TBGRADefaultBitmap.ComputeArcRad(x, y, rx, ry: single; startRad,
     2938  endRad: single): ArrayOfTPointF;
     2939begin
     2940  result := BGRAPath.ComputeArc65536(x,y,rx,ry,round(startRad*32768/Pi),round(endRad*32768/Pi));
     2941end;
     2942
     2943function TBGRADefaultBitmap.ComputeRoundRect(x1, y1, x2, y2, rx, ry: single
     2944  ): ArrayOfTPointF;
     2945begin
     2946  result := BGRAPath.ComputeRoundRect(x1,y1,x2,y2,rx,ry);
     2947end;
     2948
     2949function TBGRADefaultBitmap.ComputeRoundRect(x1, y1, x2, y2, rx, ry: single;
     2950  options: TRoundRectangleOptions): ArrayOfTPointF;
     2951begin
     2952  Result:= BGRAPath.ComputeRoundRect(x1,y1,x2,y2,rx,ry,options);
     2953end;
     2954
     2955function TBGRADefaultBitmap.ComputePie65536(x, y, rx, ry: single; start65536,
     2956  end65536: word): ArrayOfTPointF;
     2957begin
     2958  result := BGRAPath.ComputeArc65536(x,y,rx,ry,start65536,end65536);
     2959  if (start65536 <> end65536) then
     2960  begin
     2961    setlength(result,length(result)+1);
     2962    result[high(result)] := PointF(x,y);
     2963  end;
     2964end;
     2965
     2966function TBGRADefaultBitmap.ComputePieRad(x, y, rx, ry: single; startRad,
     2967  endRad: single): ArrayOfTPointF;
     2968begin
     2969  result := self.ComputePie65536(x,y,rx,ry,round(startRad*32768/Pi),round(endRad*32768/Pi));
    24902970end;
    24912971
    24922972{---------------------------------- Fill ---------------------------------}
    24932973
    2494 procedure TBGRADefaultBitmap.FillTransparent;
    2495 begin
    2496   Fill(BGRAPixelTransparent);
    2497 end;
    2498 
    2499 procedure TBGRADefaultBitmap.ApplyGlobalOpacity(alpha: byte);
    2500 var
    2501   p: PBGRAPixel;
    2502   i: integer;
    2503 begin
    2504   if alpha = 0 then
    2505     FillTransparent
    2506   else
    2507   if alpha <> 255 then
    2508   begin
    2509     p := Data;
    2510     for i := NbPixels - 1 downto 0 do
    2511     begin
    2512       p^.alpha := (p^.alpha * alpha + 128) shr 8;
    2513       Inc(p);
    2514     end;
    2515   end;
    2516 end;
    2517 
    2518 procedure TBGRADefaultBitmap.Fill(c: TColor);
    2519 begin
    2520   Fill(ColorToBGRA(c));
    2521 end;
    2522 
    2523 procedure TBGRADefaultBitmap.Fill(c: TBGRAPixel);
    2524 begin
    2525   Fill(c, 0, Width * Height);
     2974procedure TBGRADefaultBitmap.Fill(texture: IBGRAScanner);
     2975begin
     2976  FillRect(FClipRect.Left,FClipRect.Top,FClipRect.Right,FClipRect.Bottom,texture,dmSet);
    25262977end;
    25272978
     
    25422993end;
    25432994
    2544 procedure TBGRADefaultBitmap.AlphaFill(alpha: byte);
    2545 begin
    2546   AlphaFill(alpha, 0, NbPixels);
    2547 end;
    2548 
    25492995procedure TBGRADefaultBitmap.AlphaFill(alpha: byte; start, Count: integer);
    25502996begin
     
    25653011end;
    25663012
     3013procedure TBGRADefaultBitmap.FillMask(x, y: integer; AMask: TBGRACustomBitmap;
     3014  color: TBGRAPixel);
     3015var
     3016  scan: TBGRACustomScanner;
     3017begin
     3018  if (AMask = nil) or (color.alpha = 0) then exit;
     3019  scan := TBGRASolidColorMaskScanner.Create(AMask,Point(-X,-Y),color);
     3020  self.FillRect(X,Y,X+AMask.Width,Y+AMask.Height,scan,dmDrawWithTransparency);
     3021  scan.Free;
     3022end;
     3023
     3024procedure TBGRADefaultBitmap.FillMask(x, y: integer; AMask: TBGRACustomBitmap;
     3025  texture: IBGRAScanner);
     3026var
     3027  scan: TBGRACustomScanner;
     3028begin
     3029  if AMask = nil then exit;
     3030  scan := TBGRATextureMaskScanner.Create(AMask,Point(-X,-Y),texture);
     3031  self.FillRect(X,Y,X+AMask.Width,Y+AMask.Height,scan,dmDrawWithTransparency);
     3032  scan.Free;
     3033end;
     3034
     3035procedure TBGRADefaultBitmap.FillClearTypeMask(x, y: integer; xThird: integer;
     3036  AMask: TBGRACustomBitmap; color: TBGRAPixel; ARGBOrder: boolean);
     3037begin
     3038  BGRAFillClearTypeMask(self,x, y, xThird, AMask, color, nil, ARGBOrder);
     3039end;
     3040
     3041procedure TBGRADefaultBitmap.FillClearTypeMask(x, y: integer; xThird: integer;
     3042  AMask: TBGRACustomBitmap; texture: IBGRAScanner; ARGBOrder: boolean);
     3043begin
     3044  BGRAFillClearTypeMask(self,x, y, xThird, AMask, BGRAPixelTransparent, texture, ARGBOrder);
     3045end;
     3046
     3047{ Replace color without taking alpha channel into account }
    25673048procedure TBGRADefaultBitmap.ReplaceColor(before, after: TColor);
    25683049const
     
    25733054  beforeBGR, afterBGR: longword;
    25743055begin
    2575   beforeBGR := (before and $FF shl 16) + (before and $FF00) + (before shr 16 and $FF);
    2576   afterBGR  := (after and $FF shl 16) + (after and $FF00) + (after shr 16 and $FF);
     3056  beforeBGR := NtoLE((before and $FF shl 16) + (before and $FF00) + (before shr 16 and $FF));
     3057  afterBGR  := NtoLE((after and $FF shl 16) + (after and $FF00) + (after shr 16 and $FF));
    25773058
    25783059  p := PLongWord(Data);
     
    26063087end;
    26073088
     3089{ Replace transparent pixels by the specified color }
    26083090procedure TBGRADefaultBitmap.ReplaceTransparent(after: TBGRAPixel);
    26093091var
     
    26213103end;
    26223104
    2623 procedure TBGRADefaultBitmap.FloodFill(X, Y: integer; Color: TBGRAPixel;
    2624   mode: TFloodfillMode; Tolerance: byte = 0);
    2625 begin
    2626   ParallelFloodFill(X,Y,Self,Color,mode,Tolerance);
    2627 end;
    2628 
     3105{ General purpose FloodFill. It can be used to fill inplace or to
     3106  fill a destination bitmap according to the content of the current bitmap.
     3107
     3108  The first pixel encountered is taken as a reference, further pixels
     3109  are compared to this pixel. If the distance between next colors and
     3110  the first color is lower than the tolerance, then the floodfill continues.
     3111
     3112  It uses an array of bits to store visited places to avoid filling twice
     3113  the same area. It also uses a stack of positions to remember where
     3114  to continue after a place is completely filled.
     3115
     3116  The first direction to be checked is horizontal, then
     3117  it checks pixels on the line above and on the line below. }
    26293118procedure TBGRADefaultBitmap.ParallelFloodFill(X, Y: integer;
    2630   Dest: TBGRADefaultBitmap; Color: TBGRAPixel; mode: TFloodfillMode;
     3119  Dest: TBGRACustomBitmap; Color: TBGRAPixel; mode: TFloodfillMode;
    26313120  Tolerance: byte);
    26323121var
     
    26993188
    27003189begin
    2701   if (X >= 0) and (X < Width) and (Y >= 0) and (Y < Height) then
     3190  if PtInClipRect(X,Y) then
    27023191  begin
    27033192    S := GetPixel(X, Y);
     
    27173206
    27183207      SX := X;
    2719       while (SX > 0) and CheckPixel(Pred(SX), Y) do
     3208      while (SX > FClipRect.Left) and CheckPixel(Pred(SX), Y) do
    27203209        Dec(SX);
    27213210      EX := X;
    2722       while (EX < Pred(Width)) and CheckPixel(Succ(EX), Y) do
     3211      while (EX < Pred(FClipRect.Right)) and CheckPixel(Succ(EX), Y) do
    27233212        Inc(EX);
    27243213
     
    27333222
    27343223      Added := False;
    2735       if Y > 0 then
     3224      if Y > FClipRect.Top then
    27363225        for I := SX to EX do
    27373226          if CheckPixel(I, Pred(Y)) then
    27383227          begin
    2739             if Added then
     3228            if Added then //do not add twice the same segment
    27403229              Continue;
    27413230            Push(I, Pred(Y));
     
    27463235
    27473236      Added := False;
    2748       if Y < Pred(Height) then
     3237      if Y < Pred(FClipRect.Bottom) then
    27493238        for I := SX to EX do
    27503239          if CheckPixel(I, Succ(Y)) then
    27513240          begin
    2752             if Added then
     3241            if Added then //do not add twice the same segment
    27533242              Continue;
    27543243            Push(I, Succ(Y));
     
    27643253  c1, c2: TBGRAPixel; gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode;
    27653254  gammaColorCorrection: boolean = True; Sinus: Boolean=False);
    2766 var
    2767   u, p:   TPointF;
    2768   len, a: single;
    2769   xb, yb, temp: integer;
    2770   b:      integer;
    2771   c:      TBGRAPixel;
    2772   ec, ec1, ec2: TExpandedPixel;
    2773   pixelProc: procedure(x, y: integer; col: TBGRAPixel) of object;
    2774 begin
    2775   if (x > x2) then
    2776   begin
    2777     temp := x;
    2778     x    := x2;
    2779     x2   := temp;
    2780   end;
    2781   if (y > y2) then
    2782   begin
    2783     temp := y;
    2784     y    := y2;
    2785     y2   := temp;
    2786   end;
    2787   if x < 0 then x := 0;
    2788   if x2 > width then x2 := width;
    2789   if y < 0 then y := 0;
    2790   if y2 > height then y2 := height;
    2791   if (x2 <= x) or (y2 <= y) then exit;
    2792 
     3255begin
     3256  BGRAGradientFill(self, x, y, x2, y2, c1, c2, gtype, o1, o2, mode, gammaColorCorrection, Sinus);
     3257end;
     3258
     3259procedure TBGRADefaultBitmap.GradientFill(x, y, x2, y2: integer;
     3260  gradient: TBGRACustomGradient; gtype: TGradientType; o1, o2: TPointF;
     3261  mode: TDrawMode; Sinus: Boolean);
     3262var
     3263  scanner: TBGRAGradientScanner;
     3264begin
     3265  scanner := TBGRAGradientScanner.Create(gradient,gtype,o1,o2,sinus);
     3266  FillRect(x,y,x2,y2,scanner,mode);
     3267  scanner.Free;
     3268end;
     3269
     3270function TBGRADefaultBitmap.CreateBrushTexture(ABrushStyle: TBrushStyle; APatternColor, ABackgroundColor: TBGRAPixel;
     3271                AWidth: integer = 8; AHeight: integer = 8; APenWidth: single = 1): TBGRACustomBitmap;
     3272begin
     3273  result := BGRAPen.CreateBrushTexture(self,ABrushStyle,APatternColor,ABackgroundColor,AWidth,AHeight,APenWidth);
     3274end;
     3275
     3276{ Scanning procedures for IBGRAScanner interface }
     3277procedure TBGRADefaultBitmap.ScanMoveTo(X, Y: Integer);
     3278begin
     3279  LoadFromBitmapIfNeeded;
     3280  FScanCurX := PositiveMod(X+ScanOffset.X, FWidth);
     3281  FScanCurY := PositiveMod(Y+ScanOffset.Y, FHeight);
     3282  FScanPtr := ScanLine[FScanCurY];
     3283end;
     3284
     3285function TBGRADefaultBitmap.ScanNextPixel: TBGRAPixel;
     3286begin
     3287  result := (FScanPtr+FScanCurX)^;
     3288  inc(FScanCurX);
     3289  if FScanCurX = FWidth then //cycle
     3290    FScanCurX := 0;
     3291end;
     3292
     3293function TBGRADefaultBitmap.ScanAt(X, Y: Single): TBGRAPixel;
     3294begin
     3295  Result:= GetPixelCycle(x+ScanOffset.X,y+ScanOffset.Y,ScanInterpolationFilter);
     3296end;
     3297
     3298function TBGRADefaultBitmap.IsScanPutPixelsDefined: boolean;
     3299begin
     3300  Result:= true;
     3301end;
     3302
     3303procedure TBGRADefaultBitmap.ScanPutPixels(pdest: PBGRAPixel; count: integer;
     3304  mode: TDrawMode);
     3305var
     3306  i,nbCopy: Integer;
     3307  c: TBGRAPixel;
     3308begin
    27933309  case mode of
    2794     dmSet, dmSetExceptTransparent: pixelProc := @SetPixel;
    2795     dmDrawWithTransparency: pixelProc := @DrawPixel;
    2796     dmFastBlend: pixelProc := @FastBlendPixel;
    2797   end;
    2798   //handles transparency
    2799   if (c1.alpha = 0) and (c2.alpha = 0) then
    2800   begin
    2801     FillRect(x, y, x2, y2, BGRAPixelTransparent, mode);
    2802     exit;
    2803   end;
    2804   if c1.alpha = 0 then
    2805   begin
    2806     c1.red   := c2.red;
    2807     c1.green := c2.green;
    2808     c1.blue  := c2.blue;
    2809   end
    2810   else
    2811   if c2.alpha = 0 then
    2812   begin
    2813     c2.red   := c1.red;
    2814     c2.green := c1.green;
    2815     c2.blue  := c1.blue;
    2816   end;
    2817 
    2818   //compute vector
    2819   u.x := o2.x - o1.x;
    2820   u.y := o2.y - o1.y;
    2821   len := sqrt(sqr(u.x) + sqr(u.y));
    2822   if len = 0 then
    2823   begin
    2824     FillRect(x, y, x2, y2, MergeBGRA(c1, c2), mode);
    2825     exit;
    2826   end;
    2827   u.x /= len;
    2828   u.y /= len;
    2829 
    2830   ec1 := GammaExpansion(c1);
    2831   ec2 := GammaExpansion(c2);
    2832   if gammaColorCorrection then
    2833   begin
    2834     //render with gamma correction
    2835     case gtype of
    2836       gtLinear:
    2837         for yb := y to y2 - 1 do
    2838           for xb := x to x2 - 1 do
    2839           begin
    2840             p.x := xb - o1.x;
    2841             p.y := yb - o1.y;
    2842             a   := p.x * u.x + p.y * u.y;
    2843             if Sinus then a := (sin(a*2*Pi/len)+1)*len/2;
    2844             if a < 0 then
    2845               c := c1
    2846             else
    2847             if a > len then
    2848               c := c2
    2849             else
    2850             begin
    2851               b      := round(a / len * 256);
    2852               ec.red := (ec1.red * (256 - b) + ec2.red * b + 127) shr 8;
    2853               ec.green := (ec1.green * (256 - b) + ec2.green * b + 127) shr 8;
    2854               ec.blue := (ec1.blue * (256 - b) + ec2.blue * b + 127) shr 8;
    2855               ec.alpha := (ec1.alpha * (256 - b) + ec2.alpha * b + 127) shr 8;
    2856               c      := GammaCompression(ec);
    2857             end;
    2858             pixelProc(xb, yb, c);
    2859           end;
    2860 
    2861       gtReflected:
    2862         for yb := y to y2 - 1 do
    2863           for xb := x to x2 - 1 do
    2864           begin
    2865             p.x := xb - o1.x;
    2866             p.y := yb - o1.y;
    2867             a   := abs(p.x * u.x + p.y * u.y);
    2868             if Sinus then a := (sin(a*2*Pi/len)+1)*len/2;
    2869             if a < 0 then
    2870               c := c1
    2871             else
    2872             if a > len then
    2873               c := c2
    2874             else
    2875             begin
    2876               b      := round(a / len * 256);
    2877               ec.red := (ec1.red * (256 - b) + ec2.red * b + 127) shr 8;
    2878               ec.green := (ec1.green * (256 - b) + ec2.green * b + 127) shr 8;
    2879               ec.blue := (ec1.blue * (256 - b) + ec2.blue * b + 127) shr 8;
    2880               ec.alpha := (ec1.alpha * (256 - b) + ec2.alpha * b + 127) shr 8;
    2881               c      := GammaCompression(ec);
    2882             end;
    2883             pixelProc(xb, yb, c);
    2884           end;
    2885 
    2886       gtDiamond:
    2887         for yb := y to y2 - 1 do
    2888           for xb := x to x2 - 1 do
    2889           begin
    2890             p.x := xb - o1.x;
    2891             p.y := yb - o1.y;
    2892             a   := max(abs(p.x * u.x + p.y * u.y), abs(p.x * u.y - p.y * u.x));
    2893             if Sinus then a := (sin(a*2*Pi/len)+1)*len/2;
    2894             if a < 0 then
    2895               c := c1
    2896             else
    2897             if a > len then
    2898               c := c2
    2899             else
    2900             begin
    2901               b      := round(a / len * 256);
    2902               ec.red := (ec1.red * (256 - b) + ec2.red * b + 127) shr 8;
    2903               ec.green := (ec1.green * (256 - b) + ec2.green * b + 127) shr 8;
    2904               ec.blue := (ec1.blue * (256 - b) + ec2.blue * b + 127) shr 8;
    2905               ec.alpha := (ec1.alpha * (256 - b) + ec2.alpha * b + 127) shr 8;
    2906               c      := GammaCompression(ec);
    2907             end;
    2908             pixelProc(xb, yb, c);
    2909           end;
    2910 
    2911       gtRadial:
    2912         for yb := y to y2 - 1 do
    2913           for xb := x to x2 - 1 do
    2914           begin
    2915             p.x := xb - o1.x;
    2916             p.y := yb - o1.y;
    2917             a   := sqrt(sqr(p.x * u.x + p.y * u.y) + sqr(p.x * u.y - p.y * u.x));
    2918             if Sinus then a := (sin(a*2*Pi/len)+1)*len/2;
    2919             if a < 0 then
    2920               c := c1
    2921             else
    2922             if a > len then
    2923               c := c2
    2924             else
    2925             begin
    2926               b      := round(a / len * 256);
    2927               ec.red := (ec1.red * (256 - b) + ec2.red * b + 127) shr 8;
    2928               ec.green := (ec1.green * (256 - b) + ec2.green * b + 127) shr 8;
    2929               ec.blue := (ec1.blue * (256 - b) + ec2.blue * b + 127) shr 8;
    2930               ec.alpha := (ec1.alpha * (256 - b) + ec2.alpha * b + 127) shr 8;
    2931               c      := GammaCompression(ec);
    2932             end;
    2933             pixelProc(xb, yb, c);
    2934           end;
    2935     end;
    2936   end
    2937   else
    2938   begin
    2939     //render without gamma correction
    2940     case gtype of
    2941       gtLinear:
    2942         for yb := y to y2 - 1 do
    2943           for xb := x to x2 - 1 do
    2944           begin
    2945             p.x := xb - o1.x;
    2946             p.y := yb - o1.y;
    2947             a   := p.x * u.x + p.y * u.y;
    2948             if Sinus then a := (sin(a*2*Pi/len)+1)*len/2;
    2949             if a < 0 then
    2950               c := c1
    2951             else
    2952             if a > len then
    2953               c := c2
    2954             else
    2955             begin
    2956               b      := round(a / len * 256);
    2957               c.red  := (c1.red * (256 - b) + c2.red * b + 127) shr 8;
    2958               c.green := (c1.green * (256 - b) + c2.green * b + 127) shr 8;
    2959               c.blue := (c1.blue * (256 - b) + c2.blue * b + 127) shr 8;
    2960               c.alpha := (c1.alpha * (256 - b) + c2.alpha * b + 127) shr 8;
    2961             end;
    2962             pixelProc(xb, yb, c);
    2963           end;
    2964 
    2965       gtReflected:
    2966         for yb := y to y2 - 1 do
    2967           for xb := x to x2 - 1 do
    2968           begin
    2969             p.x := xb - o1.x;
    2970             p.y := yb - o1.y;
    2971             a   := abs(p.x * u.x + p.y * u.y);
    2972             if Sinus then a := (sin(a*2*Pi/len)+1)*len/2;
    2973             if a < 0 then
    2974               c := c1
    2975             else
    2976             if a > len then
    2977               c := c2
    2978             else
    2979             begin
    2980               b      := round(a / len * 256);
    2981               c.red  := (c1.red * (256 - b) + c2.red * b + 127) shr 8;
    2982               c.green := (c1.green * (256 - b) + c2.green * b + 127) shr 8;
    2983               c.blue := (c1.blue * (256 - b) + c2.blue * b + 127) shr 8;
    2984               c.alpha := (c1.alpha * (256 - b) + c2.alpha * b + 127) shr 8;
    2985             end;
    2986             pixelProc(xb, yb, c);
    2987           end;
    2988 
    2989       gtDiamond:
    2990         for yb := y to y2 - 1 do
    2991           for xb := x to x2 - 1 do
    2992           begin
    2993             p.x := xb - o1.x;
    2994             p.y := yb - o1.y;
    2995             a   := max(abs(p.x * u.x + p.y * u.y), abs(p.x * u.y - p.y * u.x));
    2996             if Sinus then a := (sin(a*2*Pi/len)+1)*len/2;
    2997             if a < 0 then
    2998               c := c1
    2999             else
    3000             if a > len then
    3001               c := c2
    3002             else
    3003             begin
    3004               b      := round(a / len * 256);
    3005               c.red  := (c1.red * (256 - b) + c2.red * b + 127) shr 8;
    3006               c.green := (c1.green * (256 - b) + c2.green * b + 127) shr 8;
    3007               c.blue := (c1.blue * (256 - b) + c2.blue * b + 127) shr 8;
    3008               c.alpha := (c1.alpha * (256 - b) + c2.alpha * b + 127) shr 8;
    3009             end;
    3010             pixelProc(xb, yb, c);
    3011           end;
    3012 
    3013       gtRadial:
    3014         for yb := y to y2 - 1 do
    3015           for xb := x to x2 - 1 do
    3016           begin
    3017             p.x := xb - o1.x;
    3018             p.y := yb - o1.y;
    3019             a   := sqrt(sqr(p.x * u.x + p.y * u.y) + sqr(p.x * u.y - p.y * u.x));
    3020             if Sinus then a := (sin(a*2*Pi/len)+1)*len/2;
    3021             if a < 0 then
    3022               c := c1
    3023             else
    3024             if a > len then
    3025               c := c2
    3026             else
    3027             begin
    3028               b      := round(a / len * 256);
    3029               c.red  := (c1.red * (256 - b) + c2.red * b + 127) shr 8;
    3030               c.green := (c1.green * (256 - b) + c2.green * b + 127) shr 8;
    3031               c.blue := (c1.blue * (256 - b) + c2.blue * b + 127) shr 8;
    3032               c.alpha := (c1.alpha * (256 - b) + c2.alpha * b + 127) shr 8;
    3033             end;
    3034             pixelProc(xb, yb, c);
    3035           end;
    3036     end;
    3037   end;
    3038 end;
    3039 
     3310    dmLinearBlend:
     3311      for i := 0 to count-1 do
     3312      begin
     3313        FastBlendPixelInline(pdest, ScanNextPixel);
     3314        inc(pdest);
     3315      end;
     3316    dmDrawWithTransparency:
     3317      for i := 0 to count-1 do
     3318      begin
     3319        DrawPixelInlineWithAlphaCheck(pdest, ScanNextPixel);
     3320        inc(pdest);
     3321      end;
     3322    dmSet:
     3323      while count > 0 do
     3324      begin
     3325        nbCopy := FWidth-FScanCurX;
     3326        if count < nbCopy then nbCopy := count;
     3327        move((FScanPtr+FScanCurX)^,pdest^,nbCopy*sizeof(TBGRAPixel));
     3328        inc(pdest,nbCopy);
     3329        inc(FScanCurX,nbCopy);
     3330        if FScanCurX = FWidth then FScanCurX := 0;
     3331        dec(count,nbCopy);
     3332      end;
     3333    dmSetExceptTransparent:
     3334      for i := 0 to count-1 do
     3335      begin
     3336        c := ScanNextPixel;
     3337        if c.alpha = 255 then pdest^ := c;
     3338        inc(pdest);
     3339      end;
     3340    dmXor:
     3341      for i := 0 to count-1 do
     3342      begin
     3343        PDWord(pdest)^ := PDWord(pdest)^ xor DWord(ScanNextPixel);
     3344        inc(pdest);
     3345      end;
     3346  end;
     3347end;
     3348
     3349{ General purpose pixel drawing function }
    30403350procedure TBGRADefaultBitmap.DrawPixels(c: TBGRAPixel; start, Count: integer);
    30413351var
     
    30443354  if c.alpha = 0 then
    30453355    exit;
     3356  if c.alpha = 255 then
     3357  begin
     3358    Fill(c,start,Count);
     3359    exit;
     3360  end;
    30463361
    30473362  if start < 0 then
     
    30563371
    30573372  p := Data + start;
    3058   while Count > 0 do
    3059   begin
    3060     DrawPixelInline(p, c);
    3061     Inc(p);
    3062     Dec(Count);
    3063   end;
     3373  DrawPixelsInline(p,c,Count);
    30643374  InvalidateBitmap;
    30653375end;
     
    30863396end;
    30873397
     3398{ Ensure that transparent pixels have all channels to zero }
    30883399procedure TBGRADefaultBitmap.ClearTransparentPixels;
    30893400var
     
    31013412end;
    31023413
    3103 procedure TBGRADefaultBitmap.PutImage(x, y: integer; Source: TBGRADefaultBitmap;
    3104   mode: TDrawMode);
    3105 var
    3106   x2, y2, yb, minxb, minyb, maxxb, ignoreleft, copycount, sourcewidth,
     3414function TBGRADefaultBitmap.CheckPutImageBounds(x,y,tx,ty: integer; out minxb,minyb,maxxb,maxyb,ignoreleft: integer): boolean inline;
     3415var x2,y2: integer;
     3416begin
     3417  if (x >= FClipRect.Right) or (y >= FClipRect.Bottom) or (x <= FClipRect.Left-tx) or
     3418    (y <= FClipRect.Top-ty) or (Height = 0) or (ty = 0) or (tx = 0) then
     3419  begin
     3420    result := false;
     3421    exit;
     3422  end;
     3423
     3424  x2 := x + tx - 1;
     3425  y2 := y + ty - 1;
     3426
     3427  if y < FClipRect.Top then
     3428    minyb := FClipRect.Top
     3429  else
     3430    minyb := y;
     3431  if y2 >= FClipRect.Bottom then
     3432    maxyb := FClipRect.Bottom - 1
     3433  else
     3434    maxyb := y2;
     3435
     3436  if x < FClipRect.Left then
     3437  begin
     3438    ignoreleft := FClipRect.Left-x;
     3439    minxb      := FClipRect.Left;
     3440  end
     3441  else
     3442  begin
     3443    ignoreleft := 0;
     3444    minxb      := x;
     3445  end;
     3446  if x2 >= FClipRect.Right then
     3447    maxxb := FClipRect.Right - 1
     3448  else
     3449    maxxb := x2;
     3450
     3451  result := true;
     3452end;
     3453
     3454function TBGRADefaultBitmap.CheckAntialiasRectBounds(var x, y, x2, y2: single;
     3455  w: single): boolean;
     3456var
     3457  temp: Single;
     3458begin
     3459  if (x > x2) then
     3460  begin
     3461    temp := x;
     3462    x    := x2;
     3463    x2   := temp;
     3464  end;
     3465  if (y > y2) then
     3466  begin
     3467    temp := y;
     3468    y    := y2;
     3469    y2   := temp;
     3470  end;
     3471
     3472  result := (x2 - x > w) and (y2 - y > w);
     3473end;
     3474
     3475function TBGRADefaultBitmap.GetCanvasBGRA: TBGRACanvas;
     3476begin
     3477  if FCanvasBGRA = nil then
     3478    FCanvasBGRA := TBGRACanvas.Create(self);
     3479  result := FCanvasBGRA;
     3480end;
     3481
     3482function TBGRADefaultBitmap.GetCanvas2D: TBGRACanvas2D;
     3483begin
     3484  if FCanvas2D = nil then
     3485    FCanvas2D := TBGRACanvas2D.Create(self);
     3486  result := FCanvas2D;
     3487end;
     3488
     3489procedure TBGRADefaultBitmap.PutImage(x, y: integer; Source: TBGRACustomBitmap;
     3490  mode: TDrawMode; AOpacity: byte);
     3491var
     3492  yb, minxb, minyb, maxxb, maxyb, ignoreleft, copycount, sourcewidth,
    31073493  i, delta_source, delta_dest: integer;
    31083494  psource, pdest: PBGRAPixel;
    3109 begin
     3495  tempPixel: TBGRAPixel;
     3496
     3497begin
     3498  if (source = nil) or (AOpacity = 0) then exit;
    31103499  sourcewidth := Source.Width;
    31113500
    3112   if (x >= Width) or (y >= Height) or (x <= -sourcewidth) or
    3113     (y <= -Source.Height) or (Height = 0) or (Source.Height = 0) then
    3114     exit;
    3115 
    3116   x2 := x + sourcewidth - 1;
    3117   y2 := y + Source.Height - 1;
    3118 
    3119   if y < 0 then
    3120     minyb := 0
    3121   else
    3122     minyb := y;
    3123   if y2 >= Height then
    3124     y2 := Height - 1;
    3125 
    3126   if x < 0 then
    3127   begin
    3128     ignoreleft := -x;
    3129     minxb      := 0;
    3130   end
    3131   else
    3132   begin
    3133     ignoreleft := 0;
    3134     minxb      := x;
    3135   end;
    3136   if x2 >= Width then
    3137     maxxb := Width - 1
    3138   else
    3139     maxxb := x2;
     3501  if not CheckPutImageBounds(x,y,sourcewidth,source.height,minxb,minyb,maxxb,maxyb,ignoreleft) then exit;
    31403502
    31413503  copycount := maxxb - minxb + 1;
    31423504
    31433505  psource := Source.ScanLine[minyb - y] + ignoreleft;
    3144   if Source.FLineOrder = riloBottomToTop then
     3506  if Source.LineOrder = riloBottomToTop then
    31453507    delta_source := -sourcewidth
    31463508  else
     
    31563518    dmSet:
    31573519    begin
    3158       copycount *= sizeof(TBGRAPixel);
    3159       for yb := minyb to y2 do
     3520      if AOpacity <> 255 then
    31603521      begin
    3161         move(psource^, pdest^, copycount);
    3162         Inc(psource, delta_source);
    3163         Inc(pdest, delta_dest);
     3522        for yb := minyb to maxyb do
     3523        begin
     3524          CopyPixelsWithOpacity(pdest, psource, AOpacity, copycount);
     3525          Inc(psource, delta_source);
     3526          Inc(pdest, delta_dest);
     3527        end;
     3528      end
     3529      else
     3530      begin
     3531        copycount *= sizeof(TBGRAPixel);
     3532        for yb := minyb to maxyb do
     3533        begin
     3534          move(psource^, pdest^, copycount);
     3535          Inc(psource, delta_source);
     3536          Inc(pdest, delta_dest);
     3537        end;
    31643538      end;
    31653539      InvalidateBitmap;
     
    31693543      Dec(delta_source, copycount);
    31703544      Dec(delta_dest, copycount);
    3171       for yb := minyb to y2 do
     3545      for yb := minyb to maxyb do
    31723546      begin
    3173         for i := copycount - 1 downto 0 do
     3547        if AOpacity <> 255 then
    31743548        begin
    3175           if psource^.alpha = 255 then
    3176             pdest^ := psource^;
    3177           Inc(pdest);
    3178           Inc(psource);
    3179         end;
     3549          for i := copycount - 1 downto 0 do
     3550          begin
     3551            if psource^.alpha = 255 then
     3552            begin
     3553              tempPixel := psource^;
     3554              tempPixel.alpha := ApplyOpacity(tempPixel.alpha,AOpacity);
     3555              FastBlendPixelInline(pdest,tempPixel);
     3556            end;
     3557            Inc(pdest);
     3558            Inc(psource);
     3559          end;
     3560        end else
     3561          for i := copycount - 1 downto 0 do
     3562          begin
     3563            if psource^.alpha = 255 then
     3564              pdest^ := psource^;
     3565            Inc(pdest);
     3566            Inc(psource);
     3567          end;
    31803568        Inc(psource, delta_source);
    31813569        Inc(pdest, delta_dest);
     
    31873575      Dec(delta_source, copycount);
    31883576      Dec(delta_dest, copycount);
    3189       for yb := minyb to y2 do
     3577      for yb := minyb to maxyb do
    31903578      begin
    3191         for i := copycount - 1 downto 0 do
     3579        if AOpacity <> 255 then
    31923580        begin
    3193           DrawPixelInline(pdest, psource^);
    3194           Inc(pdest);
    3195           Inc(psource);
    3196         end;
     3581          for i := copycount - 1 downto 0 do
     3582          begin
     3583            DrawPixelInlineWithAlphaCheck(pdest, psource^, AOpacity);
     3584            Inc(pdest);
     3585            Inc(psource);
     3586          end;
     3587        end
     3588        else
     3589          for i := copycount - 1 downto 0 do
     3590          begin
     3591            DrawPixelInlineWithAlphaCheck(pdest, psource^);
     3592            Inc(pdest);
     3593            Inc(psource);
     3594          end;
    31973595        Inc(psource, delta_source);
    31983596        Inc(pdest, delta_dest);
     
    32043602      Dec(delta_source, copycount);
    32053603      Dec(delta_dest, copycount);
    3206       for yb := minyb to y2 do
     3604      for yb := minyb to maxyb do
    32073605      begin
    3208         for i := copycount - 1 downto 0 do
     3606        if AOpacity <> 255 then
    32093607        begin
    3210           FastBlendPixelInline(pdest, psource^);
    3211           Inc(pdest);
    3212           Inc(psource);
    3213         end;
     3608          for i := copycount - 1 downto 0 do
     3609          begin
     3610            FastBlendPixelInline(pdest, psource^, AOpacity);
     3611            Inc(pdest);
     3612            Inc(psource);
     3613          end;
     3614        end else
     3615          for i := copycount - 1 downto 0 do
     3616          begin
     3617            FastBlendPixelInline(pdest, psource^);
     3618            Inc(pdest);
     3619            Inc(psource);
     3620          end;
    32143621        Inc(psource, delta_source);
    32153622        Inc(pdest, delta_dest);
     
    32173624      InvalidateBitmap;
    32183625    end;
    3219   end;
    3220 end;
    3221 
    3222 procedure TBGRADefaultBitmap.BlendImage(x, y: integer; Source: TBGRADefaultBitmap;
     3626    dmXor:
     3627    begin
     3628      if AOpacity <> 255 then
     3629      begin
     3630        Dec(delta_source, copycount);
     3631        Dec(delta_dest, copycount);
     3632        for yb := minyb to maxyb do
     3633        begin
     3634          for i := copycount - 1 downto 0 do
     3635          begin
     3636            FastBlendPixelInline(pdest, TBGRAPixel(PDWord(pdest)^ xor PDword(psource)^), AOpacity);
     3637            Inc(pdest);
     3638            Inc(psource);
     3639          end;
     3640          Inc(psource, delta_source);
     3641          Inc(pdest, delta_dest);
     3642        end;
     3643      end else
     3644      begin
     3645        for yb := minyb to maxyb do
     3646        begin
     3647          XorPixels(pdest, psource, copycount);
     3648          Inc(psource, delta_source);
     3649          Inc(pdest, delta_dest);
     3650        end;
     3651      end;
     3652      InvalidateBitmap;
     3653    end;
     3654  end;
     3655end;
     3656
     3657procedure TBGRADefaultBitmap.BlendImage(x, y: integer; Source: TBGRACustomBitmap;
    32233658  operation: TBlendOperation);
    32243659var
    3225   x2, y2, yb, minxb, minyb, maxxb, ignoreleft, copycount, sourcewidth,
     3660  yb, minxb, minyb, maxxb, maxyb, ignoreleft, copycount, sourcewidth,
    32263661  delta_source, delta_dest: integer;
    32273662  psource, pdest: PBGRAPixel;
     
    32293664  sourcewidth := Source.Width;
    32303665
    3231   if (x >= Width) or (y >= Height) or (x <= -sourcewidth) or
    3232     (y <= -Source.Height) or (Height = 0) or (Source.Height = 0) then
    3233     exit;
    3234 
    3235   x2 := x + sourcewidth - 1;
    3236   y2 := y + Source.Height - 1;
    3237 
    3238   if y < 0 then
    3239     minyb := 0
    3240   else
    3241     minyb := y;
    3242   if y2 >= Height then
    3243     y2 := Height - 1;
    3244 
    3245   if x < 0 then
    3246   begin
    3247     ignoreleft := -x;
    3248     minxb      := 0;
    3249   end
    3250   else
    3251   begin
    3252     ignoreleft := 0;
    3253     minxb      := x;
    3254   end;
    3255   if x2 >= Width then
    3256     maxxb := Width - 1
    3257   else
    3258     maxxb := x2;
     3666  if not CheckPutImageBounds(x,y,sourcewidth,source.height,minxb,minyb,maxxb,maxyb,ignoreleft) then exit;
    32593667
    32603668  copycount := maxxb - minxb + 1;
    32613669
    32623670  psource := Source.ScanLine[minyb - y] + ignoreleft;
    3263   if Source.FLineOrder = riloBottomToTop then
     3671  if Source.LineOrder = riloBottomToTop then
    32643672    delta_source := -sourcewidth
    32653673  else
     
    32723680    delta_dest := Width;
    32733681
    3274   for yb := minyb to y2 do
     3682  for yb := minyb to maxyb do
    32753683  begin
    32763684    BlendPixels(pdest, psource, operation, copycount);
     
    32813689end;
    32823690
    3283 function TBGRADefaultBitmap.Duplicate: TBGRADefaultBitmap;
     3691{ Draw an image wih an angle. Use an affine transformation to do this. }
     3692procedure TBGRADefaultBitmap.PutImageAngle(x, y: single;
     3693  Source: TBGRACustomBitmap; angle: single; imageCenterX: single;
     3694  imageCenterY: single; AOpacity: Byte);
     3695var
     3696  cosa,sina: single;
     3697
     3698  { Compute rotated coordinates }
     3699  function Coord(relX,relY: single): TPointF;
     3700  begin
     3701    relX -= imageCenterX;
     3702    relY -= imageCenterY;
     3703    result.x := relX*cosa-relY*sina+x;
     3704    result.y := relY*cosa+relX*sina+y;
     3705  end;
     3706
     3707begin
     3708  cosa := cos(-angle*Pi/180);
     3709  sina := -sin(-angle*Pi/180);
     3710  PutImageAffine(Coord(0,0),Coord(source.Width,0),Coord(0,source.Height),source,AOpacity);
     3711end;
     3712
     3713{ Draw an image with an affine transformation (rotation, scale, translate).
     3714  Parameters are the bitmap origin, the end of the horizontal axis and the end of the vertical axis. }
     3715procedure TBGRADefaultBitmap.PutImageAffine(Origin,HAxis,VAxis: TPointF; Source: TBGRACustomBitmap; AOpacity: Byte);
     3716var affine: TBGRAAffineBitmapTransform;
     3717    minx,miny,maxx,maxy: integer;
     3718    pt4: TPointF;
     3719
     3720  //include specified point in the bounds
     3721  procedure Include(pt: TPointF);
     3722  begin
     3723    if floor(pt.X) < minx then minx := floor(pt.X);
     3724    if floor(pt.Y) < miny then miny := floor(pt.Y);
     3725    if ceil(pt.X) > maxx then maxx := ceil(pt.X);
     3726    if ceil(pt.Y) > maxy then maxy := ceil(pt.Y);
     3727  end;
     3728
     3729begin
     3730  if (abs(Origin.x-round(Origin.x))<1e-6) and (abs(Origin.y-round(Origin.Y))<1e-6) and
     3731     (abs(HAxis.x-(Origin.x+Source.Width))<1e-6) and (abs(HAxis.y-origin.y)<1e-6) and
     3732     (abs(VAxis.x-Origin.x)<1e-6) and (abs(VAxis.y-(Origin.y+Source.Height))<1e-6) then
     3733  begin
     3734    PutImage(round(origin.x),round(origin.y),Source,dmDrawWithTransparency,AOpacity);
     3735    exit;
     3736  end;
     3737
     3738  { Create affine transformation }
     3739  affine := TBGRAAffineBitmapTransform.Create(Source);
     3740  affine.GlobalOpacity := AOpacity;
     3741  affine.Fit(Origin,HAxis,VAxis);
     3742
     3743  { Compute bounds }
     3744  pt4.x := VAxis.x+HAxis.x-Origin.x;
     3745  pt4.y := VAxis.y+HAxis.y-Origin.y;
     3746  minx := floor(Origin.X);
     3747  miny := floor(Origin.Y);
     3748  maxx := ceil(Origin.X);
     3749  maxy := ceil(Origin.Y);
     3750  Include(HAxis);
     3751  Include(VAxis);
     3752  Include(pt4);
     3753
     3754  { Use the affine transformation as a scanner }
     3755  FillRect(minx,miny,maxx+1,maxy+1,affine,dmDrawWithTransparency);
     3756  affine.Free;
     3757end;
     3758
     3759{ Duplicate bitmap content. Optionally, bitmap properties can be also duplicated }
     3760function TBGRADefaultBitmap.Duplicate(DuplicateProperties: Boolean = False): TBGRACustomBitmap;
     3761var Temp: TBGRADefaultBitmap;
    32843762begin
    32853763  LoadFromBitmapIfNeeded;
    3286   Result := NewBitmap(Width, Height);
    3287   Result.PutImage(0, 0, self, dmSet);
    3288   Result.Caption := self.Caption;
    3289 end;
    3290 
    3291 function TBGRADefaultBitmap.Equals(comp: TBGRADefaultBitmap): boolean;
     3764  Temp := NewBitmap(Width, Height) as TBGRADefaultBitmap;
     3765  Temp.PutImage(0, 0, self, dmSet);
     3766  Temp.Caption := self.Caption;
     3767  if DuplicateProperties then
     3768    CopyPropertiesTo(Temp);
     3769  Result := Temp;
     3770end;
     3771
     3772{ Copy properties only }
     3773procedure TBGRADefaultBitmap.CopyPropertiesTo(ABitmap: TBGRADefaultBitmap);
     3774begin
     3775  ABitmap.CanvasOpacity := CanvasOpacity;
     3776  ABitmap.CanvasDrawModeFP := CanvasDrawModeFP;
     3777  ABitmap.PenStyle := PenStyle;
     3778  ABitmap.CustomPenStyle := CustomPenStyle;
     3779  ABitmap.FontHeight := FontHeight;
     3780  ABitmap.FontName := FontName;
     3781  ABitmap.FontStyle := FontStyle;
     3782  ABitmap.FontAntialias := FontAntialias;
     3783  ABitmap.FontOrientation := FontOrientation;
     3784  ABitmap.LineCap := LineCap;
     3785  ABitmap.JoinStyle := JoinStyle;
     3786  ABitmap.FillMode := FillMode;
     3787  ABitmap.ClipRect := ClipRect;
     3788end;
     3789
     3790{ Check if two bitmaps have the same content }
     3791function TBGRADefaultBitmap.Equals(comp: TBGRACustomBitmap): boolean;
    32923792var
    32933793  yb, xb: integer;
     
    33203820end;
    33213821
     3822{ Check if a bitmap is filled wih the specified color }
    33223823function TBGRADefaultBitmap.Equals(comp: TBGRAPixel): boolean;
    33233824var
     
    33383839end;
    33393840
    3340 function TBGRADefaultBitmap.FilterSmartZoom3(Option: TMedianOption): TBGRADefaultBitmap;
     3841{----------------------------- Filters -----------------------------------------}
     3842{ Call the appropriate function }
     3843
     3844function TBGRADefaultBitmap.FilterSmartZoom3(Option: TMedianOption): TBGRACustomBitmap;
    33413845begin
    33423846  Result := BGRAFilters.FilterSmartZoom3(self, Option);
    33433847end;
    33443848
    3345 function TBGRADefaultBitmap.FilterMedian(Option: TMedianOption): TBGRADefaultBitmap;
     3849function TBGRADefaultBitmap.FilterMedian(Option: TMedianOption): TBGRACustomBitmap;
    33463850begin
    33473851  Result := BGRAFilters.FilterMedian(self, option);
    33483852end;
    33493853
    3350 function TBGRADefaultBitmap.FilterSmooth: TBGRADefaultBitmap;
     3854function TBGRADefaultBitmap.FilterSmooth: TBGRACustomBitmap;
    33513855begin
    33523856  Result := BGRAFilters.FilterBlurRadialPrecise(self, 0.3);
    33533857end;
    33543858
    3355 function TBGRADefaultBitmap.FilterSphere: TBGRADefaultBitmap;
     3859function TBGRADefaultBitmap.FilterSphere: TBGRACustomBitmap;
    33563860begin
    33573861  Result := BGRAFilters.FilterSphere(self);
    33583862end;
    33593863
    3360 function TBGRADefaultBitmap.FilterCylinder: TBGRADefaultBitmap;
     3864function TBGRADefaultBitmap.FilterTwirl(ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap;
     3865begin
     3866  Result := BGRAFilters.FilterTwirl(self, ACenter, ARadius, ATurn, AExponent);
     3867end;
     3868
     3869function TBGRADefaultBitmap.FilterCylinder: TBGRACustomBitmap;
    33613870begin
    33623871  Result := BGRAFilters.FilterCylinder(self);
    33633872end;
    33643873
    3365 function TBGRADefaultBitmap.FilterPlane: TBGRADefaultBitmap;
     3874function TBGRADefaultBitmap.FilterPlane: TBGRACustomBitmap;
    33663875begin
    33673876  Result := BGRAFilters.FilterPlane(self);
    33683877end;
    33693878
    3370 function TBGRADefaultBitmap.FilterSharpen: TBGRADefaultBitmap;
     3879function TBGRADefaultBitmap.FilterSharpen: TBGRACustomBitmap;
    33713880begin
    33723881  Result := BGRAFilters.FilterSharpen(self);
    33733882end;
    33743883
    3375 function TBGRADefaultBitmap.FilterContour: TBGRADefaultBitmap;
     3884function TBGRADefaultBitmap.FilterContour: TBGRACustomBitmap;
    33763885begin
    33773886  Result := BGRAFilters.FilterContour(self);
     
    33793888
    33803889function TBGRADefaultBitmap.FilterBlurRadial(radius: integer;
    3381   blurType: TRadialBlurType): TBGRADefaultBitmap;
     3890  blurType: TRadialBlurType): TBGRACustomBitmap;
    33823891begin
    33833892  Result := BGRAFilters.FilterBlurRadial(self, radius, blurType);
    33843893end;
    33853894
     3895function TBGRADefaultBitmap.FilterPixelate(pixelSize: integer;
     3896  useResample: boolean; filter: TResampleFilter): TBGRACustomBitmap;
     3897begin
     3898  Result:= BGRAFilters.FilterPixelate(self, pixelSize, useResample, filter);
     3899end;
     3900
    33863901function TBGRADefaultBitmap.FilterBlurMotion(distance: integer;
    3387   angle: single; oriented: boolean): TBGRADefaultBitmap;
     3902  angle: single; oriented: boolean): TBGRACustomBitmap;
    33883903begin
    33893904  Result := BGRAFilters.FilterBlurMotion(self, distance, angle, oriented);
    33903905end;
    33913906
    3392 function TBGRADefaultBitmap.FilterCustomBlur(mask: TBGRADefaultBitmap):
    3393 TBGRADefaultBitmap;
     3907function TBGRADefaultBitmap.FilterCustomBlur(mask: TBGRACustomBitmap):
     3908TBGRACustomBitmap;
    33943909begin
    33953910  Result := BGRAFilters.FilterBlur(self, mask);
    33963911end;
    33973912
    3398 function TBGRADefaultBitmap.FilterEmboss(angle: single): TBGRADefaultBitmap;
     3913function TBGRADefaultBitmap.FilterEmboss(angle: single): TBGRACustomBitmap;
    33993914begin
    34003915  Result := BGRAFilters.FilterEmboss(self, angle);
     
    34023917
    34033918function TBGRADefaultBitmap.FilterEmbossHighlight(FillSelection: boolean):
    3404 TBGRADefaultBitmap;
     3919TBGRACustomBitmap;
    34053920begin
    34063921  Result := BGRAFilters.FilterEmbossHighlight(self, FillSelection);
    34073922end;
    34083923
    3409 function TBGRADefaultBitmap.FilterGrayscale: TBGRADefaultBitmap;
     3924function TBGRADefaultBitmap.FilterGrayscale: TBGRACustomBitmap;
    34103925begin
    34113926  Result := BGRAFilters.FilterGrayscale(self);
     
    34133928
    34143929function TBGRADefaultBitmap.FilterNormalize(eachChannel: boolean = True):
    3415 TBGRADefaultBitmap;
     3930TBGRACustomBitmap;
    34163931begin
    34173932  Result := BGRAFilters.FilterNormalize(self, eachChannel);
     
    34193934
    34203935function TBGRADefaultBitmap.FilterRotate(origin: TPointF;
    3421   angle: single): TBGRADefaultBitmap;
     3936  angle: single): TBGRACustomBitmap;
    34223937begin
    34233938  Result := BGRAFilters.FilterRotate(self, origin, angle);
     
    34813996end;
    34823997
     3998function TBGRADefaultBitmap.CreateAdaptedPngWriter: TFPWriterPNG;
     3999begin
     4000  result := TFPWriterPNG.Create;
     4001  result.Indexed := False;
     4002  result.UseAlpha := HasTransparentPixels;
     4003  result.WordSized := false;
     4004end;
     4005
     4006{$hints off}
     4007function TBGRADefaultBitmap.LoadAsBmp32(Str: TStream): boolean;
     4008var OldPos: int64;
     4009    fileHeader: TBitmapFileHeader;
     4010    infoHeader: TBitmapInfoHeader;
     4011    dataSize: integer;
     4012begin
     4013  OldPos := Str.Position;
     4014  result := false;
     4015  try
     4016    if Str.Read(fileHeader,sizeof(fileHeader)) <> sizeof(fileHeader) then
     4017      raise exception.Create('Inuable to read file header');
     4018    if fileHeader.bfType = $4D42 then
     4019    begin
     4020      if Str.Read(infoHeader,sizeof(infoHeader)) <> sizeof(infoHeader) then
     4021        raise exception.Create('Inuable to read info header');
     4022
     4023      if (infoHeader.biPlanes = 1) and (infoHeader.biBitCount = 32) and (infoHeader.biCompression = 0) then
     4024      begin
     4025        SetSize(infoHeader.biWidth,infoHeader.biHeight);
     4026        Str.Position := OldPos+fileHeader.bfOffBits;
     4027        dataSize := NbPixels*sizeof(TBGRAPixel);
     4028        if Str.Read(Data^, dataSize) <> dataSize then
     4029        Begin
     4030          SetSize(0,0);
     4031          raise exception.Create('Unable to read data');
     4032        end;
     4033        result := true;
     4034      end;
     4035    end;
     4036
     4037  except
     4038    on ex:exception do
     4039    begin
     4040
     4041    end;
     4042  end;
     4043  Str.Position := OldPos;
     4044
     4045end;
     4046{$hints on}
     4047
    34834048procedure TBGRADefaultBitmap.SetCanvasOpacity(AValue: byte);
    34844049begin
     
    34964061
    34974062function TBGRADefaultBitmap.FineResample(NewWidth, NewHeight: integer):
    3498 TBGRADefaultBitmap;
    3499 begin
    3500   Result := BGRAResample.FineResample(self, NewWidth, NewHeight);
     4063TBGRACustomBitmap;
     4064begin
     4065  Result := BGRAResample.FineResample(self, NewWidth, NewHeight, ResampleFilter);
    35014066end;
    35024067
    35034068function TBGRADefaultBitmap.SimpleStretch(NewWidth, NewHeight: integer):
    3504 TBGRADefaultBitmap;
     4069TBGRACustomBitmap;
    35054070begin
    35064071  Result := BGRAResample.SimpleStretch(self, NewWidth, NewHeight);
     
    35084073
    35094074function TBGRADefaultBitmap.Resample(newWidth, newHeight: integer;
    3510   mode: TResampleMode): TBGRADefaultBitmap;
     4075  mode: TResampleMode): TBGRACustomBitmap;
    35114076begin
    35124077  case mode of
     
    35204085{-------------------------------- Data functions ------------------------}
    35214086
     4087{ Flip vertically the bitmap. Use a temporary line to store top line,
     4088  assign bottom line to top line, then assign temporary line to bottom line.
     4089
     4090  It is an involution, i.e it does nothing when applied twice }
    35224091procedure TBGRADefaultBitmap.VerticalFlip;
    35234092var
     
    35314100    exit;
    35324101
     4102  LoadFromBitmapIfNeeded;
    35334103  linesize := Width * sizeof(TBGRAPixel);
    35344104  line     := nil;
     
    35484118end;
    35494119
     4120{ Flip horizontally. Swap left pixels with right pixels on each line.
     4121
     4122  It is an involution, i.e it does nothing when applied twice}
    35504123procedure TBGRADefaultBitmap.HorizontalFlip;
    35514124var
     
    35584131    exit;
    35594132
     4133  LoadFromBitmapIfNeeded;
    35604134  for yb := 0 to Height - 1 do
    35614135  begin
     
    35744148end;
    35754149
    3576 function TBGRADefaultBitmap.RotateCW: TBGRADefaultBitmap;
     4150{ Return a new bitmap rotated in a clock wise direction. }
     4151function TBGRADefaultBitmap.RotateCW: TBGRACustomBitmap;
    35774152var
    35784153  psrc, pdest: PBGRAPixel;
     
    35804155  delta: integer;
    35814156begin
     4157  LoadFromBitmapIfNeeded;
    35824158  Result := NewBitmap(Height, Width);
    35834159  if Result.LineOrder = riloTopToBottom then
     
    35984174end;
    35994175
    3600 function TBGRADefaultBitmap.RotateCCW: TBGRADefaultBitmap;
     4176{ Return a new bitmap rotated in a counter clock wise direction. }
     4177function TBGRADefaultBitmap.RotateCCW: TBGRACustomBitmap;
    36014178var
    36024179  psrc, pdest: PBGRAPixel;
     
    36044181  delta: integer;
    36054182begin
     4183  LoadFromBitmapIfNeeded;
    36064184  Result := NewBitmap(Height, Width);
    36074185  if Result.LineOrder = riloTopToBottom then
     
    36224200end;
    36234201
     4202{ Compute negative with gamma correction. A negative contains
     4203  complentary colors (black becomes white etc.).
     4204
     4205  It is an involution, i.e it does nothing when applied twice }
    36244206procedure TBGRADefaultBitmap.Negative;
    36254207var
     
    36274209  n: integer;
    36284210begin
     4211  LoadFromBitmapIfNeeded;
    36294212  p := Data;
    36304213  for n := NbPixels - 1 downto 0 do
     
    36414224end;
    36424225
     4226{ Compute negative without gamma correction.
     4227
     4228  It is an involution, i.e it does nothing when applied twice }
    36434229procedure TBGRADefaultBitmap.LinearNegative;
    36444230var
     
    36464232  n: integer;
    36474233begin
     4234  LoadFromBitmapIfNeeded;
    36484235  p := Data;
    36494236  for n := NbPixels - 1 downto 0 do
     
    36604247end;
    36614248
     4249{ Swap red and blue channels. Useful when RGB order is swapped.
     4250
     4251  It is an involution, i.e it does nothing when applied twice }
    36624252procedure TBGRADefaultBitmap.SwapRedBlue;
    36634253var
     
    36664256  p:    PLongword;
    36674257begin
     4258  LoadFromBitmapIfNeeded;
    36684259  p := PLongword(Data);
    36694260  n := NbPixels;
     
    36714262    exit;
    36724263  repeat
    3673     temp := p^;
    3674     p^   := ((temp and $FF) shl 16) or ((temp and $FF0000) shr 16) or
    3675       temp and $FF00FF00;
     4264    temp := LEtoN(p^);
     4265    p^   := NtoLE(((temp and $FF) shl 16) or ((temp and $FF0000) shr 16) or
     4266      temp and $FF00FF00);
    36764267    Inc(p);
    36774268    Dec(n);
     
    36804271end;
    36814272
     4273{ Convert a grayscale image into a black image with alpha value }
    36824274procedure TBGRADefaultBitmap.GrayscaleToAlpha;
    36834275var
     
    36864278  p:    PLongword;
    36874279begin
     4280  LoadFromBitmapIfNeeded;
    36884281  p := PLongword(Data);
    36894282  n := NbPixels;
     
    36914284    exit;
    36924285  repeat
    3693     temp := p^;
    3694     p^   := (temp and $FF) shl 24;
     4286    temp := LEtoN(p^);
     4287    p^   := NtoLE((temp and $FF) shl 24);
    36954288    Inc(p);
    36964289    Dec(n);
     
    37054298  p:    PLongword;
    37064299begin
     4300  LoadFromBitmapIfNeeded;
    37074301  p := PLongword(Data);
    37084302  n := NbPixels;
     
    37104304    exit;
    37114305  repeat
    3712     temp := p^ shr 24;
    3713     p^   := temp or (temp shl 8) or (temp shl 16) or $FF000000;
     4306    temp := LEtoN(p^ shr 24);
     4307    p^   := NtoLE(temp or (temp shl 8) or (temp shl 16) or $FF000000);
    37144308    Inc(p);
    37154309    Dec(n);
     
    37184312end;
    37194313
    3720 procedure TBGRADefaultBitmap.ApplyMask(mask: TBGRADefaultBitmap);
     4314{ Apply a mask to the bitmap. It means that alpha channel is
     4315  changed according to grayscale values of the mask.
     4316
     4317  See : http://wiki.lazarus.freepascal.org/BGRABitmap_tutorial_5 }
     4318procedure TBGRADefaultBitmap.ApplyMask(mask: TBGRACustomBitmap);
    37214319var
    37224320  p, pmask: PBGRAPixel;
     
    37264324    exit;
    37274325
     4326  LoadFromBitmapIfNeeded;
    37284327  for yb := 0 to Height - 1 do
    37294328  begin
     
    37324331    for xb := Width - 1 downto 0 do
    37334332    begin
    3734       p^.alpha := (p^.alpha * pmask^.red + 128) div 255;
     4333      p^.alpha := ApplyOpacity(p^.alpha, pmask^.red);
    37354334      Inc(p);
    37364335      Inc(pmask);
     
    37404339end;
    37414340
     4341procedure TBGRADefaultBitmap.ApplyGlobalOpacity(alpha: byte);
     4342var
     4343  p: PBGRAPixel;
     4344  i: integer;
     4345begin
     4346  if alpha = 0 then
     4347    FillTransparent
     4348  else
     4349  if alpha <> 255 then
     4350  begin
     4351    p := Data;
     4352    for i := NbPixels - 1 downto 0 do
     4353    begin
     4354      p^.alpha := ApplyOpacity(p^.alpha, alpha);
     4355      Inc(p);
     4356    end;
     4357  end;
     4358end;
     4359
     4360{ Get bounds of non zero values of specified channel }
    37424361function TBGRADefaultBitmap.GetImageBounds(Channel: TChannel = cAlpha): TRect;
    37434362var
     
    37934412end;
    37944413
     4414function TBGRADefaultBitmap.GetImageBounds(Channels: TChannels): TRect;
     4415var c: TChannel;
     4416begin
     4417  result := rect(0,0,0,0);
     4418  for c := low(TChannel) to high(TChannel) do
     4419    if c in Channels then
     4420      UnionRect(result,result,GetImageBounds(c));
     4421end;
     4422
     4423{ Make a copy of the transparent bitmap to a TBitmap with a background color
     4424  instead of transparency }
    37954425function TBGRADefaultBitmap.MakeBitmapCopy(BackgroundColor: TColor): TBitmap;
    37964426var
    3797   opaqueCopy: TBGRADefaultBitmap;
     4427  opaqueCopy: TBGRACustomBitmap;
    37984428begin
    37994429  Result     := TBitmap.Create;
     
    38074437end;
    38084438
    3809 procedure TBGRADefaultBitmap.DrawPart(Arect: TRect; Canvas: TCanvas;
    3810   x, y: integer; Opaque: boolean);
    3811 var
    3812   partial: TBGRADefaultBitmap;
    3813 begin
    3814   partial := GetPart(ARect);
    3815   if partial <> nil then
    3816   begin
    3817     partial.Draw(Canvas, x, y, Opaque);
    3818     partial.Free;
    3819   end;
    3820 end;
    3821 
    3822 function TBGRADefaultBitmap.GetPart(ARect: TRect): TBGRADefaultBitmap;
     4439{ Get a part of the image with repetition in both directions. It means
     4440  that if the bounds are within the image, the result is just that part
     4441  of the image, but if the bounds are bigger than the image, the image
     4442  is tiled. }
     4443function TBGRADefaultBitmap.GetPart(ARect: TRect): TBGRACustomBitmap;
    38234444var
    38244445  copywidth, copyheight, widthleft, heightleft, curxin, curyin, xdest,
     
    38904511end;
    38914512
     4513function TBGRADefaultBitmap.GetPtrBitmap(Top, Bottom: Integer
     4514  ): TBGRACustomBitmap;
     4515var temp: integer;
     4516    ptrbmp: TBGRAPtrBitmap;
     4517begin
     4518  if Top > Bottom then
     4519  begin
     4520    temp := Top;
     4521    Top := Bottom;
     4522    Bottom := Temp;
     4523  end;
     4524  if Top < 0 then Top := 0;
     4525  if Bottom > Height then Bottom := Height;
     4526  if Top >= Bottom then
     4527    result := nil
     4528  else
     4529  begin
     4530    if LineOrder = riloTopToBottom then
     4531      ptrbmp := TBGRAPtrBitmap.Create(Width,Bottom-Top,ScanLine[Top]) else
     4532      ptrbmp := TBGRAPtrBitmap.Create(Width,Bottom-Top,ScanLine[Bottom-1]);
     4533    ptrbmp.LineOrder := LineOrder;
     4534    result := ptrbmp;
     4535  end;
     4536end;
     4537
     4538{ Draw BGRA data to a canvas with transparency }
    38924539procedure TBGRADefaultBitmap.DataDrawTransparent(ACanvas: TCanvas;
    38934540  Rect: TRect; AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
     
    39114558end;
    39124559
     4560{ Draw BGRA data to a canvas without transparency }
    39134561procedure TBGRADefaultBitmap.DataDrawOpaque(ACanvas: TCanvas;
    39144562  Rect: TRect; AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
     
    39244572  ALineEndMargin: integer;
    39254573  CreateResult: boolean;
    3926 {$IFDEF DARWIN}
    3927   TempShift: byte;
    3928 {$ENDIF}
     4574  {$IFDEF DARWIN}
     4575  TempShift: Byte;
     4576  {$ENDIF}
    39294577begin
    39304578  if (AHeight = 0) or (AWidth = 0) then
     
    39394587  PTempData := TempData;
    39404588  PSource   := AData;
    3941      {$IFDEF DARWIN}
    3942   SwapRedBlue; //swap red and blue values
    3943      {$ENDIF}
     4589
     4590{$IFDEF DARWIN} //swap red and blue values
    39444591  for y := 0 to AHeight - 1 do
    39454592  begin
    39464593    for x := 0 to AWidth - 1 do
    39474594    begin
    3948       PWord(PTempData)^ := PWord(PSource)^;
    3949       Inc(PTempData, 2);
    3950       Inc(PSource, 2);
    3951       PTempData^ := PSource^;
    3952       Inc(PTempData);
    3953       Inc(PSource, 2);
     4595      PTempData^ := (PSource+2)^;
     4596      (PTempData+1)^ := (PSource+1)^;
     4597      (PTempData+2)^ := PSource^;
     4598      inc(PTempData,3);
     4599      inc(PSource,4);
    39544600    end;
    39554601    Inc(PTempData, ALineEndMargin);
    39564602  end;
    3957      {$IFDEF DARWIN}
    3958   SwapRedBlue; //swap red and blue values
    3959      {$ENDIF}
     4603{$ELSE}
     4604  for y := 0 to AHeight - 1 do
     4605  begin
     4606    for x := 0 to AWidth - 1 do
     4607    begin
     4608      PWord(PTempData)^ := PWord(PSource)^;
     4609      (PTempData+2)^ := (PSource+2)^;
     4610      Inc(PTempData,3);
     4611      Inc(PSource, 4);
     4612    end;
     4613    Inc(PTempData, ALineEndMargin);
     4614  end;
     4615{$ENDIF}
    39604616
    39614617  RawImage.Init;
    39624618  RawImage.Description.Init_BPP24_B8G8R8_BIO_TTB(AWidth, AHeight);
    3963      {$IFDEF DARWIN}
    3964   //swap red and blue positions
     4619{$IFDEF DARWIN}
    39654620  TempShift := RawImage.Description.RedShift;
    39664621  RawImage.Description.RedShift := RawImage.Description.BlueShift;
    39674622  RawImage.Description.BlueShift := TempShift;
    3968      {$ENDIF}
     4623{$ENDIF}
     4624
    39694625  RawImage.Description.LineOrder := ALineOrder;
    39704626  RawImage.Description.LineEnd := rileDWordBoundary;
     4627
    39714628  if integer(RawImage.Description.BytesPerLine) <> AWidth * 3 + ALineEndMargin then
    39724629  begin
     
    39994656    raise EOutOfMemory.Create('TBGRADefaultBitmap: Not enough memory');
    40004657  InvalidateBitmap;
     4658  FScanPtr := nil;
    40014659end;
    40024660
     
    40424700var
    40434701  bmp: TBitmap;
    4044   subBmp: TBGRADefaultBitmap;
     4702  subBmp: TBGRACustomBitmap;
    40454703  subRect: TRect;
    40464704  cw,ch: integer;
     
    40814739end;
    40824740
     4741function TBGRADefaultBitmap.GetNbPixels: integer;
     4742begin
     4743  result := FNbPixels;
     4744end;
     4745
     4746function TBGRADefaultBitmap.GetWidth: integer;
     4747begin
     4748  Result := FWidth;
     4749end;
     4750
     4751function TBGRADefaultBitmap.GetHeight: integer;
     4752begin
     4753  Result:= FHeight;
     4754end;
     4755
     4756function TBGRADefaultBitmap.GetRefCount: integer;
     4757begin
     4758  result := FRefCount;
     4759end;
     4760
     4761function TBGRADefaultBitmap.GetLineOrder: TRawImageLineOrder;
     4762begin
     4763  result := FLineOrder;
     4764end;
     4765
     4766function TBGRADefaultBitmap.GetCanvasOpacity: byte;
     4767begin
     4768  result:= FCanvasOpacity;
     4769end;
     4770
     4771function TBGRADefaultBitmap.GetFontHeight: integer;
     4772begin
     4773  result := FFontHeight;
     4774end;
     4775
    40834776{ TBGRAPtrBitmap }
    40844777
     
    40994792end;
    41004793
    4101 function TBGRAPtrBitmap.Duplicate: TBGRADefaultBitmap;
     4794function TBGRAPtrBitmap.Duplicate(DuplicateProperties: Boolean = False): TBGRACustomBitmap;
    41024795begin
    41034796  Result := NewBitmap(Width, Height);
    4104   TBGRAPtrBitmap(Result).SetDataPtr(FData);
     4797  if DuplicateProperties then CopyPropertiesTo(TBGRADefaultBitmap(Result));
    41054798end;
    41064799
     
    41084801begin
    41094802  FData := AData;
     4803end;
     4804
     4805procedure BGRAGradientFill(bmp: TBGRACustomBitmap; x, y, x2, y2: integer;
     4806  c1, c2: TBGRAPixel; gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode;
     4807  gammaColorCorrection: boolean = True; Sinus: Boolean=False);
     4808var
     4809  gradScan : TBGRAGradientScanner;
     4810begin
     4811  //handles transparency
     4812  if (c1.alpha = 0) and (c2.alpha = 0) then
     4813  begin
     4814    bmp.FillRect(x, y, x2, y2, BGRAPixelTransparent, mode);
     4815    exit;
     4816  end;
     4817
     4818  gradScan := TBGRAGradientScanner.Create(c1,c2,gtype,o1,o2,gammaColorCorrection,Sinus);
     4819  bmp.FillRect(x,y,x2,y2,gradScan,mode);
     4820  gradScan.Free;
    41104821end;
    41114822
  • GraphicTest/BGRABitmap/bgradnetdeserial.pas

    r210 r317  
    44
    55interface
     6
     7{ This unit allow to read .Net serialized classes with BinaryFormatter of
     8  namespace System.Runtime.Serialization.Formatters.Binary.
     9
     10  Serialization is a process by which objects in memory are saved according
     11  to their structure.
     12
     13  This unit is used by BGRAPaintNet to read Paint.NET images. }
    614
    715uses
     
    917
    1018type
     19  arrayOfLongword = array of longword;
     20
    1121  TTypeCategory = (ftPrimitiveType = 0, ftString = 1, ftObjectType =
    1222    2, ftRuntimeType = 3,
     
    1727    ptDouble = 6, ptInt16 = 7, ptInt32 = 8, ptInt64 = 9, ptSByte = 10, ptSingle = 11,
    1828    ptDateTime = 13, ptUInt16 = 14, ptUInt32 = 15, ptUInt64 = 16, ptString = 18);
     29
     30  TGenericArrayType = (gatSingleDimension, gatJagged, gatMultidimensional);
     31
     32  TDotNetDeserialization = class;
    1933
    2034  ArrayOfNameValue = array of record
     
    4357  end;
    4458
    45   PSerializedObject = ^TSerializedObject;
    46 
    47   TSerializedObject = record
     59  { TCustomSerializedObject }
     60
     61  TCustomSerializedObject = class
     62  protected
     63    FContainer: TDotNetDeserialization;
     64    function GetTypeAsString: string; virtual; abstract;
     65    function GetFieldAsString(Index: longword): string; virtual; abstract;
     66    function GetFieldAsString(Name: string): string;
     67    function GetFieldCount: longword; virtual; abstract;
     68    function GetFieldName(Index: longword): string; virtual; abstract;
     69    function GetFieldTypeAsString(Index: longword): string; virtual; abstract;
     70    function IsReferenceType(index: longword): boolean; virtual; abstract;
     71  public
    4872    idObject:   longword;
    49     numType:    integer;
    50     fields:     ArrayOfNameValue;
    5173    refCount:   integer;
    5274    inToString: boolean;
     75    constructor Create(container: TDotNetDeserialization); virtual;
     76    property FieldCount: longword read GetFieldCount;
     77    property FieldName[Index: longword]:string read GetFieldName;
     78    property FieldAsString[Index: longword]: string read GetFieldAsString;
     79    property FieldByNameAsString[Name: string]: string read GetFieldAsString;
     80    property FieldTypeAsString[Index: longword]: string read GetFieldTypeAsString;
     81    property TypeAsString: string read GetTypeAsString;
     82    function GetFieldIndex(Name: string): integer;
     83  end;
     84
     85  { TSerializedClass }
     86
     87  TSerializedClass = class(TCustomSerializedObject)
     88  protected
     89    function GetFieldAsString(Index: longword): string; override;
     90    function GetFieldCount: longword; override;
     91    function GetFieldName(Index: longword): string; override;
     92    function GetFieldTypeAsString(Index: longword): string; override;
     93    function IsReferenceType(index: longword): boolean; override;
     94    function GetTypeAsString: string; override;
     95  public
     96    numType: integer;
     97    fields:  ArrayOfNameValue;
     98  end;
     99
     100  { TSerializedArray }
     101
     102  TSerializedArray = class(TCustomSerializedObject)
     103  private
     104    data:       pointer;
     105    FItemSize:   longword;
     106    function GetItemPtr(Index: longword): pointer;
     107    procedure InitData;
     108  protected
     109    FArrayType: TGenericArrayType;
     110    function GetFieldAsString(Index: longword): string; override;
     111    function GetFieldCount: longword; override;
     112    function GetFieldName(Index: longword): string; override;
     113    function GetFieldTypeAsString(Index: longword): string; override;
     114    function IsReferenceType(index: longword): boolean; override;
     115    function GetTypeAsString: string; override;
     116  public
     117    dimensions: array of longword;
     118    itemType:   TFieldType;
     119    nbItems:    longword;
     120    constructor Create(AContainer: TDotNetDeserialization; AItemType: TFieldType; ALength: longword); overload;
     121    constructor Create(AContainer: TDotNetDeserialization; AArrayType: TGenericArrayType; AItemType: TFieldType; ADimensions: arrayOfLongword); overload;
     122    destructor Destroy; override;
     123    property ItemPtr[Index:longword]: pointer read GetItemPtr;
     124    property ItemSize: longword read FItemSize;
     125  end;
     126
     127  { TSerializedValue }
     128
     129  TSerializedValue = class(TSerializedArray)
     130  protected
     131    function GetIsReferenceType: boolean;
     132    function GetValueAsString: string;
     133    function GetTypeAsString: string; override;
     134  public
     135    constructor Create(AContainer: TDotNetDeserialization; AItemType: TFieldType); overload;
     136    property ValueAsString: string read GetValueAsString;
     137    property IsReferenceType: boolean read GetIsReferenceType;
    53138  end;
    54139
     
    57142    objectTypes: array of TSerializedType;
    58143    assemblies:  array of TAssemblyReference;
    59     objects:     array of TSerializedObject;
    60 
    61     function FindObject(typeName: string): PSerializedObject;
    62     function GetSimpleField(obj: TSerializedObject; Name: string): string;
    63     function FieldIndex(obj: TSerializedObject; Name: string): integer;
    64     function GetObjectField(obj: TSerializedObject; Name: string): PSerializedObject;
    65     function GetObject(id: string): PSerializedObject;
    66     function GetObject(id: longword): PSerializedObject;
    67     function GetObjectType(obj: PSerializedObject): string;
    68     function PrimitiveTypeName(pt: TPrimitiveType): string;
    69     function IsBoxedValue(obj: TSerializedObject; index: integer): boolean;
    70     function GetBoxedValue(obj: TSerializedObject; index: integer): string;
    71     function IsReferenceType(numType: integer; index: integer): boolean;
     144    objects:     array of TCustomSerializedObject;
     145
     146    function FindClass(typeName: string): TSerializedClass;
     147    function FindObject(typeName: string): TCustomSerializedObject;
     148    function GetSimpleField(obj: TCustomSerializedObject; Name: string): string;
     149    function GetObjectField(obj: TCustomSerializedObject; Name: string): TCustomSerializedObject;
     150    function GetObjectField(obj: TCustomSerializedObject; index: integer): TCustomSerializedObject;
     151    function GetObject(id: string): TCustomSerializedObject;
     152    function GetObject(id: longword): TCustomSerializedObject;
     153    function IsBoxedValue(obj: TCustomSerializedObject; index: integer): boolean;
     154    function GetBoxedValue(obj: TCustomSerializedObject; index: integer): string;
    72155    procedure LoadFromStream(Stream: TStream);
    73156    procedure LoadFromFile(filename: string);
    74157    function ToString: string;
    75158    constructor Create;
     159    destructor Destroy; override;
     160    function GetTypeOfClassObject(idObject: longword): integer;
    76161  private
    77162    EndOfStream:      boolean;
    78     ArrayFillerCount: integer;
     163    ArrayFillerCount: Longword;
    79164    currentAutoObjectValue: longword;
    80165    function nextAutoObjectId: longword;
    81166    function LoadNextFromStream(Stream: TStream): longword;
    82167    function LoadStringFromStream(Stream: TStream): string;
     168    function LoadDotNetCharFromStream(Stream: TStream): string;
    83169    function LoadTypeFromStream(Stream: TStream; IsRuntimeType: boolean): integer;
    84170    function LoadValuesFromStream(Stream: TStream; numType: integer): ArrayOfNameValue;
    85     function LoadValueFromStream(Stream: TStream; fieldType: TFieldType): string;
    86     function GetTypeOfObject(idObject: longword): integer;
    87   end;
    88 
     171    function LoadValueFromStream(Stream: TStream; const fieldType: TFieldType): string;
     172    function LoadFieldType(Stream: TStream; category: TTypeCategory): TFieldType;
     173  end;
     174
     175function WinReadByte(stream: TStream): byte;
    89176function WinReadWord(Stream: TStream): word;
    90177function WinReadSmallInt(Stream: TStream): smallint;
     
    119206
    120207{$hints off}
     208
     209function WinReadByte(stream: TStream): byte;
     210begin
     211  stream.Read(Result, sizeof(Result));
     212end;
     213
    121214function WinReadWord(Stream: TStream): word;
    122215begin
     
    155248end;
    156249
    157 {$hints on}
    158 
    159 { TDotNetDeserialization }
    160 
    161 function TDotNetDeserialization.FindObject(typeName: string): PSerializedObject;
    162 var
    163   i, numType:   integer;
    164   comparedType: string;
    165 begin
    166   for i := 0 to high(objects) do
     250function GetFieldTypeSize(const fieldType: TFieldType): longword;
     251begin
     252  case fieldType.category of
     253    ftPrimitiveType:
     254      case fieldType.primitiveType of
     255        ptBoolean, ptByte,ptSByte: result := 1;
     256        ptChar,ptString, ptDecimal: Result := sizeof(string);
     257        ptSingle: result := sizeof(single);
     258        ptDouble: result := sizeof(double);
     259        ptInt16,ptUInt16: result := 2;
     260        ptInt32,ptUInt32: result := 4;
     261        ptInt64,ptUInt64,ptDateTime: result := 8;
     262      else
     263        raise Exception.Create('Unknown primitive type (' + IntToStr(
     264          byte(fieldType.primitiveType)) + ')');
     265      end;
     266    ftString, ftObjectType, ftRuntimeType, ftGenericType, ftArrayOfObject,
     267    ftArrayOfString, ftArrayOfPrimitiveType: result := 4;
     268  else
     269    raise Exception.Create('Unknown field type (' + IntToStr(
     270      byte(fieldType.category)) + ')');
     271  end;
     272end;
     273
     274function IsDotNetTypeStoredAsString(const fieldType: TFieldType): boolean;
     275begin
     276  result := (fieldType.category = ftPrimitiveType) and
     277    (fieldType.primitiveType in [ptChar,ptString,ptDecimal]);
     278end;
     279
     280function DotNetValueToString(var value; const fieldType: TFieldType): string;
     281var
     282  tempByte:     byte;
     283  value2bytes: record
     284    case byte of
     285    2: (tempWord: word);
     286    3: (tempInt16: smallint);
     287  end;
     288  value4bytes: record
     289    case byte of
     290    1: (tempSingle:   single);
     291    2: (tempLongWord: longword);
     292    3: (tempLongInt: longint);
     293  end;
     294  value8bytes: record
     295    case byte of
     296    1: (tempDouble:   double);
     297    2: (tempInt64:    Int64);
     298    2: (tempUInt64:   QWord);
     299  end;
     300  tempIdObject: longword;
     301
     302begin
     303  if IsDotNetTypeStoredAsString(fieldType) then
    167304  begin
    168     numType := objects[i].numType;
    169     if numType >= 0 then
    170     begin
    171       comparedType := objectTypes[numType].ClassName;
    172       if (comparedType = typeName) or (length(typeName) <
    173         length(comparedType)) and
    174         (copy(comparedType, length(comparedType) - length(typeName),
    175         length(typeName) + 1) = '.' + typeName) then
    176       begin
    177         Result := @objects[i];
    178         exit;
    179       end;
    180     end;
    181   end;
    182   Result := nil;
    183 end;
    184 
    185 function TDotNetDeserialization.GetSimpleField(obj: TSerializedObject;
    186   Name: string): string;
    187 var
    188   i: integer;
    189 begin
    190   i := FieldIndex(obj, Name);
    191   if i = -1 then
    192     Result := ''
    193   else
    194   begin
    195     if IsBoxedValue(obj, i) then
    196       Result := GetBoxedValue(obj, i)
     305    Result := pstring(@value)^;
     306    exit;
     307  end;
     308  case fieldType.category of
     309    ftPrimitiveType: case fieldType.primitiveType of
     310        ptBoolean:
     311        begin
     312          {$hints off}
     313          move(value,tempByte,sizeof(tempByte));
     314          {$hints on}
     315          if tempByte = 0 then
     316            Result := 'False'
     317          else
     318          if tempByte = 1 then
     319            Result := 'True'
     320          else
     321            raise Exception.Create('Invalid boolean value (' +
     322              IntToStr(tempByte) + ')');
     323        end;
     324        ptByte: Result := inttostr(pbyte(@value)^);
     325        ptSByte: Result := inttostr(pshortint(@value)^);
     326        ptInt16,ptUInt16:
     327        begin
     328          {$hints off}
     329          move(value, value2bytes.tempWord,sizeof(word));
     330          {$hints on}
     331          value2bytes.tempWord := LEtoN(value2bytes.tempWord);
     332          if fieldType.primitiveType = ptInt16 then
     333            Result := IntToStr(value2bytes.tempInt16)
     334          else
     335            Result := IntToStr(value2bytes.tempWord);
     336        end;
     337        ptInt32,ptUInt32,ptSingle:
     338        begin
     339          {$hints off}
     340          move(value, value4bytes.tempLongWord,sizeof(longword));
     341          {$hints on}
     342          value4bytes.tempLongWord := LEtoN(value4bytes.tempLongWord);
     343          if fieldType.primitiveType = ptInt32 then
     344            Result := IntToStr(value4bytes.tempLongInt)
     345          else if fieldType.primitiveType = ptUInt32 then
     346            Result := IntToStr(value4bytes.tempLongWord)
     347          else
     348            result := FloatToStr(value4bytes.tempSingle);
     349        end;
     350
     351        ptInt64,ptUInt64,ptDouble,ptDateTime:
     352        begin
     353          {$hints off}
     354          move(value, value8bytes.tempUInt64,8);
     355          {$hints on}
     356          value8bytes.tempUInt64 := LEtoN(value8bytes.tempUInt64);
     357          if fieldType.primitiveType = ptInt64 then
     358            Result := IntToStr(value8bytes.tempInt64)
     359          else if fieldType.primitiveType = ptUInt64 then
     360            Result := IntToStr(value8bytes.tempUInt64)
     361          else if fieldType.primitiveType = ptDouble then
     362            result := FloatToStr(value8bytes.tempDouble)
     363          else
     364            Result := DateTimeToStr(
     365            (value8bytes.tempUInt64 and $7FFFFFFFFFFFFFFF - 599264352000000000) / 864000000000);
     366        end;
     367        else
     368          raise Exception.Create('Unknown primitive type (' + IntToStr(
     369            byte(fieldType.primitiveType)) + ')');
     370      end;
     371    ftString, ftObjectType, ftRuntimeType, ftGenericType, ftArrayOfObject,
     372    ftArrayOfString, ftArrayOfPrimitiveType:
     373    begin
     374      {$hints off}
     375      move(value,tempIdObject,sizeof(tempIdObject));
     376      {$hints on}
     377      result := '#' + IntToStr(tempIdObject);
     378    end;
    197379    else
    198       Result := obj.fields[i].Value;
    199   end;
    200 end;
    201 
    202 function TDotNetDeserialization.FieldIndex(obj: TSerializedObject;
    203   Name: string): integer;
    204 var
    205   i: integer;
    206 begin
    207   //case sensitive
    208   for i := 0 to high(obj.fields) do
    209     if obj.fields[i].Name = Name then
    210     begin
    211       Result := i;
    212       exit;
    213     end;
    214   //case insensitive
    215   for i := 0 to high(obj.fields) do
    216     if compareText(obj.fields[i].Name, Name) = 0 then
    217     begin
    218       Result := i;
    219       exit;
    220     end;
    221   //case sensitive inner member
    222   for i := 0 to high(obj.fields) do
    223     if (length(Name) < length(obj.fields[i].Name)) and
    224       (copy(obj.fields[i].Name, length(obj.fields[i].Name) - length(Name),
    225       length(Name) + 1) = '+' + Name) then
    226     begin
    227       Result := i;
    228       exit;
    229     end;
    230   //case insensitive inner member
    231   for i := 0 to high(obj.fields) do
    232     if (length(Name) < length(obj.fields[i].Name)) and
    233       (compareText(copy(obj.fields[i].Name, length(obj.fields[i].Name) -
    234       length(Name), length(Name) + 1), '+' + Name) = 0) then
    235     begin
    236       Result := i;
    237       exit;
    238     end;
    239   Result := -1;
    240 end;
    241 
    242 function TDotNetDeserialization.GetObjectField(obj: TSerializedObject;
    243   Name: string): PSerializedObject;
    244 var
    245   i: integer;
    246 begin
    247   i := FieldIndex(obj, Name);
    248   if i = -1 then
    249     Result := nil
    250   else
    251   begin
    252     if not IsReferenceType(obj.numType, i) then
    253       raise Exception.Create('GetObjectMember: Not a reference type');
    254     Result := GetObject(obj.fields[i].Value);
    255   end;
    256 end;
    257 
    258 function TDotNetDeserialization.GetObject(id: string): PSerializedObject;
    259 var
    260   idObj: longword;
    261 begin
    262   if copy(id, 1, 1) = '#' then
    263     Delete(id, 1, 1);
    264   idObj  := StrToInt(id);
    265   Result := GetObject(idObj);
    266 end;
    267 
    268 function TDotNetDeserialization.GetObject(id: longword): PSerializedObject;
    269 var
    270   i: integer;
    271 begin
    272   for i := 0 to high(objects) do
    273     if objects[i].idObject = id then
    274     begin
    275       Result := @objects[i];
    276       exit;
    277     end;
    278   Result := nil;
    279 end;
    280 
    281 function TDotNetDeserialization.GetObjectType(obj: PSerializedObject): string;
    282 begin
    283   if (obj^.numType = -btString) then
    284     Result := 'String'
    285   else
    286   if (obj^.numType = -btArrayOfObject) then
    287     Result := 'Object[]'
    288   else
    289   if (obj^.numType = -btArrayOfString) then
    290     Result := 'String[]'
    291   else
    292   if (obj^.numType < 0) or (obj^.numType > high(objectTypes)) then
    293     Result := ''
    294   else
    295   begin
    296     Result := objectTypes[obj^.numType].ClassName;
    297   end;
    298 end;
    299 
    300 function TDotNetDeserialization.PrimitiveTypeName(pt: TPrimitiveType): string;
     380      raise Exception.Create('Unknown field type (' + IntToStr(
     381        byte(fieldType.category)) + ')');
     382  end;
     383end;
     384
     385function PrimitiveTypeName(pt: TPrimitiveType): string;
    301386begin
    302387  case pt of
     
    317402    ptString: Result   := 'String';
    318403    else
    319       raise Exception.Create('Unknown primitive type (' + IntToStr(byte(pt)) + ')');
    320   end;
    321 end;
    322 
    323 function TDotNetDeserialization.IsBoxedValue(obj: TSerializedObject;
     404      raise Exception.Create('Unknown primitive type (' + IntToStr(integer(pt)) + ')');
     405  end;
     406end;
     407
     408Function DotNetTypeToString(ft: TFieldType): string;
     409begin
     410  if ft.category = ftPrimitiveType then
     411    result := PrimitiveTypeName(ft.primitiveType)
     412  else
     413    case ft.category of
     414      ftString: result := 'String';
     415      ftObjectType: result := 'Object';
     416      ftRuntimeType: result := 'RuntimeType';
     417      ftGenericType: result := 'GenericType';
     418      ftArrayOfObject: result := 'Object[]';
     419      ftArrayOfString: result := 'String[]';
     420      ftArrayOfPrimitiveType: result := 'PrimitiveType[]';
     421    else
     422      raise Exception.Create('Unknown field type (' + IntToStr(
     423        byte(ft.category)) + ')');
     424    end;
     425end;
     426
     427{ TCustomSerializedObject }
     428
     429function TCustomSerializedObject.GetFieldAsString(Name: string): string;
     430begin
     431  result := GetFieldAsString(GetFieldIndex(Name));
     432end;
     433
     434constructor TCustomSerializedObject.Create(container: TDotNetDeserialization);
     435begin
     436  FContainer := container;
     437  refCount := 0;
     438end;
     439
     440function TCustomSerializedObject.GetFieldIndex(Name: string): integer;
     441var
     442  i: integer;
     443  fn: string;
     444begin
     445  if FieldCount = 0 then
     446  begin
     447    result := -1;
     448    exit;
     449  end;
     450  //case sensitive
     451  for i := 0 to FieldCount-1 do
     452    if FieldName[i] = Name then
     453    begin
     454      Result := i;
     455      exit;
     456    end;
     457  //case insensitive
     458  for i := 0 to FieldCount-1 do
     459    if compareText(FieldName[i], Name) = 0 then
     460    begin
     461      Result := i;
     462      exit;
     463    end;
     464  //case sensitive inner member
     465  for i := 0 to FieldCount-1 do
     466  begin
     467    fn := FieldName[i];
     468    if (length(Name) < length(fn)) and
     469      (copy(fn, length(fn) - length(Name),
     470      length(Name) + 1) = '+' + Name) then
     471    begin
     472      Result := i;
     473      exit;
     474    end;
     475  end;
     476  //case insensitive inner member
     477  for i := 0 to FieldCount-1 do
     478  begin
     479    fn := FieldName[i];
     480    if (length(Name) < length(fn)) and
     481      (compareText(copy(fn, length(fn) -
     482      length(Name), length(Name) + 1), '+' + Name) = 0) then
     483    begin
     484      Result := i;
     485      exit;
     486    end;
     487  end;
     488  Result := -1;
     489end;
     490
     491{ TSerializedClass }
     492
     493function TSerializedClass.GetFieldAsString(Index: longword): string;
     494begin
     495  result := fields[Index].Value;
     496end;
     497
     498function TSerializedClass.GetFieldCount: longword;
     499begin
     500  Result:= length(fields);
     501end;
     502
     503function TSerializedClass.GetFieldName(Index: longword): string;
     504begin
     505  result := fields[Index].Name;
     506end;
     507
     508function TSerializedClass.GetFieldTypeAsString(Index: longword): string;
     509begin
     510  result := fields[Index].valueType;
     511end;
     512
     513function TSerializedClass.IsReferenceType(index: longword): boolean;
     514begin
     515  Result:= FContainer.objectTypes[numType].fieldTypes[index].category <> ftPrimitiveType;
     516end;
     517
     518function TSerializedClass.GetTypeAsString: string;
     519begin
     520  Result:= FContainer.objectTypes[numType].ClassName;
     521end;
     522
     523{ TSerializedArray }
     524
     525procedure TSerializedArray.InitData;
     526begin
     527  FItemSize := GetFieldTypeSize(itemType);
     528  getmem(data, itemSize*nbItems);
     529  fillchar(data^, itemSize*nbItems, 0);
     530end;
     531
     532function TSerializedArray.GetItemPtr(Index: longword): pointer;
     533begin
     534  if index >= nbItems then
     535    raise exception.Create('Index out of bounds');
     536  result := pointer(pbyte(data)+Index*itemsize);
     537end;
     538
     539function TSerializedArray.GetFieldAsString(Index: longword): string;
     540begin
     541  if data = nil then
     542    result := ''
     543  else
     544    result := DotNetValueToString(ItemPtr[index]^, itemType);
     545end;
     546
     547function TSerializedArray.GetFieldCount: longword;
     548begin
     549  Result:= nbItems;
     550end;
     551
     552function TSerializedArray.GetFieldName(Index: longword): string;
     553var
     554  r: longword;
     555begin
     556  result := '[';
     557  for r := 1 to length(dimensions) do
     558  begin
     559    if r <> 1 then result+=',';
     560    result += inttostr(index mod dimensions[r-1]);
     561    index := index div dimensions[r-1];
     562  end;
     563  result += ']';
     564end;
     565
     566{$hints off}
     567function TSerializedArray.GetFieldTypeAsString(Index: longword): string;
     568begin
     569  Result:= DotNetTypeToString(itemType);
     570end;
     571{$hints on}
     572
     573{$hints off}
     574function TSerializedArray.IsReferenceType(index: longword): boolean;
     575begin
     576  Result:= itemType.category <> ftPrimitiveType;
     577end;
     578{$hints on}
     579
     580function TSerializedArray.GetTypeAsString: string;
     581var
     582  i: Integer;
     583begin
     584  Result:= DotNetTypeToString(itemType)+'[';
     585  for i := 2 to length(dimensions) do
     586    result += ',';
     587  result += ']';
     588end;
     589
     590constructor TSerializedArray.Create(AContainer: TDotNetDeserialization; AItemType: TFieldType; ALength: longword);
     591begin
     592  inherited Create(AContainer);
     593  setlength(dimensions,1);
     594  dimensions[0] := ALength;
     595  nbItems := ALength;
     596  FArrayType := gatSingleDimension;
     597  itemType := AItemType;
     598  InitData;
     599end;
     600
     601constructor TSerializedArray.Create(AContainer: TDotNetDeserialization; AArrayType: TGenericArrayType; AItemType: TFieldType;
     602  ADimensions: arrayOfLongword);
     603var n: longword;
     604begin
     605  inherited Create(AContainer);
     606  setlength(dimensions, length(ADimensions));
     607  nbItems := 1;
     608  if length(ADimensions) <> 0 then
     609    for n := 0 to length(ADimensions)-1 do
     610    begin
     611      dimensions[n] := ADimensions[n];
     612      nbItems *= ADimensions[n];
     613    end;
     614  FArrayType := AArrayType;
     615  itemType := AItemType;
     616  InitData;
     617end;
     618
     619destructor TSerializedArray.Destroy;
     620var ps: PString;
     621  n: longword;
     622begin
     623  if IsDotNetTypeStoredAsString(itemType) and (nbItems <> 0) then
     624  begin
     625    ps := PString(data);
     626    for n := 1 to nbItems do
     627    begin
     628      ps^ := '';
     629      inc(ps);
     630    end;
     631  end;
     632  freemem(data);
     633  inherited Destroy;
     634end;
     635
     636{ TSerializedValue }
     637
     638function TSerializedValue.GetIsReferenceType: boolean;
     639begin
     640  result := inherited IsReferenceType(0);
     641end;
     642
     643function TSerializedValue.GetValueAsString: string;
     644begin
     645  result := GetFieldAsString(0);
     646end;
     647
     648function TSerializedValue.GetTypeAsString: string;
     649begin
     650  Result:= GetFieldTypeAsString(0);
     651end;
     652
     653constructor TSerializedValue.Create(AContainer: TDotNetDeserialization;
     654  AItemType: TFieldType);
     655begin
     656  inherited Create(AContainer,AItemType,1);
     657end;
     658
     659{$hints on}
     660
     661{ TDotNetDeserialization }
     662
     663function TDotNetDeserialization.FindClass(typeName: string): TSerializedClass;
     664var obj: TCustomSerializedObject;
     665begin
     666  obj := FindObject(typeName);
     667  if obj is TSerializedClass then
     668    result := obj as TSerializedClass
     669  else
     670    raise exception.Create('FindClass: found object is not a class');
     671end;
     672
     673function TDotNetDeserialization.FindObject(typeName: string): TCustomSerializedObject;
     674var
     675  i:   integer;
     676  comparedType: string;
     677begin
     678  for i := 0 to high(objects) do
     679  begin
     680    comparedType := objects[i].TypeAsString;
     681    if (comparedType = typeName) or
     682      ( (length(typeName) < length(comparedType) ) and
     683        (copy(comparedType, length(comparedType) - length(typeName),
     684        length(typeName) + 1) = '.' + typeName) ) then
     685    begin
     686      Result := objects[i];
     687      exit;
     688    end;
     689  end;
     690  Result := nil;
     691end;
     692
     693function TDotNetDeserialization.GetSimpleField(obj: TCustomSerializedObject;
     694  Name: string): string;
     695var
     696  i,idxSlash: integer;
     697  tempSub: TCustomSerializedObject;
     698begin
     699  i := obj.GetFieldIndex(Name);
     700  if i = -1 then
     701  begin
     702    idxSlash := pos('\',name);
     703    if idxSlash <> 0 then
     704    begin
     705      tempSub := GetObjectField(obj,copy(name,1,idxSlash-1));
     706      if tempSub <> nil then
     707      begin
     708        result := GetSimpleField(tempSub,copy(name,idxSlash+1,length(name)-idxSlash));
     709        exit;
     710      end;
     711    end;
     712    Result := ''
     713  end
     714  else
     715  begin
     716    if IsBoxedValue(obj, i) then
     717      Result := GetBoxedValue(obj, i)
     718    else
     719      Result := obj.FieldAsString[i];
     720  end;
     721end;
     722
     723function TDotNetDeserialization.GetObjectField(obj: TCustomSerializedObject;
     724  Name: string): TCustomSerializedObject;
     725var
     726  i: integer;
     727  idxSlash: LongInt;
     728  tempSub: TCustomSerializedObject;
     729begin
     730  i := obj.GetFieldIndex(Name);
     731  if i = -1 then
     732  begin
     733    idxSlash := pos('\',name);
     734    if idxSlash <> 0 then
     735    begin
     736      tempSub := GetObjectField(obj,copy(name,1,idxSlash-1));
     737      if tempSub <> nil then
     738      begin
     739        result := GetObjectField(tempSub,copy(name,idxSlash+1,length(name)-idxSlash));
     740        exit;
     741      end;
     742    end;
     743    Result := nil
     744  end
     745  else
     746  begin
     747    if not obj.IsReferenceType(i) then
     748      raise Exception.Create('GetObjectField: Not a reference type');
     749    Result := GetObject(obj.FieldAsString[i]);
     750  end;
     751end;
     752
     753function TDotNetDeserialization.GetObjectField(obj: TCustomSerializedObject;
     754  index: integer): TCustomSerializedObject;
     755begin
     756  if not obj.IsReferenceType(index) then
     757    raise Exception.Create('GetObjectField: Not a reference type');
     758  Result := GetObject(obj.FieldAsString[index]);
     759end;
     760
     761function TDotNetDeserialization.GetObject(id: string): TCustomSerializedObject;
     762var
     763  idObj: longword;
     764begin
     765  if copy(id, 1, 1) = '#' then
     766    Delete(id, 1, 1);
     767  idObj  := StrToInt64(id);
     768  Result := GetObject(idObj);
     769end;
     770
     771function TDotNetDeserialization.GetObject(id: longword): TCustomSerializedObject;
     772var
     773  i: integer;
     774begin
     775  for i := 0 to high(objects) do
     776    if objects[i].idObject = id then
     777    begin
     778      Result := objects[i];
     779      exit;
     780    end;
     781  Result := nil;
     782end;
     783
     784function TDotNetDeserialization.IsBoxedValue(obj: TCustomSerializedObject;
    324785  index: integer): boolean;
    325786var
    326   subObj: PSerializedObject;
    327 begin
    328   if not IsReferenceType(obj.numType, index) then
     787  subObj: TCustomSerializedObject;
     788begin
     789  if not obj.IsReferenceType(index) then
    329790  begin
    330791    Result := False;
    331792    exit;
    332793  end;
    333   subObj := GetObject(obj.fields[index].Value);
    334   if subObj = nil then
     794  subObj := GetObject(obj.FieldAsString[index]);
     795  if subObj = nil then //suppose Nothing is a boxed value
    335796  begin
    336797    Result := True;
    337798    exit;
    338799  end;
    339   Result := (length(subObj^.fields) = 1) and (subObj^.fields[0].Name = '');
    340 end;
    341 
    342 function TDotNetDeserialization.GetBoxedValue(obj: TSerializedObject;
     800  Result := subObj is TSerializedValue;
     801end;
     802
     803function TDotNetDeserialization.GetBoxedValue(obj: TCustomSerializedObject;
    343804  index: integer): string;
    344805var
    345   subObj: PSerializedObject;
    346 begin
    347   if not IsReferenceType(obj.numType, index) then
     806  subObj: TCustomSerializedObject;
     807begin
     808  if not obj.IsReferenceType(index) then
    348809    raise Exception.Create('GetBoxedValue: Not a reference type');
    349   subObj := GetObject(obj.fields[index].Value);
     810  subObj := GetObject(obj.FieldAsString[index]);
    350811  if subObj = nil then
    351812  begin
     
    353814    exit;
    354815  end;
    355   if (length(subObj^.fields) = 1) and (subObj^.fields[0].Name = '') then
    356     Result := subObj^.fields[0].Value
     816  if (subObj is TSerializedValue) and not (subObj as TSerializedValue).IsReferenceType then
     817    Result := (subObj as TSerializedValue).ValueAsString
    357818  else
    358819    raise Exception.Create('GetBoxedValue: Not a primitive type');
    359 end;
    360 
    361 function TDotNetDeserialization.IsReferenceType(numType: integer;
    362   index: integer): boolean;
    363 begin
    364   if numType >= length(objectTypes) then
    365     raise Exception.Create('IsReferenceType: Type number out of bounds');
    366 
    367   if (numType < 0) then
    368   begin
    369     Result := (numType = -btArrayOfObject) or (numtype = -btArrayOfString);
    370   end
    371   else
    372   begin
    373     if (index < 0) or (index >= objecttypes[numType].nbFields) then
    374       raise Exception.Create('IsReferenceType: Index out of bounds');
    375 
    376     Result := (objecttypes[numType].fieldTypes[index].category <> ftPrimitiveType);
    377   end;
    378820end;
    379821
     
    433875    subNum: integer;
    434876    objType, subExpectedType: string;
     877    fieldTypeStr: string;
    435878  begin
    436879    Result := '';
     
    448891      end;
    449892      inToString := True;
     893      objType := TypeAsString;
    450894      if main then
    451895      begin
    452         if numType < 0 then
    453           objType := ''
    454         else
    455           objType := objectTypes[numType].ClassName;
    456896        Result += tab + 'Object';
    457         if refCount > 0 then
    458           Result += ' #' + IntToStr(idObject);
     897        Result += ' #' + IntToStr(idObject);
    459898        if (objType = '') or (objType = expectedType) then
    460899          Result += ' = '
     
    464903      else
    465904      begin
    466         objType := GetObjectType(@objects[num]);
    467905        if (objType = '') or (objType = expectedType) then
    468906          Result := ''
     
    477915        subExpectedType := '';
    478916
    479       if not main and (length(fields) = 1) and (fields[0].Name = '') then
     917      if not main and (objects[num] is TSerializedValue) then
    480918      begin
    481         Result += fields[0].Value + LineEnding;
     919        Result += (objects[num] as TSerializedValue).ValueAsString + LineEnding;
    482920      end
    483921      else
    484       if (length(fields) = 0) then
     922      if (FieldCount = 0) then
    485923      begin
    486924        Result += '{}' + LineEnding;
     
    489927      begin
    490928        Result += '{' + LineEnding;
    491         for j := 0 to High(fields) do
     929        for j := 0 to FieldCount-1 do
    492930        begin
    493           Result += tab + '  ' + fields[j].Name;
    494           if (fields[j].valueType <> '') and (fields[j].valueType <> subExpectedType) and
    495             not ((subExpectedType = '') and ((fields[j].valueType = 'Int32') or
    496             (fields[j].valueType = 'Boolean'))) then
    497             Result += ' As ' + fields[j].valueType;
     931          Result += tab + '  ' + FieldName[j];
     932          fieldTypeStr := FieldTypeAsString[j];
     933          if (fieldTypeStr <> '') and (fieldTypeStr <> subExpectedType) and
     934            not ((subExpectedType = '') and ((fieldTypeStr = 'Int32') or
     935            (fieldTypeStr = 'Boolean') or (fieldTypeStr = 'Double'))) then
     936            Result += ' As ' + fieldTypeStr;
    498937          Result   += ' = ';
    499           if not IsReferenceType(numType, j) or (copy(fields[j].Value, 1, 1) <> '#') or
    500             (fields[j].Value = '#0') then
    501             Result += fields[j].Value + lineending
     938          if not IsReferenceType(j) then
     939            Result += FieldAsString[j] + lineending
    502940          else
    503941          begin
    504             subId  := StrToInt(copy(fields[j].Value, 2, length(fields[j].Value) - 1));
    505             subNum := -1;
    506             for k := 0 to high(objects) do
    507               if (objects[k].idObject = subId) then
     942            try
     943              subId  := StrToInt64(copy(fieldAsString[j], 2, length(fieldAsString[j]) - 1));
     944              if subId = 0 then result += 'null'+LineEnding else
    508945              begin
    509                 subNum := k;
    510                 break;
     946                begin
     947                  subNum := -1;
     948                  for k := 0 to high(objects) do
     949                  if (objects[k].idObject = subId) then
     950                  begin
     951                    subNum := k;
     952                    break;
     953                  end;
     954                end;
     955                if subNum = -1 then
     956                  Result += '(Not found) #' + IntToStr(subId)+LineEnding
     957                else
     958                  Result += objectToString(subNum, fieldTypeStr, tab + '  ', False);
    511959              end;
    512             if subNum = -1 then
    513               Result += '#' + IntToStr(subId) + '!' + LineEnding
    514             else
    515               Result += objectToString(subNum, fields[j].valueType, tab + '  ', False);
     960            except
     961              result += '!' + fieldAsString[j]+'!' +LineEnding
     962            end;
    516963          end;
    517964        end;
     
    541988end;
    542989
     990destructor TDotNetDeserialization.Destroy;
     991var
     992  i: Integer;
     993begin
     994  for i := 0 to high(objects) do
     995    objects[i].Free;
     996  inherited Destroy;
     997end;
     998
     999function TDotNetDeserialization.GetTypeOfClassObject(idObject: longword
     1000  ): integer;
     1001var
     1002  i: Integer;
     1003begin
     1004  for i := 0 to high(objects) do
     1005    if objects[i].idObject = idObject then
     1006    begin
     1007      if objects[i] is TSerializedClass then
     1008      begin
     1009        result := (objects[i] as TSerializedClass).numType;
     1010        exit;
     1011      end
     1012      else
     1013        raise exception.Create('GetTypeOfClassObject: Specified object is not of class type');
     1014    end;
     1015  raise exception.Create('GetTypeOfClassObject: Object not found');
     1016end;
     1017
    5431018function TDotNetDeserialization.nextAutoObjectId: longword;
    5441019begin
     
    5521027  idRefObject, tempIdObject: longword;
    5531028  tempType:     TFieldType;
    554   arrayCount, i, idx, FillZeroCount: integer;
    555   tempObj:      TSerializedObject;
    556   tempTypeName: string;
    557   tempPObj:     PSerializedObject;
     1029  arrayCount, arrayIndex,FillZeroCount : longword;
     1030  tempAnyObj: TCustomSerializedObject;
     1031  newClassObj: TSerializedClass;
     1032  newValueObj: TSerializedValue;
     1033  newArrayObj: TSerializedArray;
     1034  genericArrayType: TGenericArrayType;
     1035  genericArrayRank: longword;
     1036  genericArrayDims: array of longword;
     1037  genericArrayItemType: TFieldType;
     1038
     1039  function GetArrayCellNumber(index: longword): string;
     1040  var r: longword;
     1041  begin
     1042    result := '';
     1043    for r := 1 to genericArrayRank do
     1044    begin
     1045      if r <> 1 then result+=',';
     1046      result += inttostr(index mod genericArrayDims[r-1]);
     1047      index := index div genericArrayDims[r-1];
     1048    end;
     1049  end;
     1050
    5581051begin
    5591052  Result := 0; //idObject or zero
    560    {$hints off}
    561   Stream.Read(blockType, sizeof(blockType));
    562    {$hints on}
     1053  blockType := WinReadByte(Stream);
    5631054  case blockType of
    5641055
     
    5681059      with assemblies[high(assemblies)] do
    5691060      begin
    570         Stream.Read(idAssembly, 4);
     1061        idAssembly := WinReadLongword(Stream);
    5711062        Name := LoadStringFromStream(Stream);
    5721063      end;
     
    5751066    btRuntimeObject, btExternalObject:
    5761067    begin
     1068      newClassObj := TSerializedClass.Create(self);
    5771069      setlength(objects, length(objects) + 1);
    578       idx := high(objects);
    579       with tempObj do  //use temp because array address may change
     1070      objects[high(objects)] := newClassObj;
     1071      with newClassObj do
    5801072      begin
    581         refCount := 0;
    582         Stream.Read(idObject, 4);
    583         Result  := idObject;
    584         numType := LoadTypeFromStream(Stream, blockType = btRuntimeObject);
    585       end;
    586       objects[idx]   := tempObj;
    587       tempObj.fields := LoadValuesFromStream(Stream, objects[idx].numType);
    588       objects[idx].fields := tempObj.fields;
     1073        idObject := WinReadLongword(Stream);
     1074        Result   := idObject;
     1075        numType  := LoadTypeFromStream(Stream, blockType = btRuntimeObject);
     1076        fields   := LoadValuesFromStream(Stream, numType);
     1077      end;
    5891078    end;
    5901079
    5911080    btRefTypeObject:
    5921081    begin
     1082      newClassObj := TSerializedClass.Create(self);
    5931083      setlength(objects, length(objects) + 1);
    594       idx := high(objects);
    595       with tempObj do  //use temp because array address may change
     1084      objects[high(objects)] := newClassObj;
     1085      with newClassObj do
    5961086      begin
    597         refCount    := 0;
    5981087        idObject    := WinReadLongword(Stream);
    5991088        Result      := idObject;
    6001089        idRefObject := WinReadLongword(Stream);
    601         numType     := GetTypeOfObject(idRefObject);
    602       end;
    603       objects[idx]   := tempObj;
    604       tempObj.fields := LoadValuesFromStream(Stream, objects[idx].numType);
    605       objects[idx].fields := tempObj.fields;
     1090        numType     := GetTypeOfClassObject(idRefObject);
     1091        fields      := LoadValuesFromStream(Stream, numType);
     1092      end;
    6061093    end;
    6071094
    6081095    btString:
    6091096    begin
     1097      tempType.primitiveType := ptString;
     1098      tempType.category := ftPrimitiveType;
     1099      tempType.Name := PrimitiveTypeName(ptString);
     1100      tempType.refAssembly := 0;
     1101
     1102      newValueObj := TSerializedValue.Create(self,tempType);
    6101103      setlength(objects, length(objects) + 1);
    611       idx := high(objects);
    612       with tempObj do  //use temp because array address may change
     1104      objects[high(objects)] := newValueObj;
     1105      with newValueObj do
    6131106      begin
    614         refCount := 0;
    615         Stream.Read(idObject, 4);
     1107        idObject := WinReadLongword(Stream);
    6161108        Result  := idObject;
    617         numType := -blockType;
    618         setlength(fields, 1);
    619         fields[0].Name      := '';
    620         fields[0].valueType := 'String';
    621         fields[0].Value     := LoadStringFromStream(Stream);
    622       end;
    623       objects[idx] := tempObj;
     1109        pstring(data)^ := LoadStringFromStream(Stream);
     1110      end;
    6241111    end;
    6251112
     
    6271114    begin
    6281115      try
     1116        tempType.category    := ftPrimitiveType;
     1117        tempType.refAssembly := 0;
     1118        tempType.primitiveType := TPrimitiveType(WinReadByte(stream));
     1119        tempType.Name := PrimitiveTypeName(tempType.primitiveType);
     1120
     1121        newValueObj := TSerializedValue.Create(self,tempType);
    6291122        setlength(objects, length(objects) + 1);
    630         idx := high(objects);
    631         with tempObj do  //use temp because array address may change
     1123        objects[high(objects)] := newValueObj;
     1124
     1125        with newValueObj do
    6321126        begin
    633           refCount := 0;
    6341127          idObject := nextAutoObjectId;
    6351128          Result   := idObject;
    636           numType  := -blockType;
    637 
    638           tempType.category    := ftPrimitiveType;
    639           tempType.refAssembly := 0;
    640           Stream.Read(tempType.primitiveType, 1);
    641           tempType.Name := PrimitiveTypeName(tempType.primitiveType);
    642 
    643           setlength(fields, 1);
    644           fields[0].Name      := '';
    645           fields[0].Value     := LoadValueFromStream(Stream, tempType);
    646           fields[0].valueType := tempType.Name;
     1129
     1130          if IsDotNetTypeStoredAsString(tempType) then
     1131            pstring(data)^ := LoadValueFromStream(Stream, tempType)
     1132          else
     1133            Stream.Read(data^, itemSize);
    6471134        end;
    648         objects[idx] := tempObj;
    6491135      except
    6501136        on ex: Exception do
     
    6561142    btObjectReference:
    6571143    begin
    658       Stream.Read(Result, 4);
    659       tempPObj := GetObject(Result);
    660       if tempPObj <> nil then
    661         Inc(tempPObj^.refCount);
     1144      result := WinReadLongword(Stream);
     1145      tempAnyObj := GetObject(Result);
     1146      if tempAnyObj <> nil then
     1147        Inc(tempAnyObj.refCount);
    6621148    end;
    6631149
     
    6671153    begin
    6681154      try
     1155        result := WinReadLongword(Stream);
     1156        arrayCount := WinReadLongword(Stream);
     1157
     1158        tempType.category    := ftPrimitiveType;
     1159        tempType.refAssembly := 0;
     1160        tempType.primitiveType := TPrimitiveType(WinReadByte(stream));
     1161        tempType.Name := PrimitiveTypeName(tempType.primitiveType);
     1162
     1163        newArrayObj := TSerializedArray.Create(self,tempType,arrayCount);
    6691164        setlength(objects, length(objects) + 1);
    670         idx := high(objects);
    671         with tempObj do  //use temp because array address may change
     1165        objects[high(objects)] := newArrayObj;
     1166        with newArrayObj do
    6721167        begin
    673           refCount := 0;
    674           Stream.Read(idObject, 4);
    675           Result     := idObject;
    676           arrayCount := WinReadLongint(Stream);
    677 
    678           tempType.category    := ftPrimitiveType;
    679           tempType.refAssembly := 0;
    680           Stream.Read(tempType.primitiveType, 1);
    681           tempType.Name := PrimitiveTypeName(tempType.primitiveType);
    682 
    683           setlength(fields, arrayCount);
    684           for i := 0 to arrayCount - 1 do
     1168          idObject := result;
     1169
     1170          if arrayCount <> 0 then
    6851171          begin
    686             fields[i].Name      := '[' + IntToStr(i) + ']';
    687             fields[i].Value     := LoadValueFromStream(Stream, tempType);
    688             fields[i].valueType := tempType.Name;
    689           end;
    690 
    691           setlength(objectTypes, length(objecttypes) + 1);
    692           numType := high(objectTypes);
    693           with objectTypes[numType] do
    694           begin
    695             ClassName := tempType.Name + '[]';
    696             nbFields  := arrayCount;
    697             setlength(fieldNames, nbFields);
    698             setlength(fieldTypes, nbFields);
    699             for i := 0 to arrayCount - 1 do
     1172            if IsDotNetTypeStoredAsString(tempType) then
    7001173            begin
    701               fieldNames[i] := fields[i].Name;
    702               fieldTypes[i] := tempType;
     1174              for arrayIndex := 0 to arrayCount - 1 do
     1175                pstring(ItemPtr[arrayIndex])^ := LoadValueFromStream(Stream, tempType);
     1176            end else
     1177            begin
     1178              for arrayIndex := 0 to arrayCount - 1 do
     1179                stream.Read(ItemPtr[arrayIndex]^, itemSize);
    7031180            end;
    704             refAssembly := 0;
    7051181          end;
    7061182        end;
    707         objects[idx] := tempObj;
    7081183      except
    7091184        on ex: Exception do
     
    7131188    end;
    7141189
    715     btArrayOfObject, btArrayOfString:
     1190    btArrayOfObject,btArrayOfString:
    7161191    begin
    7171192      try
     1193        result := WinReadLongword(Stream);
     1194        arrayCount := WinReadLongword(Stream);
     1195
     1196        if blockType = btArrayOfObject then
     1197          tempType.category := ftObjectType
     1198        else
     1199          tempType.category := ftString;
     1200
     1201        tempType.refAssembly := 0;
     1202        tempType.primitiveType := ptNone;
     1203        tempType.Name := DotNetTypeToString(tempType);
     1204
     1205        newArrayObj := TSerializedArray.Create(self,tempType,arrayCount);
    7181206        setlength(objects, length(objects) + 1);
    719         idx := high(objects);
    720         with tempObj do  //use temp because array address may change
     1207        objects[high(objects)] := newArrayObj;
     1208
     1209        with newArrayObj do
    7211210        begin
    722           refCount := 0;
    723           Stream.Read(idObject, 4);
    724           Result  := idObject;
    725           numType := -blockType;
    726           Stream.Read(arrayCount, 4);
    727         end;
    728         objects[idx] := tempObj;
    729         with tempObj do
    730         begin
    731           setlength(fields, arrayCount);
     1211          idObject:= result;
    7321212          FillZeroCount := 0;
    733           if blockType = btArrayOfObject then
    734             tempTypeName := 'Object'
    735           else
    736             tempTypeName := 'String';
    737           for i := 0 to arrayCount - 1 do
    738           begin
    739             fields[i].Name      := '[' + IntToStr(i) + ']';
    740             fields[i].valueType := tempTypeName;
    741             if FillZeroCount > 0 then
     1213          if arrayCount <> 0 then
     1214            for arrayIndex := 0 to arrayCount - 1 do
    7421215            begin
    743               fields[i].Value := '#0';
    744               Dec(FillZeroCount);
    745             end
    746             else
    747             begin
    748               tempIdObject := LoadNextFromStream(Stream);
    749               if tempIdObject = idArrayFiller then
    750               begin
    751                 tempIdObject     := 0;
    752                 FillZeroCount    := ArrayFillerCount;
    753                 ArrayFillerCount := 0;
    754               end;
    7551216              if FillZeroCount > 0 then
    756               begin
    757                 fields[i].Value := '#0';
    758                 Dec(FillZeroCount);
    759               end
     1217                Dec(FillZeroCount)
    7601218              else
    7611219              begin
    762                 fields[i].Value := '#' + IntToStr(tempIdObject);
     1220                tempIdObject := LoadNextFromStream(Stream);
     1221                if tempIdObject = idArrayFiller then
     1222                begin
     1223                  tempIdObject     := 0;
     1224                  FillZeroCount    := ArrayFillerCount;
     1225                  ArrayFillerCount := 0;
     1226                end;
     1227                if FillZeroCount > 0 then
     1228                  Dec(FillZeroCount)
     1229                else
     1230                  plongword(ItemPtr[arrayIndex])^ := tempIdObject;
    7631231              end;
    7641232            end;
    765           end;
    7661233        end;
    767         objects[idx].fields := tempObj.fields;
    7681234      except
    7691235        on ex: Exception do
     
    7771243      arrayCount := 0;
    7781244      if blockType = btArrayFiller8b then
    779       begin
    780         Stream.Read(arrayCount, 1);
    781       end
     1245        arrayCount := WinReadByte(Stream)
    7821246      else
    783         Stream.Read(arrayCount, 3);
    784       arrayCount := LEtoN(arrayCount);
     1247        arrayCount := WinReadLongWord(Stream);
    7851248      ArrayFillerCount := arraycount;
    7861249    end;
    7871250
    7881251    btGenericArray:
    789       raise Exception.Create('Generic array not supported');
     1252    begin
     1253        try
     1254          result := WinReadLongword(Stream);
     1255          genericArrayType := TGenericArrayType( WinReadByte(Stream) );
     1256          genericArrayRank := WinReadLongword(Stream);
     1257          setlength(genericArrayDims,genericArrayRank);
     1258          arrayCount := 0;
     1259          if genericArrayRank <> 0 then
     1260            for arrayIndex := 0 to genericArrayRank-1 do
     1261            begin
     1262              genericArrayDims[arrayIndex] := WinReadLongword(Stream);
     1263              if arrayIndex=0 then
     1264                arrayCount := genericArrayDims[arrayIndex]
     1265              else
     1266                arrayCount *= genericArrayDims[arrayIndex];
     1267            end;
     1268          genericArrayItemType.category := TTypeCategory(WinReadByte(Stream));
     1269          genericArrayItemType := LoadFieldType(stream,genericArrayItemType.category);
     1270
     1271          newArrayObj := TSerializedArray.Create(self,genericArrayType,genericArrayItemType,genericArrayDims);
     1272          setlength(objects, length(objects) + 1);
     1273          objects[high(objects)] := newArrayObj;
     1274          newArrayObj.idObject := result;
     1275
     1276          FillZeroCount := 0;
     1277          if arrayCount <> 0 then
     1278            for arrayIndex := 0 to arrayCount - 1 do
     1279            begin
     1280              if IsDotNetTypeStoredAsString(genericArrayItemType) then
     1281                PString(newArrayObj.ItemPtr[arrayIndex])^ := LoadValueFromStream(Stream,genericArrayItemType)
     1282              else
     1283              if genericArrayItemType.category = ftPrimitiveType then
     1284                Stream.Read(newArrayObj.ItemPtr[arrayIndex]^, newArrayObj.ItemSize)
     1285              else
     1286              begin
     1287                if FillZeroCount > 0 then
     1288                  Dec(FillZeroCount)
     1289                else
     1290                begin
     1291                  tempIdObject := LoadNextFromStream(Stream);
     1292                  if tempIdObject = idArrayFiller then
     1293                  begin
     1294                    tempIdObject     := 0;
     1295                    FillZeroCount    := ArrayFillerCount;
     1296                    ArrayFillerCount := 0;
     1297                  end;
     1298                  if FillZeroCount > 0 then
     1299                    Dec(FillZeroCount)
     1300                  else
     1301                    plongword(newArrayObj.ItemPtr[arrayIndex])^ := tempIdObject;
     1302                end;
     1303              end;
     1304            end;
     1305        except
     1306          on ex: Exception do
     1307            raise Exception.Create('Error while reading array of object. ' + ex.Message);
     1308        end;
     1309      end;
    7901310
    7911311    btMethodCall, btMethodResponse:
    792       raise Exception.Create('Method or not supported');
     1312      raise Exception.Create('Method or method response not supported');
    7931313
    7941314    btEndOfStream: EndOfStream := True;
     
    8021322var
    8031323  byteLength, shift: byte;
    804   fullLength: longword;
     1324  fullLength: integer;
    8051325  utf8value:  string;
    8061326begin
     
    8171337  if Stream.Read(utf8value[1], fullLength) <> fullLength then
    8181338    raise Exception.Create('String length error');
    819   Result := Utf8ToAnsi(utf8value);
     1339  Result := utf8value;
     1340end;
     1341
     1342function TDotNetDeserialization.LoadDotNetCharFromStream(Stream: TStream
     1343  ): string;
     1344var
     1345  tempByte: byte;
     1346  dataLen: Byte;
     1347  utf8value: string;
     1348begin
     1349  tempByte:= WinReadByte(Stream);
     1350
     1351  if tempByte and $80 = 0 then
     1352    dataLen := 1
     1353  else
     1354  if tempByte and $E0 = $C0 then
     1355    dataLen := 2
     1356  else
     1357  if tempByte and $F0 = $E0 then
     1358    dataLen := 3
     1359  else
     1360  if tempByte and $F8 = $F0 then
     1361    dataLen := 4
     1362  else
     1363    raise Exception.Create('Invalid UTF8 char');
     1364
     1365  setlength(utf8value, dataLen);
     1366  utf8value[1] := char(tempByte);
     1367  Stream.Read(utf8value[2], dataLen - 1);
     1368  Result := utf8value;
    8201369end;
    8211370
     
    8311380    begin
    8321381      ClassName := LoadStringFromStream(Stream);
    833       Stream.Read(nbFields, 4);
     1382      nbFields := WinReadLongword(Stream);
    8341383      setlength(fieldNames, nbFields);
    8351384      setlength(fieldTypes, nbFields);
     
    8371386        fieldNames[i] := LoadStringFromStream(Stream);
    8381387      for i := 0 to nbFields - 1 do
    839         Stream.Read(fieldTypes[i].category, 1);
     1388        fieldTypes[i].category := TTypeCategory(WinReadByte(Stream));
    8401389      for i := 0 to nbFields - 1 do
    841       begin
    842         fieldTypes[i].Name := '';
    843         fieldTypes[i].refAssembly := 0;
    844         fieldTypes[i].primitiveType := ptNone;
    845         case fieldTypes[i].category of
    846           ftPrimitiveType, ftArrayOfPrimitiveType:
    847           begin
    848             Stream.Read(fieldTypes[i].primitiveType, 1);
    849             fieldTypes[i].Name := PrimitiveTypeName(fieldTypes[i].primitiveType);
    850             if fieldTypes[i].category = ftArrayOfPrimitiveType then
    851               fieldTypes[i].Name += '[]';
    852           end;
    853           ftString: fieldTypes[i].Name      := 'String';
    854           ftObjectType: fieldTypes[i].Name  := 'Object';
    855           ftRuntimeType: fieldTypes[i].Name := LoadStringFromStream(Stream);
    856           ftGenericType:
    857           begin
    858             fieldTypes[i].Name := LoadStringFromStream(Stream);
    859             Stream.Read(fieldTypes[i].refAssembly, 4);
    860           end;
    861           ftArrayOfObject: fieldTypes[i].Name := 'Object[]';
    862           ftArrayOfString: fieldTypes[i].Name := 'String[]';
    863           else
    864             raise Exception.Create('Unknown field type tag (' + IntToStr(
    865               byte(fieldTypes[i].category)) + ')');
    866         end;
    867       end;
     1390        fieldTypes[i] := LoadFieldType(Stream,fieldTypes[i].category);
    8681391      if isRuntimeType then
    8691392        refAssembly := 0
    8701393      else
    871         Stream.Read(refAssembly, 4);
     1394        refAssembly := WinReadLongword(Stream);
    8721395    end;
    8731396  except
     
    9061429
    9071430function TDotNetDeserialization.LoadValueFromStream(Stream: TStream;
    908   fieldType: TFieldType): string;
    909 var
    910   utf8value:    string;
    911   utf8len:      byte;
    912   tempByte:     byte;
    913   tempDouble:   double;
    914   tempSingle:   single;
    915   tempSByte:    shortint;
    916   tempUInt64:   QWord;
     1431  const fieldType: TFieldType): string;
     1432var
     1433  data : record
     1434    case byte of
     1435    1: (ptr: pointer);
     1436    2: (bytes: array[0..7] of byte);
     1437    end;
     1438  dataLen: longword;
    9171439  tempIdObject: longword;
    9181440begin
    9191441  try
    920     case fieldType.category of
    921       ftPrimitiveType: case fieldType.primitiveType of
    922           ptBoolean:
    923           begin
    924                  {$hints off}
    925             Stream.Read(tempByte, 1);
    926                  {$hints on}
    927             if tempByte = 0 then
    928               Result := 'False'
    929             else
    930             if tempByte = 1 then
    931               Result := 'True'
    932             else
    933               raise Exception.Create('Invalid boolean value (' +
    934                 IntToStr(tempByte) + ')');
    935           end;
    936           ptByte:
    937           begin
    938                  {$hints off}
    939             Stream.Read(tempByte, 1);
    940                  {$hints on}
    941             Result := IntToStr(tempByte);
    942           end;
    943           ptChar:
    944           begin
    945                  {$hints off}
    946             Stream.Read(tempByte, 1);
    947                  {$hints on}
    948             if tempByte and $80 = 0 then
    949               utf8len := 1
    950             else
    951             if tempByte and $E0 = $C0 then
    952               utf8len := 2
    953             else
    954             if tempByte and $F0 = $E0 then
    955               utf8len := 3
    956             else
    957             if tempByte and $F8 = $F0 then
    958               utf8len := 4
    959             else
    960               raise Exception.Create('Invalid UTF8 char');
    961             setlength(utf8value, utf8len);
    962             utf8value[1] := char(tempByte);
    963             Stream.Read(utf8value[2], utf8len - 1);
    964             Result := Utf8ToAnsi(utf8value);
    965           end;
    966           ptString, ptDecimal: Result := LoadStringFromStream(Stream);
    967           ptDouble:
    968           begin
    969               {$hints off}
    970             stream.Read(tempDouble, sizeof(tempDouble));
    971               {$hints on}
    972             Result := FloatToStr(tempDouble);
    973           end;
    974           ptInt16:
    975           begin
    976             Result := IntToStr(WinReadSmallInt(stream));
    977           end;
    978           ptInt32:
    979           begin
    980             Result := IntToStr(WinReadLongInt(stream));
    981           end;
    982           ptInt64:
    983           begin
    984             Result := IntToStr(WinReadInt64(stream));
    985           end;
    986           ptSByte:
    987           begin
    988               {$hints off}
    989             stream.Read(tempSByte, sizeof(tempSByte));
    990               {$hints on}
    991             Result := IntToStr(tempSByte);
    992           end;
    993           ptSingle:
    994           begin
    995               {$hints off}
    996             stream.Read(tempSingle, sizeof(tempSingle));
    997               {$hints on}
    998             Result := FloatToStr(tempSingle);
    999           end;
    1000           ptUInt16:
    1001           begin
    1002             Result := IntToStr(WinReadWord(stream));
    1003           end;
    1004           ptUInt32:
    1005           begin
    1006             Result := IntToStr(WinReadLongword(stream));
    1007           end;
    1008           ptUInt64:
    1009           begin
    1010             Result := IntToStr(WinReadQWord(stream));
    1011           end;
    1012           ptDateTime:
    1013           begin
    1014             tempUInt64 := WinReadQWord(stream);
    1015             Result     := DateTimeToStr(
    1016               (tempUInt64 and $7FFFFFFFFFFFFFFF - 599264352000000000) / 864000000000);
    1017           end;
    1018           else
    1019             raise Exception.Create('Unknown primitive type (' + IntToStr(
    1020               byte(fieldType.primitiveType)) + ')');
     1442    if fieldType.Category = ftPrimitiveType then
     1443    begin
     1444      case fieldType.primitiveType of
     1445        ptChar: Result := LoadDotNetCharFromStream(Stream);
     1446        ptString, ptDecimal: Result := LoadStringFromStream(Stream);
     1447      else
     1448        begin
     1449          dataLen := GetFieldTypeSize(fieldType);
     1450          {$hints off}
     1451          stream.read(data,dataLen);
     1452          {$hints on}
     1453          result := DotNetValueToString(data,fieldType);
    10211454        end;
    1022       ftString, ftObjectType, ftRuntimeType, ftGenericType, ftArrayOfObject,
    1023       ftArrayOfString, ftArrayOfPrimitiveType:
    1024       begin
    1025         tempIdObject := LoadNextFromStream(stream);
    1026         Result := '#' + IntToStr(tempIdObject);
    1027 
    1028       end;
    1029       else
    1030         raise Exception.Create('Unknown field type (' + IntToStr(
    1031           byte(fieldType.category)) + ')');
    1032     end;
     1455      end;
     1456    end else
     1457    if fieldType.Category in [ftString, ftObjectType, ftRuntimeType, ftGenericType, ftArrayOfObject,
     1458        ftArrayOfString, ftArrayOfPrimitiveType] then
     1459    begin
     1460      tempIdObject := LoadNextFromStream(stream);
     1461      Result := '#' + IntToStr(tempIdObject);
     1462    end else
     1463      raise Exception.Create('Unknown field type (' + IntToStr(
     1464        byte(fieldType.category)) + ')');
    10331465  except
    10341466    on ex: Exception do
     
    10371469end;
    10381470
    1039 function TDotNetDeserialization.GetTypeOfObject(idObject: longword): integer;
    1040 var
    1041   i: integer;
    1042 begin
    1043   for i := 0 to high(objects) do
    1044     if objects[i].idObject = idObject then
    1045     begin
    1046       Result := objects[i].numType;
    1047       exit;
    1048     end;
    1049   raise Exception.Create('Object not found (' + IntToStr(idObject) + ')');
     1471function TDotNetDeserialization.LoadFieldType(Stream: TStream; category: TTypeCategory
     1472  ): TFieldType;
     1473begin
     1474  result.category := category;
     1475  result.Name := '';
     1476  result.refAssembly := 0;
     1477  result.primitiveType := ptNone;
     1478  case category of
     1479    ftPrimitiveType, ftArrayOfPrimitiveType:
     1480    begin
     1481      result.primitiveType := TPrimitiveType(WinReadByte(stream));
     1482      result.Name := PrimitiveTypeName(result.primitiveType);
     1483      if result.category = ftArrayOfPrimitiveType then
     1484        result.Name += '[]';
     1485    end;
     1486    ftString: result.Name      := 'String';
     1487    ftObjectType: result.Name  := 'Object';
     1488    ftRuntimeType: result.Name := LoadStringFromStream(Stream);
     1489    ftGenericType:
     1490    begin
     1491      result.Name := LoadStringFromStream(Stream);
     1492      result.refAssembly := WinReadLongword(Stream);
     1493    end;
     1494    ftArrayOfObject: result.Name := 'Object[]';
     1495    ftArrayOfString: result.Name := 'String[]';
     1496    else
     1497      raise Exception.Create('Unknown field type tag (' + IntToStr(
     1498        byte(result.category)) + ')');
     1499  end;
    10501500end;
    10511501
  • GraphicTest/BGRABitmap/bgrafilters.pas

    r210 r317  
    55interface
    66
     7{ Here are some filters that can be applied to a bitmap. The filters
     8  take a source image as a parameter and gives a filtered image as
     9  a result. }
     10
    711uses
    8   Classes, SysUtils, BGRADefaultBitmap, BGRABitmapTypes;
    9 
    10 function FilterMedian(bmp: TBGRADefaultBitmap;
    11   Option: TMedianOption): TBGRADefaultBitmap;
    12 function FilterSmartZoom3(bmp: TBGRADefaultBitmap;
    13   Option: TMedianOption): TBGRADefaultBitmap;
    14 function FilterSharpen(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap;
    15 function FilterBlurRadialPrecise(bmp: TBGRADefaultBitmap;
    16   radius: single): TBGRADefaultBitmap;
    17 function FilterBlurRadial(bmp: TBGRADefaultBitmap; radius: integer;
    18   blurType: TRadialBlurType): TBGRADefaultBitmap;
    19 function FilterBlurMotion(bmp: TBGRADefaultBitmap; distance: single;
    20   angle: single; oriented: boolean): TBGRADefaultBitmap;
    21 function FilterBlur(bmp: TBGRADefaultBitmap;
    22   blurMask: TBGRADefaultBitmap): TBGRADefaultBitmap;
    23 function FilterEmboss(bmp: TBGRADefaultBitmap; angle: single): TBGRADefaultBitmap;
    24 function FilterEmbossHighlight(bmp: TBGRADefaultBitmap;
    25   FillSelection: boolean): TBGRADefaultBitmap;
    26 function FilterNormalize(bmp: TBGRADefaultBitmap;
    27   eachChannel: boolean = True): TBGRADefaultBitmap;
    28 function FilterRotate(bmp: TBGRADefaultBitmap; origin: TPointF;
    29   angle: single): TBGRADefaultBitmap;
    30 function FilterGrayscale(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap;
    31 function FilterContour(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap;
    32 function FilterSphere(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap;
    33 function FilterCylinder(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap;
    34 function FilterPlane(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap;
     12  Classes, SysUtils, BGRABitmapTypes;
     13
     14{ The median filter consist in calculating the median value of pixels. Here
     15  a square of 9x9 pixel is considered. The median allow to select the most
     16  representative colors. The option parameter allow to choose to smooth the
     17  result or not. }
     18function FilterMedian(bmp: TBGRACustomBitmap;
     19  Option: TMedianOption): TBGRACustomBitmap;
     20
     21{ SmartZoom x3 is a filter that upsizes 3 times the picture and add
     22  pixels that could be logically expected (horizontal, vertical, diagonal lines) }
     23function FilterSmartZoom3(bmp: TBGRACustomBitmap;
     24  Option: TMedianOption): TBGRACustomBitmap;
     25
     26{ Sharpen filter add more contrast between pixels }
     27function FilterSharpen(bmp: TBGRACustomBitmap): TBGRACustomBitmap;
     28
     29{ A radial blur applies a blur with a circular influence, i.e, each pixel
     30  is merged with pixels within the specified radius. There is an exception
     31  with rbFast blur, the optimization entails an hyperbolic shape. }
     32function FilterBlurRadial(bmp: TBGRACustomBitmap; radius: integer;
     33  blurType: TRadialBlurType): TBGRACustomBitmap;
     34
     35{ The precise blur allow to specify the blur radius with subpixel accuracy }
     36function FilterBlurRadialPrecise(bmp: TBGRACustomBitmap;
     37  radius: single): TBGRACustomBitmap;
     38
     39{ Motion blur merge pixels in a direction. The oriented parameter specifies
     40  if the weights of the pixels are the same along the line or not. }
     41function FilterBlurMotion(bmp: TBGRACustomBitmap; distance: single;
     42  angle: single; oriented: boolean): TBGRACustomBitmap;
     43
     44function FilterPixelate(bmp: TBGRACustomBitmap; pixelSize: integer; useResample: boolean; filter: TResampleFilter = rfLinear): TBGRACustomBitmap;
     45
     46{ General purpose blur filter, with a blur mask as parameter to describe
     47  how pixels influence each other }
     48function FilterBlur(bmp: TBGRACustomBitmap;
     49  blurMask: TBGRACustomBitmap): TBGRACustomBitmap;
     50
     51{ Emboss filter compute a color difference in the angle direction }
     52function FilterEmboss(bmp: TBGRACustomBitmap; angle: single): TBGRACustomBitmap;
     53
     54{ Emboss highlight computes a sort of emboss with 45 degrees angle and
     55  with standard selection color (white/black and filled with blue) }
     56function FilterEmbossHighlight(bmp: TBGRACustomBitmap;
     57  FillSelection: boolean): TBGRACustomBitmap;
     58
     59{ Normalize use the whole available range of values, making dark colors darkest possible
     60  and light colors lightest possible }
     61function FilterNormalize(bmp: TBGRACustomBitmap;
     62  eachChannel: boolean = True): TBGRACustomBitmap;
     63
     64{ Rotate filter rotate the image and clip it in the bounding rectangle }
     65function FilterRotate(bmp: TBGRACustomBitmap; origin: TPointF;
     66  angle: single): TBGRACustomBitmap;
     67
     68{ Grayscale converts colored pixel into grayscale with same luminosity }
     69function FilterGrayscale(bmp: TBGRACustomBitmap): TBGRACustomBitmap;
     70
     71{ Compute a contour, as if the image was drawn with a 2 pixels-wide black pencil }
     72function FilterContour(bmp: TBGRACustomBitmap): TBGRACustomBitmap;
     73
     74{ Distort the image as if it were on a sphere }
     75function FilterSphere(bmp: TBGRACustomBitmap): TBGRACustomBitmap;
     76
     77{ Twirl distortion, i.e. a progressive rotation }
     78function FilterTwirl(bmp: TBGRACustomBitmap; ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap;
     79
     80{ Distort the image as if it were on a vertical cylinder }
     81function FilterCylinder(bmp: TBGRACustomBitmap): TBGRACustomBitmap;
     82
     83{ Compute a plane projection towards infinity (SLOW) }
     84function FilterPlane(bmp: TBGRACustomBitmap): TBGRACustomBitmap;
    3585
    3686implementation
    3787
    38 uses Math;
    39 
    40 function FilterSmartZoom3(bmp: TBGRADefaultBitmap;
    41   Option: TMedianOption): TBGRADefaultBitmap;
     88uses Math, GraphType, Dialogs, BGRATransform;
     89
     90function FilterSmartZoom3(bmp: TBGRACustomBitmap;
     91  Option: TMedianOption): TBGRACustomBitmap;
    4292type
    4393  TSmartDiff = record
     
    4898  xb, yb: integer;
    4999  diag1, diag2, h1, h2, v1, v2: TSmartDiff;
    50   c:      TBGRAPixel;
    51   temp, median: TBGRADefaultBitmap;
     100  c,c1,c2:      TBGRAPixel;
     101  temp, median: TBGRACustomBitmap;
    52102
    53103  function ColorDiff(c1, c2: TBGRAPixel): single;
     
    156206        if diag1.cd < 0.3 then
    157207        begin
    158           c := MergeBGRA(bmp.GetPixel(xb, yb), bmp.GetPixel(xb + 1, yb + 1));
     208          c1 := bmp.GetPixel(xb, yb);
     209          c2 := bmp.GetPixel(integer(xb + 1), integer(yb + 1));
     210          c := MergeBGRA(c1, c2);
    159211          //restore
    160212          Result.SetPixel(xb * 3 + 2, yb * 3 + 2, bmp.GetPixel(xb, yb));
    161           Result.SetPixel(xb * 3 + 3, yb * 3 + 3, bmp.GetPixel(xb + 1, yb + 1));
     213          Result.SetPixel(xb * 3 + 3, yb * 3 + 3, bmp.GetPixel(integer(xb + 1), integer(yb + 1)));
    162214
    163215          if (diag1.sd < h1.sd) and (diag1.sd < v2.sd) then
     
    173225        if diag2.cd < 0.3 then
    174226        begin
    175           c := MergeBGRA(bmp.GetPixel(xb, yb + 1), bmp.GetPixel(xb + 1, yb));
     227          c1 := bmp.GetPixel(xb, yb + 1);
     228          c2 := bmp.GetPixel(xb + 1, yb);
     229          c := MergeBGRA(c1, c2);
    176230          //restore
    177231          Result.SetPixel(xb * 3 + 3, yb * 3 + 2, bmp.GetPixel(xb + 1, yb));
     
    190244end;
    191245
    192 function FilterSharpen(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap;
     246{ This filter compute for each pixel the mean of the eight surrounding pixels,
     247  then the difference between this average pixel and the pixel at the center
     248  of the square. Finally the difference is added to the new pixel, exagerating
     249  its difference with its neighbours. }
     250function FilterSharpen(bmp: TBGRACustomBitmap): TBGRACustomBitmap;
    193251const
    194252  nbpix = 8;
     
    204262  Result := bmp.NewBitmap(bmp.Width, bmp.Height);
    205263
     264  //determine where pixels are in the bitmap
    206265  bounds := bmp.GetImageBounds;
    207266  if (bounds.Right <= bounds.Left) or (bounds.Bottom <= Bounds.Top) then
     
    212271  bounds.Bottom := min(bmp.Height, bounds.Bottom + 1);
    213272
     273  //loop through the destination bitmap
    214274  for yb := bounds.Top to bounds.Bottom - 1 do
    215275  begin
     
    217277    for xb := bounds.Left to bounds.Right - 1 do
    218278    begin
     279      //for each pixel, read eight surrounding pixels in the source bitmap
    219280      n := 0;
    220281      for dy := -1 to 1 do
     
    222283          if (dx <> 0) or (dy <> 0) then
    223284          begin
    224             a_pixels[n] := bmp.GetPixel(xb + dx, yb + dy);
     285            a_pixels[n] := bmp.GetPixel(integer(xb + dx), integer(yb + dy));
    225286            Inc(n);
    226287          end;
    227288
     289      //compute sum
    228290      sumR   := 0;
    229291      sumG   := 0;
     
    246308       {$hints on}
    247309
     310      //we finally have an average pixel
    248311      if (RGBdiv = 0) then
    249312        refPixel := BGRAPixelTransparent
     
    256319      end;
    257320
     321      //read the pixel at the center of the square
    258322      tempPixel := bmp.GetPixel(xb, yb);
    259323      if refPixel <> BGRAPixelTransparent then
    260324      begin
     325        //compute sharpened pixel by adding the difference
    261326        tempPixel.red   := max(0, min(255, tempPixel.red +
    262327          integer(tempPixel.red - refPixel.red)));
     
    275340end;
    276341
    277 function FilterBlurRadialPrecise(bmp: TBGRADefaultBitmap;
    278   radius: single): TBGRADefaultBitmap;
    279 var
    280   blurShape: TBGRADefaultBitmap;
     342{ Precise blur builds a blur mask with a gradient fill and use
     343  general purpose blur }
     344function FilterBlurRadialPrecise(bmp: TBGRACustomBitmap;
     345  radius: single): TBGRACustomBitmap;
     346var
     347  blurShape: TBGRACustomBitmap;
    281348  intRadius: integer;
    282349begin
     350  if radius = 0 then
     351  begin
     352    result := bmp.Duplicate;
     353    exit;
     354  end;
    283355  intRadius := ceil(radius);
    284   blurShape := TBGRADefaultBitmap.Create(2 * intRadius + 1, 2 * intRadius + 1);
     356  blurShape := bmp.NewBitmap(2 * intRadius + 1, 2 * intRadius + 1);
    285357  blurShape.GradientFill(0, 0, blurShape.Width, blurShape.Height, BGRAWhite,
    286358    BGRABlack, gtRadial, pointF(intRadius, intRadius), pointF(
     
    290362end;
    291363
    292 function FilterBlurRadialNormal(bmp: TBGRADefaultBitmap;
    293   radius: integer): TBGRADefaultBitmap;
    294 var
    295   blurShape: TBGRADefaultBitmap;
    296 begin
    297   blurShape := TBGRADefaultBitmap.Create(2 * radius + 1, 2 * radius + 1);
     364{ This is a clever solution for fast computing of the blur
     365  effect : it stores an array of vertical sums forming a square
     366  around the pixel which moves with it. For each new pixel,
     367  the vertical sums are kept except for the last column of
     368  the square }
     369function FilterBlurFast(bmp: TBGRACustomBitmap;
     370  radius: integer): TBGRACustomBitmap;
     371
     372  type
     373    TRowSum = record
     374      sumR,sumG,sumB,rgbDiv,sumA,aDiv: cardinal;
     375    end;
     376
     377  function ComputeAverage(sum: TRowSum): TBGRAPixel;
     378  begin
     379    result.alpha:= (sum.sumA+sum.aDiv shr 1) div sum.aDiv;
     380    result.red := (sum.sumR+sum.rgbDiv shr 1) div sum.rgbDiv;
     381    result.green := (sum.sumG+sum.rgbDiv shr 1) div sum.rgbDiv;
     382    result.blue := (sum.sumB+sum.rgbDiv shr 1) div sum.rgbDiv;
     383  end;
     384
     385  {$I blurfast.inc}
     386
     387{ Normal radial blur compute a blur mask with a GradientFill and
     388  then posterize to optimize general purpose blur }
     389function FilterBlurRadialNormal(bmp: TBGRACustomBitmap;
     390  radius: integer): TBGRACustomBitmap;
     391var
     392  blurShape: TBGRACustomBitmap;
     393  n: Integer;
     394  p: PBGRAPixel;
     395begin
     396  blurShape := bmp.NewBitmap(2 * radius + 1, 2 * radius + 1);
    298397  blurShape.GradientFill(0, 0, blurShape.Width, blurShape.Height, BGRAWhite,
    299398    BGRABlack, gtRadial, pointF(radius, radius), pointF(-0.5, radius), dmSet);
     399  p := blurShape.Data;
     400  for n := 0 to blurShape.NbPixels-1 do
     401  begin
     402    p^.red := p^.red and $F0;
     403    p^.green := p^.red;
     404    p^.blue := p^.red;
     405    inc(p);
     406  end;
    300407  Result := FilterBlur(bmp, blurShape);
    301408  blurShape.Free;
    302409end;
    303410
    304 function FilterBlurDisk(bmp: TBGRADefaultBitmap; radius: integer): TBGRADefaultBitmap;
    305 var
    306   blurShape: TBGRADefaultBitmap;
    307 begin
    308   blurShape := TBGRADefaultBitmap.Create(2 * radius + 1, 2 * radius + 1);
     411{ Blur disk creates a disk mask with a FillEllipse }
     412function FilterBlurDisk(bmp: TBGRACustomBitmap; radius: integer): TBGRACustomBitmap;
     413var
     414  blurShape: TBGRACustomBitmap;
     415begin
     416  blurShape := bmp.NewBitmap(2 * radius + 1, 2 * radius + 1);
    309417  blurShape.Fill(BGRABlack);
    310418  blurShape.FillEllipseAntialias(radius, radius, radius + 0.5, radius + 0.5, BGRAWhite);
     
    313421end;
    314422
    315 function FilterBlurCorona(bmp: TBGRADefaultBitmap; radius: integer): TBGRADefaultBitmap;
    316 var
    317   blurShape: TBGRADefaultBitmap;
    318 begin
    319   blurShape := TBGRADefaultBitmap.Create(2 * radius + 1, 2 * radius + 1);
     423{ Corona blur use a circle as mask }
     424function FilterBlurCorona(bmp: TBGRACustomBitmap; radius: integer): TBGRACustomBitmap;
     425var
     426  blurShape: TBGRACustomBitmap;
     427begin
     428  blurShape := bmp.NewBitmap(2 * radius + 1, 2 * radius + 1);
    320429  blurShape.Fill(BGRABlack);
    321430  blurShape.EllipseAntialias(radius, radius, radius, radius, BGRAWhite, 1);
     
    324433end;
    325434
    326 function FilterBlurRadial(bmp: TBGRADefaultBitmap; radius: integer;
    327   blurType: TRadialBlurType): TBGRADefaultBitmap;
    328 begin
     435function FilterBlurRadial(bmp: TBGRACustomBitmap; radius: integer;
     436  blurType: TRadialBlurType): TBGRACustomBitmap;
     437begin
     438  if radius = 0 then
     439  begin
     440    result := bmp.Duplicate;
     441    exit;
     442  end;
    329443  case blurType of
    330444    rbCorona: Result  := FilterBlurCorona(bmp, radius);
    331445    rbDisk: Result    := FilterBlurDisk(bmp, radius);
    332446    rbNormal: Result  := FilterBlurRadialNormal(bmp, radius);
     447    rbFast: Result  := FilterBlurFast(bmp, radius);
    333448    rbPrecise: Result := FilterBlurRadialPrecise(bmp, radius / 10);
    334449    else
     
    337452end;
    338453
    339 function FilterBlurMotion(bmp: TBGRADefaultBitmap; distance: single;
    340   angle: single; oriented: boolean): TBGRADefaultBitmap;
    341 var
    342   blurShape: TBGRADefaultBitmap;
     454{ This filter draws an antialiased line to make the mask, and
     455  if the motion blur is oriented, does a GradientFill to orient it }
     456function FilterBlurMotion(bmp: TBGRACustomBitmap; distance: single;
     457  angle: single; oriented: boolean): TBGRACustomBitmap;
     458var
     459  blurShape: TBGRACustomBitmap;
    343460  intRadius: integer;
    344461  dx, dy, d: single;
    345462begin
     463  if distance = 0 then
     464  begin
     465    result := bmp.Duplicate;
     466    exit;
     467  end;
    346468  intRadius := ceil(distance / 2);
    347   blurShape := TBGRADefaultBitmap.Create(2 * intRadius + 1, 2 * intRadius + 1);
     469  blurShape := bmp.NewBitmap(2 * intRadius + 1, 2 * intRadius + 1);
    348470  d  := distance / 2;
    349471  dx := cos(angle * Pi / 180);
     
    362484end;
    363485
    364 function FilterBlur(bmp: TBGRADefaultBitmap;
    365   blurMask: TBGRADefaultBitmap): TBGRADefaultBitmap;
    366 var
    367   yb, xb:      integer;
    368   dx, dy, mindx, maxdx, mindy, maxdy, n, j: integer;
    369   a_pixels:    array of TBGRAPixel;
    370   weights:     array of integer;
    371   sumR, sumG, sumB, sumA, Adiv, RGBdiv: cardinal;
    372   RGBweight:   byte;
    373   tempPixel, refPixel: TBGRAPixel;
    374   shapeMatrix: array of array of byte;
    375   pdest, psrc: PBGRAPixel;
    376   blurOfs:     TPoint;
    377   bounds:      TRect;
    378 begin
    379   blurOfs := point(blurMask.Width shr 1, blurMask.Height shr 1);
    380 
    381   setlength(shapeMatrix, blurMask.Width, blurMask.Height);
    382   n := 0;
    383   for yb := 0 to blurMask.Height - 1 do
    384     for xb := 0 to blurMask.Width - 1 do
    385     begin
    386       shapeMatrix[yb, xb] := blurMask.GetPixel(xb, yb).red;
    387       if shapeMatrix[yb, xb] <> 0 then
    388         Inc(n);
    389     end;
    390 
    391   setlength(a_pixels, n);
    392   setlength(weights, n);
    393 
    394   Result := bmp.NewBitmap(bmp.Width, bmp.Height);
    395   bounds := bmp.GetImageBounds;
    396   if (bounds.Right <= bounds.Left) or (bounds.Bottom <= Bounds.Top) then
     486{ General purpose blur : compute pixel sum according to the mask and then
     487  compute only difference while scanning from the left to the right }
     488function FilterBlurSmallMask(bmp: TBGRACustomBitmap;
     489  blurMask: TBGRACustomBitmap): TBGRACustomBitmap; forward;
     490function FilterBlurSmallMaskWithShift(bmp: TBGRACustomBitmap;
     491  blurMask: TBGRACustomBitmap; maskShift: integer): TBGRACustomBitmap; forward;
     492function FilterBlurBigMask(bmp: TBGRACustomBitmap;
     493  blurMask: TBGRACustomBitmap): TBGRACustomBitmap; forward;
     494
     495//make sure value is in the range 0..255
     496function clampByte(value: integer): byte; inline;
     497begin
     498  if value < 0 then result := 0 else
     499  if value > 255 then result := 255 else
     500    result := value;
     501end;
     502
     503function FilterPixelate(bmp: TBGRACustomBitmap; pixelSize: integer;
     504  useResample: boolean; filter: TResampleFilter): TBGRACustomBitmap;
     505var yb,xb, xs,ys, tx,ty: integer;
     506    psrc,pdest: PBGRAPixel;
     507    temp,stretched: TBGRACustomBitmap;
     508    oldfilter: TResampleFilter;
     509begin
     510  if pixelSize < 1 then
     511  begin
     512    result := bmp.Duplicate;
    397513    exit;
    398   bounds.Left   := max(0, bounds.Left - blurOfs.X);
    399   bounds.Top    := max(0, bounds.Top - blurOfs.Y);
    400   bounds.Right  := min(bmp.Width, bounds.Right + blurMask.Width - 1 - blurOfs.X);
    401   bounds.Bottom := min(bmp.Height, bounds.Bottom + blurMask.Height - 1 - blurOfs.Y);
    402 
    403   for yb := bounds.Top to bounds.Bottom - 1 do
    404   begin
    405     pdest := Result.ScanLine[yb] + bounds.Left;
    406     for xb := bounds.Left to Bounds.Right - 1 do
    407     begin
    408       n     := 0;
    409       mindx := max(-blurOfs.X, -xb);
    410       mindy := max(-blurOfs.Y, -yb);
    411       maxdx := min(blurMask.Width - 1 - blurOfs.X, bmp.Width - 1 - xb);
    412       maxdy := min(blurMask.Height - 1 - blurOfs.Y, bmp.Height - 1 - yb);
    413       for dy := mindy to maxdy do
    414       begin
    415         psrc := bmp.scanline[yb + dy] + (xb + mindx);
    416         for dx := mindx to maxdx do
    417         begin
    418           j := shapeMatrix[dy + blurOfs.Y, dx + blurOfs.X];
    419           if j <> 0 then
    420           begin
    421             a_pixels[n] := psrc^;
    422             weights[n]  := (a_pixels[n].alpha * j + 127) shr 8;
    423             Inc(n);
    424           end;
    425           Inc(psrc);
    426         end;
     514  end;
     515  result := bmp.NewBitmap(bmp.Width,bmp.Height);
     516
     517  tx := (bmp.Width+pixelSize-1) div pixelSize;
     518  ty := (bmp.Height+pixelSize-1) div pixelSize;
     519  if not useResample then
     520  begin
     521    temp := bmp.NewBitmap(tx,ty);
     522
     523    xs := (bmp.Width mod pixelSize) div 2;
     524    ys := (bmp.Height mod pixelSize) div 2;
     525
     526    for yb := 0 to temp.height-1 do
     527    begin
     528      pdest := temp.ScanLine[yb];
     529      psrc := bmp.scanline[ys]+xs;
     530      inc(ys,pixelSize);
     531      for xb := 0 to temp.width-1 do
     532      begin
     533        pdest^ := psrc^;
     534        inc(pdest);
     535        inc(psrc,pixelSize);
    427536      end;
    428       sumR   := 0;
    429       sumG   := 0;
    430       sumB   := 0;
    431       sumA   := 0;
    432       Adiv   := 0;
    433       RGBdiv := 0;
    434 
    435        {$hints off}
    436       for j := 0 to n - 1 do
    437       begin
    438         tempPixel := a_pixels[j];
    439         RGBweight := (weights[j] * tempPixel.alpha + 128) div 255;
    440         sumR      += tempPixel.red * RGBweight;
    441         sumG      += tempPixel.green * RGBweight;
    442         sumB      += tempPixel.blue * RGBweight;
    443         RGBdiv    += RGBweight;
    444         sumA      += tempPixel.alpha;
    445         Adiv      += 1;
    446       end;
    447        {$hints on}
    448 
    449       if (Adiv = 0) or (RGBdiv = 0) then
    450         refPixel := BGRAPixelTransparent
    451       else
    452       begin
    453         refPixel.alpha := (sumA + Adiv shr 1) div Adiv;
    454         if refPixel.alpha = 0 then
    455           refPixel := BGRAPixelTransparent
    456         else
    457         begin
    458           refPixel.red   := (sumR + RGBdiv shr 1) div RGBdiv;
    459           refPixel.green := (sumG + RGBdiv shr 1) div RGBdiv;
    460           refPixel.blue  := (sumB + RGBdiv shr 1) div RGBdiv;
    461         end;
    462       end;
    463 
    464       pdest^ := refPixel;
    465       Inc(pdest);
    466     end;
    467   end;
    468   Result.InvalidateBitmap;
    469 end;
    470 
    471 function FilterEmboss(bmp: TBGRADefaultBitmap; angle: single): TBGRADefaultBitmap;
     537    end;
     538    temp.InvalidateBitmap;
     539  end else
     540  begin
     541    oldfilter := bmp.ResampleFilter;
     542    bmp.ResampleFilter := filter;
     543    temp := bmp.Resample(tx,ty,rmFineResample);
     544    bmp.ResampleFilter := oldfilter;
     545  end;
     546  stretched := temp.Resample(temp.Width*pixelSize,temp.Height*pixelSize,rmSimpleStretch);
     547  temp.free;
     548  if bmp.Width mod pixelSize = 0 then
     549    xs := 0
     550  else
     551    xs := (-pixelSize+(bmp.Width mod pixelSize)) div 2;
     552  if bmp.Height mod pixelSize = 0 then
     553    ys := 0
     554  else
     555    ys := (-pixelSize+(bmp.Height mod pixelSize)) div 2;
     556  result.PutImage(xs,ys,stretched,dmSet);
     557  stretched.Free;
     558end;
     559
     560function FilterBlur(bmp: TBGRACustomBitmap;
     561  blurMask: TBGRACustomBitmap): TBGRACustomBitmap;
     562var
     563  maskSum: int64;
     564  i: Integer;
     565  p: PBGRAPixel;
     566  maskShift: integer;
     567begin
     568  maskSum := 0;
     569  p := blurMask.data;
     570  for i := 0 to blurMask.NbPixels-1 do
     571  begin
     572    inc(maskSum,p^.red);
     573    inc(p);
     574  end;
     575  maskShift := 0;
     576  while maskSum > 32768 do
     577  begin
     578    inc(maskShift);
     579    maskSum := maskSum shr 1;
     580  end;
     581  //check if sum can be stored in a 32-bit signed integer
     582  if maskShift = 0 then
     583    result := FilterBlurSmallMask(bmp,blurMask) else
     584  if maskShift < 8 then
     585    result := FilterBlurSmallMaskWithShift(bmp,blurMask,maskShift) else
     586    result := FilterBlurBigMask(bmp,blurMask);
     587end;
     588
     589//32-bit blur with shift
     590function FilterBlurSmallMaskWithShift(bmp: TBGRACustomBitmap;
     591  blurMask: TBGRACustomBitmap; maskShift: integer): TBGRACustomBitmap;
     592
     593  var
     594    sumR, sumG, sumB, sumA, Adiv, RGBdiv : integer;
     595
     596  function ComputeAverage: TBGRAPixel; inline;
     597  begin
     598    result.alpha := (sumA + Adiv shr 1) div Adiv;
     599    if result.alpha = 0 then
     600      result := BGRAPixelTransparent
     601    else
     602    begin
     603      result.red   := clampByte((sumR + RGBdiv shr 1) div RGBdiv);
     604      result.green := clampByte((sumG + RGBdiv shr 1) div RGBdiv);
     605      result.blue  := clampByte((sumB + RGBdiv shr 1) div RGBdiv);
     606    end;
     607  end;
     608
     609  {$define PARAM_MASKSHIFT}
     610  {$I blurnormal.inc}
     611
     612//32-bit blur
     613function FilterBlurSmallMask(bmp: TBGRACustomBitmap;
     614  blurMask: TBGRACustomBitmap): TBGRACustomBitmap;
     615
     616  var
     617    sumR, sumG, sumB, sumA, Adiv : integer;
     618
     619  function ComputeAverage: TBGRAPixel; inline;
     620  begin
     621    result.alpha := (sumA + Adiv shr 1) div Adiv;
     622    if result.alpha = 0 then
     623      result := BGRAPixelTransparent
     624    else
     625    begin
     626      result.red   := clampByte((sumR + sumA shr 1) div sumA);
     627      result.green := clampByte((sumG + sumA shr 1) div sumA);
     628      result.blue  := clampByte((sumB + sumA shr 1) div sumA);
     629    end;
     630  end;
     631
     632  {$I blurnormal.inc}
     633
     634//floating point blur
     635function FilterBlurBigMask(bmp: TBGRACustomBitmap;
     636  blurMask: TBGRACustomBitmap): TBGRACustomBitmap;
     637
     638  var
     639    sumR, sumG, sumB, sumA, Adiv : single;
     640
     641  function ComputeAverage: TBGRAPixel; inline;
     642  begin
     643    result.alpha := round(sumA/Adiv);
     644    if result.alpha = 0 then
     645      result := BGRAPixelTransparent
     646    else
     647    begin
     648      result.red   := clampByte(round(sumR/sumA));
     649      result.green := clampByte(round(sumG/sumA));
     650      result.blue  := clampByte(round(sumB/sumA));
     651    end;
     652  end;
     653
     654  {$I blurnormal.inc}
     655
     656{ Emboss filter computes the difference between each pixel and the surrounding pixels
     657  in the specified direction. }
     658function FilterEmboss(bmp: TBGRACustomBitmap; angle: single): TBGRACustomBitmap;
    472659var
    473660  yb, xb: integer;
     
    475662  idx1, idy1, idx2, idy2, idx3, idy3, idx4, idy4: integer;
    476663  w:      array[1..4] of single;
    477   iw:     integer;
     664  iw:     cardinal;
    478665  c:      array[0..4] of TBGRAPixel;
    479666
     
    485672  bounds: TRect;
    486673begin
     674  //compute pixel position and weight
    487675  dx   := cos(angle * Pi / 180);
    488676  dy   := sin(angle * Pi / 180);
     
    501689  w[4] := (1 - abs(idx4 - dx)) * (1 - abs(idy4 - dy));
    502690
     691  //fill with gray
    503692  Result := bmp.NewBitmap(bmp.Width, bmp.Height);
    504693  Result.Fill(BGRA(128, 128, 128, 255));
     
    512701  bounds.Bottom := min(bmp.Height, bounds.Bottom + 1);
    513702
     703  //loop through destination
    514704  for yb := bounds.Top to bounds.bottom - 1 do
    515705  begin
     
    518708    begin
    519709      c[0] := bmp.getPixel(xb, yb);
    520       c[1] := bmp.getPixel(xb + idx1, yb + idy1);
    521       c[2] := bmp.getPixel(xb + idx2, yb + idy2);
    522       c[3] := bmp.getPixel(xb + idx3, yb + idy3);
    523       c[4] := bmp.getPixel(xb + idx4, yb + idy4);
     710      c[1] := bmp.getPixel(integer(xb + idx1), integer(yb + idy1));
     711      c[2] := bmp.getPixel(integer(xb + idx2), integer(yb + idy2));
     712      c[3] := bmp.getPixel(integer(xb + idx3), integer(yb + idy3));
     713      c[4] := bmp.getPixel(integer(xb + idx4), integer(yb + idy4));
    524714
    525715      sumR   := 0;
     
    530720      RGBdiv := 0;
    531721
     722      //compute sum
    532723       {$hints off}
    533724      for i := 1 to 4 do
     
    546737       {$hints on}
    547738
     739      //average
    548740      if (Adiv = 0) or (RGBdiv = 0) then
    549741        refPixel := c[0]
     
    555747        refPixel.alpha := (sumA * 255 + Adiv shr 1) div Adiv;
    556748      end;
     749
     750      //difference with center pixel
    557751       {$hints off}
    558752      tempPixel.red := max(0, min(512 * 255, 65536 + refPixel.red *
     
    571765end;
    572766
    573 function FilterEmbossHighlight(bmp: TBGRADefaultBitmap;
    574   FillSelection: boolean): TBGRADefaultBitmap;
     767{ Like general emboss, but with fixed direction and automatic color with transparency }
     768function FilterEmbossHighlight(bmp: TBGRACustomBitmap;
     769  FillSelection: boolean): TBGRACustomBitmap;
    575770var
    576771  yb, xb: integer;
     
    710905end;
    711906
    712 function FilterNormalize(bmp: TBGRADefaultBitmap;
    713   eachChannel: boolean = True): TBGRADefaultBitmap;
     907{ Normalize compute min-max of specified channel and apply an affine transformation
     908  to make it use the full range of values }
     909function FilterNormalize(bmp: TBGRACustomBitmap;
     910  eachChannel: boolean = True): TBGRACustomBitmap;
    714911var
    715912  psrc, pdest: PBGRAPixel;
     
    8311028end;
    8321029
    833 function FilterRotate(bmp: TBGRADefaultBitmap; origin: TPointF;
    834   angle: single): TBGRADefaultBitmap;
     1030{ Rotates the image. To do this, loop through the destination and
     1031  calculates the position in the source bitmap with an affine transformation }
     1032function FilterRotate(bmp: TBGRACustomBitmap; origin: TPointF;
     1033  angle: single): TBGRACustomBitmap;
    8351034var
    8361035  bounds:     TRect;
     
    9261125end;
    9271126
    928 function FilterGrayscale(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap;
     1127{ Filter grayscale applies BGRAToGrayscale function to all pixels }
     1128function FilterGrayscale(bmp: TBGRACustomBitmap): TBGRACustomBitmap;
    9291129var
    9301130  bounds:      TRect;
     
    9521152end;
    9531153
    954 function FilterContour(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap;
     1154{ Filter contour compute a grayscale image, then for each pixel
     1155  calculates the difference with surrounding pixels (in intensity and alpha)
     1156  and draw black pixels when there is a difference }
     1157function FilterContour(bmp: TBGRACustomBitmap): TBGRACustomBitmap;
    9551158var
    9561159  yb, xb: integer;
     
    9641167
    9651168  bounds: TRect;
    966   gray:   TBGRADefaultBitmap;
     1169  gray:   TBGRACustomBitmap;
    9671170begin
    9681171  bmpWidth  := bmp.Width;
     
    10661269end;
    10671270
    1068 function FilterSphere(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap;
     1271{ Compute the distance for each pixel to the center of the bitmap,
     1272  calculate the corresponding angle with arcsin, use this angle
     1273  to determine a distance from the center in the source bitmap }
     1274function FilterSphere(bmp: TBGRACustomBitmap): TBGRACustomBitmap;
    10691275var
    10701276  cx, cy, x, y, len, fact: single;
    10711277  xb, yb: integer;
    1072   mask:   TBGRADefaultBitmap;
     1278  mask:   TBGRACustomBitmap;
    10731279begin
    10741280  Result := bmp.NewBitmap(bmp.Width, bmp.Height);
     
    10991305end;
    11001306
    1101 function FilterCylinder(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap;
     1307{ Applies twirl scanner. See TBGRATwirlScanner }
     1308function FilterTwirl(bmp: TBGRACustomBitmap; ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap;
     1309var twirl: TBGRATwirlScanner;
     1310begin
     1311  twirl := TBGRATwirlScanner.Create(bmp,ACenter,ARadius,ATurn,AExponent);
     1312  Result := bmp.NewBitmap(bmp.Width, bmp.Height);
     1313  result.Fill(twirl);
     1314  twirl.free;
     1315end;
     1316
     1317{ Compute the distance for each pixel to the vertical axis of the bitmap,
     1318  calculate the corresponding angle with arcsin, use this angle
     1319  to determine a distance from the vertical axis in the source bitmap }
     1320function FilterCylinder(bmp: TBGRACustomBitmap): TBGRACustomBitmap;
    11021321var
    11031322  cx, cy, x, y, len, fact: single;
     
    11251344end;
    11261345
    1127 function FilterPlane(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap;
     1346function FilterPlane(bmp: TBGRACustomBitmap): TBGRACustomBitmap;
    11281347const resampleGap=0.6;
    11291348var
    11301349  cy, x1, x2, y1, y2, z1, z2, h: single;
    11311350  yb: integer;
    1132   resampledBmp: TBGRADefaultBitmap;
     1351  resampledBmp: TBGRACustomBitmap;
    11331352  resampledBmpWidth: integer;
    11341353  resampledFactor,newResampleFactor: single;
    1135   sub,resampledSub: TBGRADefaultBitmap;
     1354  sub,resampledSub: TBGRACustomBitmap;
    11361355  partRect: TRect;
    11371356  resampleSizeY : integer;
     
    11911410end;
    11921411
    1193 function FilterMedian(bmp: TBGRADefaultBitmap;
    1194   Option: TMedianOption): TBGRADefaultBitmap;
     1412{ For each component, sort values to get the median }
     1413function FilterMedian(bmp: TBGRACustomBitmap;
     1414  Option: TMedianOption): TBGRACustomBitmap;
    11951415
    11961416  function ComparePixLt(p1, p2: TBGRAPixel): boolean;
     
    12361456        for dx := -1 to 1 do
    12371457        begin
    1238           a_pixels[n] := bmp.GetPixel(xb + dx, yb + dy);
     1458          a_pixels[n] := bmp.GetPixel(integer(xb + dx), integer(yb + dy));
    12391459          if a_pixels[n].alpha = 0 then
    12401460            a_pixels[n] := BGRAPixelTransparent;
  • GraphicTest/BGRABitmap/bgragtkbitmap.pas

    r210 r317  
    3737  private
    3838    FPixBuf: Pointer;
    39     procedure SlowDrawTransparent(ABitmap: TBGRADefaultBitmap;
    40       ACanvas: TCanvas; ARect: TRect);
     39{    procedure SlowDrawTransparent(ABitmap: TBGRADefaultBitmap;
     40      ACanvas: TCanvas; ARect: TRect);}
     41    procedure DrawTransparent(ACanvas: TCanvas; Rect: TRect);
     42    procedure DrawOpaque(ACanvas: TCanvas; Rect: TRect);
    4143  protected
    4244    procedure ReallocData; override;
    4345    procedure FreeData; override;
    44     procedure DrawOpaque(ACanvas: TCanvas; Rect: TRect);
    4546  public
    4647    procedure DataDrawTransparent(ACanvas: TCanvas; Rect: TRect;
     
    5051    procedure Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean = True); override;
    5152    procedure DataDrawOpaque(ACanvas: TCanvas; Rect: TRect; AData: Pointer;
    52       ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
    53       override;
     53      ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); override;
    5454    procedure GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer); override;
    5555  end;
     
    7171{$ENDIF}
    7272
    73 procedure TBGRAGtkBitmap.SlowDrawTransparent(ABitmap: TBGRADefaultBitmap;
     73{procedure TBGRAGtkBitmap.SlowDrawTransparent(ABitmap: TBGRADefaultBitmap;
    7474  ACanvas: TCanvas; ARect: TRect);
    7575var
    76   background, temp: TBGRADefaultBitmap;
     76  background, temp: TBGRACustomBitmap;
    7777  w, h: integer;
    7878
     
    9292  background.Draw(ACanvas, ARect.Left, ARect.Top, True);
    9393  background.Free;
    94 end;
     94end;}
    9595
    9696procedure TBGRAGtkBitmap.ReallocData;
    9797begin
     98  {$IFDEF LCLgtk2}
     99  If FPixBuf <> nil then g_object_unref(FPixBuf);
     100  {$ELSE}
     101  If FPixBuf <> nil then gdk_pixbuf_unref(FPixBuf);
     102  {$ENDIF}
     103  FPixBuf := nil; 
    98104  inherited ReallocData;
    99   FPixbuf := gdk_pixbuf_new_from_data(pguchar(FData),
    100     GDK_COLORSPACE_RGB, True, 8, Width, Height, Width*Sizeof(TBGRAPixel), nil, nil);
    101   if FPixbuf = nil then
    102     raise Exception.Create('Error initializing Pixbuf');
     105  if (FWidth <> 0) and (FHeight <> 0) then
     106  begin 
     107    FPixbuf := gdk_pixbuf_new_from_data(pguchar(FData),
     108      GDK_COLORSPACE_RGB, True, 8, Width, Height, Width*Sizeof(TBGRAPixel), nil, nil);
     109    if FPixbuf = nil then
     110      raise Exception.Create('Error initializing Pixbuf');
     111  end;
    103112end;
    104113
     
    114123end;
    115124
    116 procedure TBGRAGtkBitmap.DrawOpaque(ACanvas: TCanvas; Rect: TRect);
     125procedure TBGRAGtkBitmap.DrawTransparent(ACanvas: TCanvas; Rect: TRect);
    117126var DrawWidth,DrawHeight: integer;
    118127    stretched: TBGRAGtkBitmap;
     
    126135  begin
    127136    stretched := Resample(DrawWidth,DrawHeight,rmSimpleStretch) as TBGRAGtkBitmap;
    128     stretched.DrawOpaque(ACanvas,Rect);
     137    stretched.DrawTransparent(ACanvas,Rect);
    129138    stretched.Free;
    130139    exit;
    131140  end;
    132141
    133   //SwapRedBlue;
     142  SwapRedBlue;
    134143  gdk_pixbuf_render_to_drawable(FPixBuf,
    135144    TGtkDeviceContext(ACanvas.Handle).Drawable,
     
    140149    Width,Height,
    141150    GDK_RGB_DITHER_NORMAL,0,0);
    142   //SwapRedBlue;
     151  SwapRedBlue;
     152end;
     153
     154procedure TBGRAGtkBitmap.DrawOpaque(ACanvas: TCanvas; Rect: TRect);
     155begin
     156  DataDrawOpaque(ACanvas,Rect,Data,LineOrder,Width,Height);
    143157end;
    144158
     
    146160  AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
    147161var
    148   Temp: TBGRAPtrBitmap;
    149 begin
    150   Temp := TBGRAPtrBitmap.Create(AWidth, AHeight, AData);
    151   Temp.LineOrder := ALineOrder;
    152   SlowDrawTransparent(Temp, ACanvas, Rect);
    153   Temp.Free;
     162  TempGtk: TBGRAGtkBitmap;
     163  temp: integer;
     164begin
     165  if (AHeight = 0) or (AWidth = 0) or (Rect.Left = Rect.Right) or
     166    (Rect.Top = Rect.Bottom) then
     167    exit;
     168
     169  if Rect.Right < Rect.Left then
     170  begin
     171    temp := Rect.Left;
     172    Rect.Left := Rect.Right;
     173    Rect.Right := temp;
     174  end;
     175
     176  if Rect.Bottom < Rect.Top then
     177  begin
     178    temp := Rect.Top;
     179    Rect.Top := Rect.Bottom;
     180    Rect.Bottom := temp;
     181  end;
     182
     183  TempGtk := TBGRAGtkBitmap.Create(AWidth, AHeight);
     184  Move(AData^,TempGtk.Data^,TempGtk.NbPixels*sizeof(TBGRAPixel));
     185  if ALineOrder <> TempGtk.LineOrder then TempGtk.VerticalFlip;
     186  TempGtk.DrawTransparent(ACanvas,Rect);
     187  TempGtk.Free;
    154188end;
    155189
     
    161195    DrawOpaque(ACanvas, Rect(X, Y, X + Width, Y + Height))
    162196  else
    163     SlowDrawTransparent(Self, ACanvas, Rect(X, Y, X + Width, Y + Height));
     197    DrawTransparent(ACanvas, Rect(X, Y, X + Width, Y + Height));
    164198end;
    165199
     
    171205    DrawOpaque(ACanvas, Rect)
    172206  else
    173     SlowDrawTransparent(Self, ACanvas, Rect);
     207    DrawTransparent(ACanvas, Rect);
    174208end;
    175209
    176210procedure TBGRAGtkBitmap.DataDrawOpaque(ACanvas: TCanvas; Rect: TRect;
    177211  AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
    178 var stretched: TBGRADefaultBitmap;
    179 begin
    180   if (AHeight = 0) or (AWidth = 0) then
    181     exit;
    182 
    183   if (AWidth <> Width) or (AHeight <> Height) then
    184   begin
    185     stretched := Resample(AWidth,AHeight,rmSimpleStretch);
    186     stretched.DataDrawOpaque(ACanvas,Rect,AData,stretched.LineOrder,AWidth,AHeight)
    187   end;
    188 
     212var ptr: TBGRAPtrBitmap;
     213    stretched: TBGRACustomBitmap;
     214    temp: integer;
     215    pos: TPoint;
     216    dest: HDC;
     217begin
     218  if (AHeight = 0) or (AWidth = 0) or (Rect.Left = Rect.Right) or
     219    (Rect.Top = Rect.Bottom) then
     220    exit;
     221
     222  if Rect.Right < Rect.Left then
     223  begin
     224    temp := Rect.Left;
     225    Rect.Left := Rect.Right;
     226    Rect.Right := temp;
     227  end;
     228
     229  if Rect.Bottom < Rect.Top then
     230  begin
     231    temp := Rect.Top;
     232    Rect.Top := Rect.Bottom;
     233    Rect.Bottom := temp;
     234  end;
     235
     236  if (AWidth <> Rect.Right-Rect.Left) or (AHeight <> Rect.Bottom-Rect.Top) then
     237  begin
     238    ptr := TBGRAPtrBitmap.Create(AWidth,AHeight,AData);
     239    ptr.LineOrder := ALineOrder;
     240    stretched := ptr.Resample(Rect.Right-Rect.Left,Rect.Bottom-Rect.Top);
     241    ptr.free;
     242    DataDrawOpaque(ACanvas,Rect,AData,stretched.LineOrder,stretched.Width,stretched.Height);
     243    stretched.Free;
     244    exit;
     245  end;
     246
     247  dest := ACanvas.Handle;
     248  pos := TGtkDeviceContext(dest).Offset;
     249  pos.X += rect.Left;
     250  pos.Y += rect.Top;
    189251  If ALineOrder = riloBottomToTop then VerticalFlip;
    190252  SwapRedBlue;
    191   gdk_pixbuf_render_to_drawable(FPixBuf,
    192     TGtkDeviceContext(ACanvas.Handle).Drawable,
    193     TGtkDeviceContext(ACanvas.Handle).GC,
    194     0,0,Rect.Left,Rect.Top,AWidth,AHeight,
    195     GDK_RGB_DITHER_NORMAL,0,0);
     253  gdk_draw_rgb_32_image(TGtkDeviceContext(dest).Drawable,
     254    TGtkDeviceContext(Dest).GC, pos.X,pos.Y,
     255    AWidth,AHeight, GDK_RGB_DITHER_NORMAL,
     256    AData, AWidth*sizeof(TBGRAPixel));
    196257  SwapRedBlue;
    197258  If ALineOrder = riloBottomToTop then VerticalFlip;
     
    200261procedure TBGRAGtkBitmap.GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer);
    201262var
    202   subBmp: TBGRADefaultBitmap;
     263  subBmp: TBGRACustomBitmap;
    203264  subRect: TRect;
    204265  cw,ch: integer;
     
    240301end.
    241302
     303
  • GraphicTest/BGRABitmap/bgrapaintnet.pas

    r210 r317  
    55interface
    66
     7{ This unit reads Paint.NET files. It needs BGRADNetDeserial to deserialize binary .Net objects.
     8
     9  A Paint.NET image consists in three parts :
     10  - Xml header
     11  - Binary serialized information (contains layer information)
     12  - Compressed data (pixel data)
     13
     14  The class TPaintDotNetFile do not read the Xml header. ComputeFlatImage builds the resulting image
     15  by using blending operations to merge layers.
     16
     17  The unit registers a TFPCustomImageReader so that it can be read by any image reading function of FreePascal }
     18
    719uses
    8   Classes, SysUtils, BGRADNetDeserial, BGRABitmap, BGRABitmapTypes;
     20  Classes, SysUtils, BGRADNetDeserial, BGRALayers, BGRABitmap, BGRABitmapTypes, FPImage;
    921
    1022type
     
    1224  { TPaintDotNetFile }
    1325
    14   TPaintDotNetFile = class
     26  TPaintDotNetFile = class(TBGRACustomLayeredBitmap)
    1527  public
    16     procedure LoadFromFile(filename: string);
    17     procedure LoadFromStream(stream: TStream);
    18     procedure Clear;
    19     function ToString: string;
    20     destructor Destroy; override;
     28    procedure LoadFromFile(filename: string); override;
     29    procedure LoadFromStream(stream: TStream); override;
     30    procedure Clear; override;
     31    function ToString: ansistring; override;
     32    function GetLayerBitmapCopy(layer: integer): TBGRABitmap; override;
    2133    constructor Create;
    22     function Width: integer;
    23     function Height: integer;
    24     function NbLayers: integer;
    25     function BlendOperation(Layer: integer): TBlendOperation;
    26     function LayerVisible(layer: integer): boolean;
    27     function LayerOpacity(layer: integer): byte;
    28     function LayerName(layer: integer): string;
    29     function MakeBitmapLayer(layer: integer): TBGRABitmap;
    30     function ComputeFlatImage: TBGRABitmap;
     34  protected
     35    function GetWidth: integer; override;
     36    function GetHeight: integer; override;
     37    function GetNbLayers: integer; override;
     38    function GetBlendOperation(Layer: integer): TBlendOperation; override;
     39    function GetLayerVisible(layer: integer): boolean; override;
     40    function GetLayerOpacity(layer: integer): byte; override;
     41    function GetLayerName(layer: integer): string; override;
    3142  private
    3243    XmlHeader: string;
    3344    ThumbNail: TBGRABitmap;
    3445    Content:   TDotNetDeserialization;
    35     Document:  PSerializedObject;
    36     Layers:    PSerializedObject;
     46    Document:  TSerializedClass;
     47    Layers:    TSerializedClass;
    3748    LayerData: array of TMemoryStream;
    38     function GetLayer(num: integer): PSerializedObject;
    39     function GetBlendOperation(layer: PSerializedObject): TBlendOperation;
    40     function GetLayerName(layer: PSerializedObject): string;
    41     function GetLayerVisible(layer: PSerializedObject): boolean;
    42     function GetLayerOpacity(layer: PSerializedObject): byte;
     49    function InternalGetLayer(num: integer): TSerializedClass;
     50    function InternalGetBlendOperation(layer: TSerializedClass): TBlendOperation;
     51    function InternalGetLayerName(layer: TSerializedClass): string;
     52    function InternalGetLayerVisible(layer: TSerializedClass): boolean;
     53    function InternalGetLayerOpacity(layer: TSerializedClass): byte;
    4354    function LayerDataSize(numLayer: integer): int64;
    4455    procedure LoadLayer(dest: TMemoryStream; src: TStream; uncompressedSize: int64);
     56  end;
     57
     58  { TFPReaderPaintDotNet }
     59
     60  TFPReaderPaintDotNet = class(TFPCustomImageReader)
     61    protected
     62      function InternalCheck(Stream: TStream): boolean; override;
     63      procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
    4564  end;
    4665
     
    146165{$hints on}
    147166
     167{ TFPReaderPaintDotNet }
     168
     169function TFPReaderPaintDotNet.InternalCheck(Stream: TStream): boolean;
     170begin
     171  result := IsPaintDotNetStream(stream);
     172end;
     173
     174procedure TFPReaderPaintDotNet.InternalRead(Stream: TStream; Img: TFPCustomImage
     175  );
     176var
     177  pdn: TPaintDotNetFile;
     178  flat: TBGRABitmap;
     179  x,y: integer;
     180begin
     181  pdn    := TPaintDotNetFile.Create;
     182  try
     183    pdn.LoadFromStream(Stream);
     184    flat := pdn.ComputeFlatImage;
     185    try
     186      Img.SetSize(pdn.Width,pdn.Height);
     187      for y := 0 to pdn.Height-1 do
     188        for x := 0 to pdn.Width-1 do
     189          Img.Colors[x,y] := BGRAToFPColor(flat.GetPixel(x,y));
     190    finally
     191      flat.free;
     192    end;
     193    pdn.Free;
     194  except
     195    on ex: Exception do
     196    begin
     197      pdn.Free;
     198      raise Exception.Create('Error while loading Paint.NET file. ' + ex.Message);
     199    end;
     200  end;
     201end;
     202
    148203{ TPaintDotNetFile }
    149204
     
    163218var
    164219  header: packed array[0..3] of char;
    165   XmlHeaderSize: longword;
     220  XmlHeaderSize: integer;
    166221  CompressionFormat: word;
    167222  i:      integer;
     
    192247        IntToStr(Compressionformat) + ')');
    193248  end;
    194   Document := Content.FindObject('Document');
     249  Document := Content.FindClass('Document');
    195250  if Document <> nil then
    196     Layers := Content.GetObjectField(Document^, 'layers');
     251    Layers := Content.GetObjectField(Document, 'layers') as TSerializedClass;
    197252  SetLength(LayerData, NbLayers);
    198253  for i := 0 to NbLayers - 1 do
     
    203258end;
    204259
    205 function TPaintDotNetFile.ToString: string;
     260function TPaintDotNetFile.ToString: ansistring;
    206261var
    207262  i, j, nbbytes: integer;
     
    216271  for i := 0 to NbLayers - 1 do
    217272  begin
    218     Result += LineEnding + 'Layer ' + IntToStr(i) + ' : ' + LayerName(i) + LineEnding;
     273    Result += LineEnding + 'Layer ' + IntToStr(i) + ' : ' + LayerName[i] + LineEnding;
    219274    Result += '[ ';
    220275    LayerData[i].Position := 0;
     
    234289    Result   += ']' + lineending;
    235290  end;
    236 end;
    237 
    238 destructor TPaintDotNetFile.Destroy;
    239 begin
    240   content.Free;
    241   Thumbnail.Free;
    242   inherited Destroy;
    243291end;
    244292
     
    265313end;
    266314
    267 function TPaintDotNetFile.Width: integer;
     315function TPaintDotNetFile.GetWidth: integer;
    268316begin
    269317  if Document = nil then
    270318    Result := 0
    271319  else
    272     Result := StrToInt(Content.GetSimpleField(Document^, 'width'));
    273 end;
    274 
    275 function TPaintDotNetFile.Height: integer;
     320    Result := StrToInt(Content.GetSimpleField(Document, 'width'));
     321end;
     322
     323function TPaintDotNetFile.GetHeight: integer;
    276324begin
    277325  if Document = nil then
    278326    Result := 0
    279327  else
    280     Result := StrToInt(Content.GetSimpleField(Document^, 'height'));
    281 end;
    282 
    283 function TPaintDotNetFile.NbLayers: integer;
     328    Result := StrToInt(Content.GetSimpleField(Document, 'height'));
     329end;
     330
     331function TPaintDotNetFile.GetNbLayers: integer;
    284332begin
    285333  if Layers = nil then
    286334    Result := 0
    287335  else
    288     Result := StrToInt(Content.GetSimpleField(Layers^, '_size'));
    289 end;
    290 
    291 function TPaintDotNetFile.BlendOperation(Layer: integer): TBlendOperation;
    292 begin
    293   Result := GetBlendOperation(GetLayer(layer));
    294 end;
    295 
    296 function TPaintDotNetFile.LayerVisible(layer: integer): boolean;
    297 begin
    298   Result := GetLayerVisible(GetLayer(layer));
    299 end;
    300 
    301 function TPaintDotNetFile.LayerOpacity(layer: integer): byte;
    302 begin
    303   Result := GetLayerOpacity(GetLayer(layer));
    304 end;
    305 
    306 function TPaintDotNetFile.LayerName(layer: integer): string;
    307 begin
    308   Result := GetLayerName(GetLayer(layer));
    309 end;
    310 
    311 function TPaintDotNetFile.MakeBitmapLayer(layer: integer): TBGRABitmap;
     336    Result := StrToInt(Content.GetSimpleField(Layers, '_size'));
     337end;
     338
     339function TPaintDotNetFile.GetBlendOperation(Layer: integer): TBlendOperation;
     340begin
     341  Result := InternalGetBlendOperation(InternalGetLayer(layer));
     342end;
     343
     344function TPaintDotNetFile.GetLayerVisible(layer: integer): boolean;
     345begin
     346  Result := InternalGetLayerVisible(InternalGetLayer(layer));
     347end;
     348
     349function TPaintDotNetFile.GetLayerOpacity(layer: integer): byte;
     350begin
     351  Result := InternalGetLayerOpacity(InternalGetLayer(layer));
     352end;
     353
     354function TPaintDotNetFile.GetLayerName(layer: integer): string;
     355begin
     356  Result := InternalGetLayerName(InternalGetLayer(layer));
     357end;
     358
     359function TPaintDotNetFile.GetLayerBitmapCopy(layer: integer): TBGRABitmap;
    312360begin
    313361  if (layer < 0) or (layer >= NbLayers) then
     
    315363
    316364  Result := TBGRABitmap.Create(Width, Height);
    317   if Result.NbPixels * 4 <> LayerData[layer].Size then
     365  if int64(Result.NbPixels) * 4 <> LayerData[layer].Size then
    318366  begin
    319367    Result.Free;
     
    331379end;
    332380
    333 function TPaintDotNetFile.ComputeFlatImage: TBGRABitmap;
    334 var
    335   tempLayer, tempMerge: TBGRABitmap;
    336   i: integer;
    337 begin
    338   Result := TBGRABitmap.Create(Width, Height);
    339   for i := 0 to NbLayers - 1 do
    340   begin
    341     tempLayer := MakeBitmapLayer(i);
    342     if tempLayer <> nil then
    343     begin
    344       //first layer is simply the background
    345       if i = 0 then
    346         Result.PutImage(0, 0, tempLayer, dmSet)
    347       else
    348       //simple blend operations
    349       if BlendOperation(i) in [boTransparent, boLinearBlend] then
    350       begin
    351         tempLayer.ApplyGlobalOpacity(LayerOpacity(i));
    352         Result.BlendImage(0, 0, tempLayer, BlendOperation(i));
    353       end
    354       else
    355         //complex blend operations are done in a third bitmap
    356       begin
    357         tempMerge := Result.Duplicate as TBGRABitmap;
    358         tempMerge.BlendImage(0, 0, tempLayer, BlendOperation(i));
    359         tempMerge.ApplyGlobalOpacity(LayerOpacity(i));
    360         Result.PutImage(0, 0, tempMerge, dmFastBlend);
    361         tempMerge.Free;
    362       end;
    363       tempLayer.Free;
    364     end;
    365   end;
    366 end;
    367 
    368 function TPaintDotNetFile.GetLayerName(layer: PSerializedObject): string;
    369 var
    370   prop: PSerializedObject;
     381function TPaintDotNetFile.InternalGetLayerName(layer: TSerializedClass): string;
     382var
     383  prop: TCustomSerializedObject;
    371384begin
    372385  if layer = nil then
     
    374387  else
    375388  begin
    376     prop := Content.GetObjectField(layer^, 'Layer+properties');
     389    prop := Content.GetObjectField(layer, 'Layer+properties');
    377390    if prop = nil then
    378391      Result := ''
    379392    else
    380393    begin
    381       Result := Content.GetSimpleField(prop^, 'name');
     394      Result := Content.GetSimpleField(prop, 'name');
    382395    end;
    383396  end;
     
    386399function TPaintDotNetFile.LayerDataSize(numLayer: integer): int64;
    387400var
    388   layer, surface, scan0: PSerializedObject;
    389 begin
    390   layer := GetLayer(numLayer);
     401  layer, surface, scan0: TCustomSerializedObject;
     402begin
     403  layer := InternalGetLayer(numLayer);
    391404  if layer = nil then
    392405    Result := 0
    393406  else
    394407  begin
    395     surface := Content.GetObjectField(layer^, 'surface');
     408    surface := Content.GetObjectField(layer, 'surface');
    396409    if surface = nil then
    397410      Result := 0
    398411    else
    399412    begin
    400       scan0  := Content.GetObjectField(surface^, 'scan0');
    401       Result := StrToInt64(Content.GetSimpleField(scan0^, 'length64'));
     413      scan0  := Content.GetObjectField(surface, 'scan0');
     414      Result := StrToInt64(Content.GetSimpleField(scan0, 'length64'));
    402415    end;
    403416  end;
     
    457470end;
    458471
    459 function TPaintDotNetFile.GetLayer(num: integer): PSerializedObject;
    460 var
    461   layerList: PSerializedObject;
     472function TPaintDotNetFile.InternalGetLayer(num: integer): TSerializedClass;
     473var
     474  layerList: TCustomSerializedObject;
    462475begin
    463476  if Layers = nil then
     
    468481  else
    469482  begin
    470     layerList := Content.GetObjectField(Layers^, '_items');
    471     Result    := Content.GetObject(layerList^.fields[num].Value);
    472   end;
    473 end;
    474 
    475 function TPaintDotNetFile.GetBlendOperation(layer: PSerializedObject): TBlendOperation;
    476 var
    477   prop, blendOp: PSerializedObject;
     483    layerList := Content.GetObjectField(Layers, '_items');
     484    Result    := Content.GetObject(layerList.FieldAsString[num]) as TSerializedClass;
     485  end;
     486end;
     487
     488function TPaintDotNetFile.InternalGetBlendOperation(layer: TSerializedClass): TBlendOperation;
     489var
     490  prop, blendOp: TCustomSerializedObject;
    478491  blendName:     string;
    479492begin
     
    482495  else
    483496  begin
    484     prop := Content.GetObjectField(layer^, 'properties');
     497    prop := Content.GetObjectField(layer, 'properties');
    485498    if prop = nil then
    486499      Result := boTransparent
    487500    else
    488501    begin
    489       blendOp := Content.GetObjectField(prop^, 'blendOp');
     502      blendOp := Content.GetObjectField(prop, 'blendOp');
    490503      if blendOp = nil then
    491504        Result := boTransparent
    492505      else
    493506      begin
    494         blendName := Content.GetObjectType(blendOp);
     507        blendName := blendOp.TypeAsString;
    495508        if (pos('+', blendName) <> 0) then
    496509          Delete(blendName, 1, pos('+', blendName));
     
    548561end;
    549562
    550 function TPaintDotNetFile.GetLayerVisible(layer: PSerializedObject): boolean;
    551 var
    552   prop: PSerializedObject;
     563function TPaintDotNetFile.InternalGetLayerVisible(layer: TSerializedClass): boolean;
     564var
     565  prop: TCustomSerializedObject;
    553566begin
    554567  if layer = nil then
     
    556569  else
    557570  begin
    558     prop := Content.GetObjectField(layer^, 'Layer+properties');
     571    prop := Content.GetObjectField(layer, 'Layer+properties');
    559572    if prop = nil then
    560573      Result := False
    561574    else
    562575    begin
    563       Result := (Content.GetSimpleField(prop^, 'visible') = 'True');
    564     end;
    565   end;
    566 end;
    567 
    568 function TPaintDotNetFile.GetLayerOpacity(layer: PSerializedObject): byte;
    569 var
    570   prop: PSerializedObject;
     576      Result := (Content.GetSimpleField(prop, 'visible') = 'True');
     577    end;
     578  end;
     579end;
     580
     581function TPaintDotNetFile.InternalGetLayerOpacity(layer: TSerializedClass): byte;
     582var
     583  prop: TCustomSerializedObject;
    571584begin
    572585  if layer = nil then
     
    574587  else
    575588  begin
    576     prop := Content.GetObjectField(layer^, 'Layer+properties');
     589    prop := Content.GetObjectField(layer, 'Layer+properties');
    577590    if prop = nil then
    578591      Result := 0
    579592    else
    580593    begin
    581       Result := StrToInt(Content.GetSimpleField(prop^, 'opacity'));
    582     end;
    583   end;
    584 end;
    585 
    586 {var fout: TFileStream;
    587     comp: Tcompressionstream;
    588 
    589     gzipHeader: packed record
    590        magicWord: word;
    591        compMethod,flags: byte;
    592        fileModif: Longword;
    593        extraflag,os: byte;
    594     end;                   }
     594      Result := StrToInt(Content.GetSimpleField(prop, 'opacity'));
     595    end;
     596  end;
     597end;
    595598
    596599initialization
    597600
    598 {  gzipHeader.magicWord := $8b1F;
    599   gzipHeader.compMethod := 8;
    600   gzipHeader.flags := 0;
    601   gzipHeader.fileModif := 0;
    602   gzipHeader.extraflag := 0;
    603   gzipHeader.os := $ff;
    604 
    605   fout := TFileStream.Create('testcomp.gz', fmCreate);
    606   fout.Write(gzipHeader,sizeof(gzipHeader));
    607   comp := Tcompressionstream.Create(cldefault,fout,true);
    608   comp.WriteAnsiString('Hello world');
    609   comp.free;
    610   fout.Free;  }
     601  ImageHandlers.RegisterImageReader ('Paint.NET image', 'pdn', TFPReaderPaintDotNet);
    611602
    612603end.
    613604
     605
  • 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 
  • GraphicTest/BGRABitmap/bgraqtbitmap.pas

    r210 r317  
    5959procedure TBGRAQtBitmap.SlowDrawTransparent(ABitmap: TBGRADefaultBitmap;
    6060  ACanvas: TCanvas; ARect: TRect);
    61 var
    62   background, temp: TBGRADefaultBitmap;
    63   w, h: integer;
    64 
    6561begin
    66   w := ARect.Right - ARect.Left;
    67   h := ARect.Bottom - ARect.Top;
    68   background := NewBitmap(w, h);
    69   background.GetImageFromCanvas(ACanvas, ARect.Left, ARect.Top);
    70   if (ABitmap.Width = w) and (ABitmap.Height = h) then
    71     background.PutImage(0, 0, ABitmap, dmDrawWithTransparency)
    72   else
    73   begin
    74     temp := ABitmap.Resample(w, h, rmSimpleStretch);
    75     background.PutImage(0, 0, temp, dmDrawWithTransparency);
    76     temp.Free;
    77   end;
    78   background.Draw(ACanvas, ARect.Left, ARect.Top, True);
    79   background.Free;
     62  ACanvas.Draw(0,0, ABitmap.Bitmap);
    8063end;
    8164
  • GraphicTest/BGRABitmap/bgraresample.pas

    r210 r317  
    1 unit bgraresample;
     1unit BGRAResample;
    22
    33{$mode objfpc}{$H+}
    44
    5 { 6/2/2011 : fixed SimpleStretchSmaller }
    6 
    75interface
    86
     7{ This unit provides resampling functions, i.e. resizing of bitmaps with or
     8  without interpolation filters.
     9
     10  SimpleStretch does a fast stretch by splitting the image into zones defined
     11  by integers. This can be quite ugly.
     12
     13  FineResample uses floating point coordinates to get an antialiased resample.
     14  It can use minimal interpolation (4 pixels when upsizing) for simple interpolation
     15  filters (linear and cosine-like) or wide kernel resample for complex interpolation.
     16  In this cas, it calls WideKernelResample.
     17
     18  WideKernelResample can be called by custom filter kernel, derived
     19  from TWideKernelFilter. It is slower of course than simple interpolation. }
     20
    921uses
    10   Classes, SysUtils, BGRADefaultBitmap;
    11 
    12 function FineResample(bmp: TBGRADefaultBitmap;
    13   NewWidth, NewHeight: integer): TBGRADefaultBitmap;
    14 function SimpleStretch(bmp: TBGRADefaultBitmap;
    15   NewWidth, NewHeight: integer): TBGRADefaultBitmap;
     22  Classes, SysUtils, BGRABitmapTypes;
     23
     24{------------------------------- Simple stretch ------------------------------------}
     25
     26function SimpleStretch(bmp: TBGRACustomBitmap;
     27  NewWidth, NewHeight: integer): TBGRACustomBitmap;
     28
     29{---------------------------- Interpolation filters --------------------------------}
     30
     31function FineInterpolation(t: single; ResampleFilter: TResampleFilter): single;
     32
     33type
     34  TWideKernelFilter = class
     35    function Interpolation(t: single): single; virtual; abstract;
     36    function ShouldCheckRange: boolean; virtual; abstract;
     37    function KernelWidth: single; virtual; abstract;
     38  end;
     39
     40  TMitchellKernel = class(TWideKernelFilter)
     41    function Interpolation(t: single): single; override;
     42    function ShouldCheckRange: boolean; override;
     43    function KernelWidth: single; override;
     44  end;
     45
     46  { TSplineKernel }
     47
     48  TSplineKernel = class(TWideKernelFilter)
     49  public
     50    Coeff: single;
     51    constructor Create;
     52    constructor Create(ACoeff: single);
     53    function Interpolation(t: single): single; override;
     54    function ShouldCheckRange: boolean; override;
     55    function KernelWidth: single; override;
     56  end;
     57
     58  { TCubicKernel }
     59
     60  TCubicKernel = class(TWideKernelFilter)
     61    function pow3(x: single): single; inline;
     62    function Interpolation(t: single): single; override;
     63    function ShouldCheckRange: boolean; override;
     64    function KernelWidth: single; override;
     65  end;
     66
     67function CreateInterpolator(style: TSplineStyle): TWideKernelFilter;
     68
     69{-------------------------------- Fine resample ------------------------------------}
     70
     71function FineResample(bmp: TBGRACustomBitmap;
     72  NewWidth, NewHeight: integer; ResampleFilter: TResampleFilter): TBGRACustomBitmap;
     73
     74function WideKernelResample(bmp: TBGRACustomBitmap;
     75  NewWidth, NewHeight: integer; ResampleFilterSmaller, ResampleFilterLarger: TWideKernelFilter): TBGRACustomBitmap;
    1676
    1777implementation
    1878
    19 uses GraphType, BGRABitmapTypes, Math;
    20 
    21 function FineResampleLarger(bmp: TBGRADefaultBitmap;
    22   newWidth, newHeight: integer): TBGRADefaultBitmap;
     79uses GraphType, Math;
     80
     81{-------------------------------- Simple stretch ------------------------------------}
     82
     83function FastSimpleStretchLarger(bmp: TBGRACustomBitmap;
     84  xFactor, yFactor: integer): TBGRACustomBitmap;
    2385var
    24   yb, xb: integer;
    25   pdest:  PBGRAPixel;
    26   xsrc, ysrc, xfactor, yfactor: double;
    27   ixsrc1, ixsrc2, iysrc1, iysrc2: integer;
    28   cUpLeft, cUpRight, cLowLeft, cLowRight: TBGRAPixel;
    29   factHoriz, factVert, factCorrX, factCorrY, Sum, fUpLeft, fUpRight,
    30   fLowLeft, fLowRight, faUpLeft, faUpRight, faLowLeft, faLowRight: single;
    31   rSum, gSum, bSum, aSum: single;
    32   temp:   TBGRADefaultBitmap;
     86  y_src, yb, y_dest: integer;
     87
     88  x_src, xb: integer;
     89  srcColor:  TBGRAPixel;
     90
     91  PSrc:  PBGRAPixel;
     92  PDest: array of PBGRAPixel;
     93  temp:  PBGRAPixel;
     94
     95begin
     96  if (xFactor < 1) or (yFactor < 1) then
     97    raise ERangeError.Create('FastSimpleStretchLarger: New dimensions must be greater or equal (*'+IntToStr(xFactor)+'x*'+IntToStr(yFactor)+')');
     98
     99  Result := bmp.NewBitmap(bmp.Width * xFactor, bmp.Height * yFactor);
     100  if (Result.Width = 0) or (Result.Height = 0) then
     101    exit;
     102
     103  bmp.LoadFromBitmapIfNeeded;
     104
     105  SetLength(PDest, yFactor);
     106  y_dest := 0;
     107  for y_src := 0 to bmp.Height - 1 do
     108  begin
     109    PSrc := bmp.Scanline[y_src];
     110    for yb := 0 to yFactor - 1 do
     111      PDest[yb] := Result.scanLine[y_dest + yb];
     112
     113    for x_src := 0 to bmp.Width - 1 do
     114    begin
     115      srcColor := PSrc^;
     116      Inc(PSrc);
     117
     118      for yb := 0 to yFactor - 1 do
     119      begin
     120        temp := PDest[yb];
     121        for xb := 0 to xFactor - 1 do
     122        begin
     123          temp^ := srcColor;
     124          Inc(temp);
     125        end;
     126        PDest[yb] := temp;
     127      end;
     128    end;
     129    Inc(y_dest, yFactor);
     130  end;
     131
     132  Result.InvalidateBitmap;
     133end;
     134
     135function SimpleStretchLarger(bmp: TBGRACustomBitmap;
     136  newWidth, newHeight: integer): TBGRACustomBitmap;
     137var
     138  x_src, y_src: integer;
     139  inc_x_dest, mod_x_dest, acc_x_dest, inc_y_dest, mod_y_dest, acc_y_dest: integer;
     140  x_dest, y_dest, prev_x_dest, prev_y_dest: integer;
     141
     142  xb, yb:      integer;
     143  srcColor:    TBGRAPixel;
     144  PDest, PSrc: PBGRAPixel;
     145  delta, lineDelta: integer;
     146
    33147begin
    34148  if (newWidth < bmp.Width) or (newHeight < bmp.Height) then
    35     raise ERangeError.Create('FineResampleLarger: New dimensions must be greater or equal ('+IntToStr(bmp.Width)+'x'+IntToStr(bmp.Height)+'->'+IntToStr(newWidth)+'x'+IntToStr(newHeight)+')');
     149    raise ERangeError.Create('SimpleStretchLarger: New dimensions must be greater or equal ('+IntToStr(bmp.Width)+'x'+IntToStr(bmp.Height)+'->'+IntToStr(newWidth)+'x'+IntToStr(newHeight)+')');
     150
     151  if ((newWidth div bmp.Width) * bmp.Width = newWidth) and
     152    ((newHeight div bmp.Height) * bmp.Height = newHeight) then
     153  begin
     154    Result := FastSimpleStretchLarger(bmp, newWidth div bmp.Width,
     155      newHeight div bmp.Height);
     156    exit;
     157  end;
    36158
    37159  Result := bmp.NewBitmap(NewWidth, NewHeight);
     
    41163  bmp.LoadFromBitmapIfNeeded;
    42164
     165  inc_x_dest := newwidth div bmp.Width;
     166  mod_x_dest := newwidth mod bmp.Width;
     167  inc_y_dest := newheight div bmp.Height;
     168  mod_y_dest := newheight mod bmp.Height;
     169
     170  y_dest     := 0;
     171  acc_y_dest := bmp.Height div 2;
     172  if Result.LineOrder = riloTopToBottom then
     173    lineDelta := newWidth
     174  else
     175    lineDelta := -newWidth;
     176  for y_src := 0 to bmp.Height - 1 do
     177  begin
     178    prev_y_dest := y_dest;
     179    Inc(y_dest, inc_y_dest);
     180    Inc(acc_y_dest, mod_y_dest);
     181    if acc_y_dest >= bmp.Height then
     182    begin
     183      Dec(acc_y_dest, bmp.Height);
     184      Inc(y_dest);
     185    end;
     186
     187    PSrc := bmp.Scanline[y_src];
     188
     189    x_dest     := 0;
     190    acc_x_dest := bmp.Width div 2;
     191    for x_src := 0 to bmp.Width - 1 do
     192    begin
     193      prev_x_dest := x_dest;
     194      Inc(x_dest, inc_x_dest);
     195      Inc(acc_x_dest, mod_x_dest);
     196      if acc_x_dest >= bmp.Width then
     197      begin
     198        Dec(acc_x_dest, bmp.Width);
     199        Inc(x_dest);
     200      end;
     201
     202      srcColor := PSrc^;
     203      Inc(PSrc);
     204
     205      PDest := Result.scanline[prev_y_dest] + prev_x_dest;
     206      delta := lineDelta - (x_dest - prev_x_dest);
     207      for yb := prev_y_dest to y_dest - 1 do
     208      begin
     209        for xb := prev_x_dest to x_dest - 1 do
     210        begin
     211          PDest^ := srcColor;
     212          Inc(PDest);
     213        end;
     214        Inc(PDest, delta);
     215      end;
     216    end;
     217  end;
     218  Result.InvalidateBitmap;
     219end;
     220
     221function SimpleStretchSmallerFactor2(source: TBGRACustomBitmap): TBGRACustomBitmap;
     222var xb,yb: integer;
     223    pdest: PBGRAPixel;
     224    psrc1,psrc2: PBGRAPixel;
     225    asum: integer;
     226    a1,a2,a3,a4: integer;
     227    newWidth,newHeight: integer;
     228begin
     229  newWidth := source.Width div 2;
     230  newHeight := source.Height div 2;
     231  result := source.NewBitmap(newWidth,newHeight);
     232  for yb := 0 to newHeight-1 do
     233  begin
     234    pdest := result.ScanLine[yb];
     235    psrc1 := source.Scanline[yb shl 1];
     236    psrc2 := source.Scanline[yb shl 1+1];
     237    for xb := newWidth-1 downto 0 do
     238    begin
     239      asum := psrc1^.alpha + (psrc1+1)^.alpha + psrc2^.alpha + (psrc2+1)^.alpha;
     240      if asum = 0 then
     241        pdest^ := BGRAPixelTransparent
     242      else if asum = 1020 then
     243      begin
     244        pdest^.alpha := 255;
     245        pdest^.red := (psrc1^.red + (psrc1+1)^.red + psrc2^.red + (psrc2+1)^.red + 2) shr 2;
     246        pdest^.green := (psrc1^.green + (psrc1+1)^.green + psrc2^.green + (psrc2+1)^.green+ 2) shr 2;
     247        pdest^.blue := (psrc1^.blue + (psrc1+1)^.blue + psrc2^.blue + (psrc2+1)^.blue+ 2) shr 2;
     248      end else
     249      begin
     250        pdest^.alpha := asum shr 2;
     251        a1 := psrc1^.alpha;
     252        a2 := (psrc1+1)^.alpha;
     253        a3 := psrc2^.alpha;
     254        a4 := (psrc2+1)^.alpha;
     255        pdest^.red := (psrc1^.red*a1 + (psrc1+1)^.red*a2 + psrc2^.red*a3 + (psrc2+1)^.red*a4 + (asum shr 1)) div asum;
     256        pdest^.green := (psrc1^.green*a1 + (psrc1+1)^.green*a2 + psrc2^.green*a3 + (psrc2+1)^.green*a4+ (asum shr 1)) div asum;
     257        pdest^.blue := (psrc1^.blue*a1 + (psrc1+1)^.blue*a2 + psrc2^.blue*a3 + (psrc2+1)^.blue*a4+ (asum shr 1)) div asum;
     258      end;
     259      inc(psrc1,2);
     260      inc(psrc2,2);
     261      inc(pdest);
     262    end;
     263  end;
     264end;
     265
     266function SimpleStretchSmallerFactor4(source: TBGRACustomBitmap): TBGRACustomBitmap;
     267var xb,yb: integer;
     268    pdest: PBGRAPixel;
     269    psrc1,psrc2,psrc3,psrc4: PBGRAPixel;
     270    asum: integer;
     271    a1,a2,a3,a4,
     272    a5,a6,a7,a8,
     273    a9,a10,a11,a12,
     274    a13,a14,a15,a16: integer;
     275    newWidth,newHeight: integer;
     276begin
     277  newWidth := source.Width div 4;
     278  newHeight := source.Height div 4;
     279  result := source.NewBitmap(newWidth,newHeight);
     280  for yb := 0 to newHeight-1 do
     281  begin
     282    pdest := result.ScanLine[yb];
     283    psrc1 := source.Scanline[yb shl 2];
     284    psrc2 := source.Scanline[yb shl 2+1];
     285    psrc3 := source.Scanline[yb shl 2+2];
     286    psrc4 := source.Scanline[yb shl 2+3];
     287    for xb := newWidth-1 downto 0 do
     288    begin
     289      asum := psrc1^.alpha + (psrc1+1)^.alpha + (psrc1+2)^.alpha + (psrc1+3)^.alpha +
     290              psrc2^.alpha + (psrc2+1)^.alpha + (psrc2+2)^.alpha + (psrc2+3)^.alpha +
     291              psrc3^.alpha + (psrc3+1)^.alpha + (psrc3+2)^.alpha + (psrc3+3)^.alpha +
     292              psrc4^.alpha + (psrc4+1)^.alpha + (psrc4+2)^.alpha + (psrc4+3)^.alpha;
     293      if asum = 0 then
     294        pdest^ := BGRAPixelTransparent
     295      else if asum = 4080 then
     296      begin
     297        pdest^.alpha := 255;
     298        pdest^.red := (psrc1^.red + (psrc1+1)^.red + (psrc1+2)^.red + (psrc1+3)^.red +
     299              psrc2^.red + (psrc2+1)^.red + (psrc2+2)^.red + (psrc2+3)^.red +
     300              psrc3^.red + (psrc3+1)^.red + (psrc3+2)^.red + (psrc3+3)^.red +
     301              psrc4^.red + (psrc4+1)^.red + (psrc4+2)^.red + (psrc4+3)^.red + 8) shr 4;
     302        pdest^.green := (psrc1^.green + (psrc1+1)^.green + (psrc1+2)^.green + (psrc1+3)^.green +
     303              psrc2^.green + (psrc2+1)^.green + (psrc2+2)^.green + (psrc2+3)^.green +
     304              psrc3^.green + (psrc3+1)^.green + (psrc3+2)^.green + (psrc3+3)^.green +
     305              psrc4^.green + (psrc4+1)^.green + (psrc4+2)^.green + (psrc4+3)^.green + 8) shr 4;
     306        pdest^.blue := (psrc1^.blue + (psrc1+1)^.blue + (psrc1+2)^.blue + (psrc1+3)^.blue +
     307              psrc2^.blue + (psrc2+1)^.blue + (psrc2+2)^.blue + (psrc2+3)^.blue +
     308              psrc3^.blue + (psrc3+1)^.blue + (psrc3+2)^.blue + (psrc3+3)^.blue +
     309              psrc4^.blue + (psrc4+1)^.blue + (psrc4+2)^.blue + (psrc4+3)^.blue + 8) shr 4;
     310      end else
     311      begin
     312        pdest^.alpha := asum shr 4;
     313        a1 := psrc1^.alpha;
     314        a2 := (psrc1+1)^.alpha;
     315        a3 := (psrc1+2)^.alpha;
     316        a4 := (psrc1+3)^.alpha;
     317        a5 := psrc2^.alpha;
     318        a6 := (psrc2+1)^.alpha;
     319        a7 := (psrc2+2)^.alpha;
     320        a8 := (psrc2+3)^.alpha;
     321        a9 := psrc3^.alpha;
     322        a10 := (psrc3+1)^.alpha;
     323        a11 := (psrc3+2)^.alpha;
     324        a12 := (psrc3+3)^.alpha;
     325        a13 := psrc4^.alpha;
     326        a14 := (psrc4+1)^.alpha;
     327        a15 := (psrc4+2)^.alpha;
     328        a16 := (psrc4+3)^.alpha;
     329        pdest^.red := (psrc1^.red*a1 + (psrc1+1)^.red*a2 + (psrc1+2)^.red*a3 + (psrc1+3)^.red*a4 +
     330              psrc2^.red*a5 + (psrc2+1)^.red*a6 + (psrc2+2)^.red*a7 + (psrc2+3)^.red*a8 +
     331              psrc3^.red*a9 + (psrc3+1)^.red*a10 + (psrc3+2)^.red*a11 + (psrc3+3)^.red*a12 +
     332              psrc4^.red*a13 + (psrc4+1)^.red*a14 + (psrc4+2)^.red*a15 + (psrc4+3)^.red*a16 + (asum shr 1)) div asum;
     333        pdest^.green := (psrc1^.green*a1 + (psrc1+1)^.green*a2 + (psrc1+2)^.green*a3 + (psrc1+3)^.green*a4 +
     334              psrc2^.green*a5 + (psrc2+1)^.green*a6 + (psrc2+2)^.green*a7 + (psrc2+3)^.green*a8 +
     335              psrc3^.green*a9 + (psrc3+1)^.green*a10 + (psrc3+2)^.green*a11 + (psrc3+3)^.green*a12 +
     336              psrc4^.green*a13 + (psrc4+1)^.green*a14 + (psrc4+2)^.green*a15 + (psrc4+3)^.green*a16 + (asum shr 1)) div asum;
     337        pdest^.blue := (psrc1^.blue*a1 + (psrc1+1)^.blue*a2 + (psrc1+2)^.blue*a3 + (psrc1+3)^.blue*a4 +
     338              psrc2^.blue*a5 + (psrc2+1)^.blue*a6 + (psrc2+2)^.blue*a7 + (psrc2+3)^.blue*a8 +
     339              psrc3^.blue*a9 + (psrc3+1)^.blue*a10 + (psrc3+2)^.blue*a11 + (psrc3+3)^.blue*a12 +
     340              psrc4^.blue*a13 + (psrc4+1)^.blue*a14 + (psrc4+2)^.blue*a15 + (psrc4+3)^.blue*a16 + (asum shr 1)) div asum;
     341      end;
     342      inc(psrc1,4);
     343      inc(psrc2,4);
     344      inc(psrc3,4);
     345      inc(psrc4,4);
     346      inc(pdest);
     347    end;
     348  end;
     349end;
     350
     351function SimpleStretchSmallerFactor(source: TBGRACustomBitmap; fx,fy: integer): TBGRACustomBitmap;
     352var xb,yb,ys,iy,ix: integer;
     353    pdest: PBGRAPixel;
     354    psrc: array of PBGRAPixel;
     355    psrci: PBGRAPixel;
     356    asum,maxsum: integer;
     357    newWidth,newHeight: integer;
     358    r,g,b,nbi: integer;
     359begin
     360  newWidth := source.Width div fx;
     361  newHeight := source.Height div fy;
     362  result := source.NewBitmap(newWidth,newHeight);
     363  ys := 0;
     364  maxsum := 255*fx*fy;
     365  nbi := fx*fy;
     366  setlength(psrc, fy);
     367  for yb := 0 to newHeight-1 do
     368  begin
     369    pdest := result.ScanLine[yb];
     370    for iy := fy-1 downto 0 do
     371    begin
     372      psrc[iy] := source.Scanline[ys];
     373      inc(ys);
     374    end;
     375    for xb := newWidth-1 downto 0 do
     376    begin
     377      asum := 0;
     378      for iy := fy-1 downto 0 do
     379      begin
     380        psrci := psrc[iy];
     381        for ix := fx-1 downto 0 do
     382          asum += (psrci+ix)^.alpha;
     383      end;
     384      if asum = 0 then
     385        pdest^ := BGRAPixelTransparent
     386      else if asum = maxsum then
     387      begin
     388        pdest^.alpha := 255;
     389        r := 0;
     390        g := 0;
     391        b := 0;
     392        for iy := fy-1 downto 0 do
     393        begin
     394          psrci := psrc[iy];
     395          for ix := fx-1 downto 0 do
     396          begin
     397            with (psrci+ix)^ do
     398            begin
     399              r += red;
     400              g += green;
     401              b += blue;
     402            end;
     403          end;
     404        end;
     405        pdest^.red := (r + (nbi shr 1)) div nbi;
     406        pdest^.green := (g + (nbi shr 1)) div nbi;
     407        pdest^.blue := (b + (nbi shr 1)) div nbi;
     408      end else
     409      begin
     410        pdest^.alpha := (asum + (nbi shr 1)) div nbi;
     411        r := 0;
     412        g := 0;
     413        b := 0;
     414        for iy := fy-1 downto 0 do
     415        begin
     416          psrci := psrc[iy];
     417          for ix := fx-1 downto 0 do
     418          begin
     419            with (psrci+ix)^ do
     420            begin
     421              r += integer(red)*integer(alpha);
     422              g += integer(green)*integer(alpha);
     423              b += integer(blue)*integer(alpha);
     424            end;
     425          end;
     426        end;
     427        pdest^.red := (r + (asum shr 1)) div asum;
     428        pdest^.green := (g + (asum shr 1)) div asum;
     429        pdest^.blue := (b + (asum shr 1)) div asum;
     430      end;
     431      for iy := fy-1 downto 0 do
     432        inc(psrc[iy],fx);
     433      inc(pdest);
     434    end;
     435  end;
     436end;
     437
     438function SimpleStretchSmaller(bmp: TBGRACustomBitmap;
     439  newWidth, newHeight: integer): TBGRACustomBitmap;
     440var
     441  x_dest, y_dest: integer;
     442  inc_x_src, mod_x_src, acc_x_src, inc_y_src, mod_y_src, acc_y_src: integer;
     443  x_src, y_src, prev_x_src, prev_y_src: integer;
     444  x_src2, y_src2: integer;
     445
     446  xb, yb: integer;
     447  v1, v2, v3, v4, v4shr1: int64;
     448  nb,a:     integer;
     449  pdest, psrc, psrcscan: PBGRAPixel;
     450  lineDelta, delta: integer;
     451
     452begin
     453  if (newWidth > bmp.Width) or (newHeight > bmp.Height) then
     454    raise ERangeError.Create('SimpleStretchSmaller: New dimensions must be smaller or equal ('+IntToStr(bmp.Width)+'x'+IntToStr(bmp.Height)+'->'+IntToStr(newWidth)+'x'+IntToStr(newHeight)+')');
     455
     456  if (newWidth = 0) or (newHeight = 0) or (bmp.Width = 0) or (bmp.Height = 0) then
     457  begin
     458    Result := bmp.NewBitmap(NewWidth, NewHeight);
     459    exit;
     460  end;
     461
     462  if (newWidth*2 = bmp.Width) and (newHeight*2 = bmp.Height) then
     463  begin
     464    result := SimpleStretchSmallerFactor2(bmp);
     465    exit
     466  end
     467  else
     468  if (newWidth*4 = bmp.Width) and (newHeight*4 = bmp.Height) then
     469  begin
     470    result := SimpleStretchSmallerFactor4(bmp);
     471    exit;
     472  end
     473  else
     474  if (newWidth < bmp.Width) and (newHeight < bmp.Height) and
     475     (bmp.Width mod newWidth = 0) and (bmp.Height mod newHeight = 0) then
     476  begin
     477    result := SimpleStretchSmallerFactor(bmp, bmp.Width div newWidth, bmp.Height div newHeight);
     478    exit;
     479  end;
     480
     481  Result := bmp.NewBitmap(NewWidth, NewHeight);
     482
     483  bmp.LoadFromBitmapIfNeeded;
     484
     485  inc_x_src := bmp.Width div newWidth;
     486  mod_x_src := bmp.Width mod newWidth;
     487  inc_y_src := bmp.Height div newHeight;
     488  mod_y_src := bmp.Height mod newHeight;
     489
     490  if bmp.lineOrder = riloTopToBottom then
     491    lineDelta := bmp.Width
     492  else
     493    lineDelta := -bmp.Width;
     494
     495  y_src     := 0;
     496  acc_y_src := 0;
     497  for y_dest := 0 to newHeight - 1 do
     498  begin
     499    PDest := Result.ScanLine[y_dest];
     500
     501    prev_y_src := y_src;
     502    Inc(y_src, inc_y_src);
     503    Inc(acc_y_src, mod_y_src);
     504    if acc_y_src >= newHeight then
     505    begin
     506      Dec(acc_y_src, newHeight);
     507      Inc(y_src);
     508    end;
     509    if y_src > prev_y_src then
     510      y_src2 := y_src - 1
     511    else
     512      y_src2 := y_src;
     513    psrcscan := bmp.Scanline[prev_y_src];
     514
     515    x_src     := 0;
     516    acc_x_src := 0;
     517    for x_dest := 0 to newWidth - 1 do
     518    begin
     519      prev_x_src := x_src;
     520      Inc(x_src, inc_x_src);
     521      Inc(acc_x_src, mod_x_src);
     522      if acc_x_src >= newWidth then
     523      begin
     524        Dec(acc_x_src, newWidth);
     525        Inc(x_src);
     526      end;
     527      if x_src > prev_x_src then
     528        x_src2 := x_src - 1
     529      else
     530        x_src2 := x_src;
     531
     532      v1    := 0;
     533      v2    := 0;
     534      v3    := 0;
     535      v4    := 0;
     536      nb    := 0;
     537      delta := lineDelta - (x_src2 - prev_x_src + 1);
     538
     539      PSrc  := psrcscan + prev_x_src;
     540      for yb := prev_y_src to y_src2 do
     541      begin
     542        for xb := prev_x_src to x_src2 do
     543        begin
     544          with PSrc^ do
     545          begin
     546            a := alpha;
     547                    {$HINTS OFF}
     548            v1 += integer(red) * a;
     549            v2 += integer(green) * a;
     550            v3 += integer(blue) * a;
     551                    {$HINTS ON}
     552          end;
     553          v4 += a;
     554          Inc(PSrc);
     555          Inc(nb);
     556        end;
     557        Inc(PSrc, delta);
     558      end;
     559
     560      if (v4 <> 0) and (nb <> 0) then
     561      begin
     562        v4shr1  := v4 shr 1;
     563        with PDest^ do
     564        begin
     565          red   := (v1 + v4shr1) div v4;
     566          green := (v2 + v4shr1) div v4;
     567          blue  := (v3 + v4shr1) div v4;
     568          alpha := (v4 + (nb shr 1)) div nb;
     569        end;
     570      end
     571      else
     572       PDest^ := BGRAPixelTransparent;
     573
     574      Inc(PDest);
     575    end;
     576  end;
     577  Result.InvalidateBitmap;
     578end;
     579
     580function SimpleStretch(bmp: TBGRACustomBitmap;
     581  NewWidth, NewHeight: integer): TBGRACustomBitmap;
     582var
     583  temp, newtemp: TBGRACustomBitmap;
     584begin
     585  if (NewWidth = bmp.Width) and (NewHeight = bmp.Height) then
     586    Result := bmp.Duplicate
     587  else
     588  if (NewWidth >= bmp.Width) and (NewHeight >= bmp.Height) then
     589    Result := SimpleStretchLarger(bmp, NewWidth, NewHeight)
     590  else
     591  if (NewWidth <= bmp.Width) and (NewHeight <= bmp.Height) then
     592    Result := SimpleStretchSmaller(bmp, NewWidth, NewHeight)
     593  else
     594  begin
     595    temp := bmp;
     596
     597    if NewWidth < bmp.Width then
     598    begin
     599      newtemp := SimpleStretchSmaller(temp, NewWidth, temp.Height);
     600      if (temp <> bmp) then
     601        temp.Free;
     602      temp := newtemp;
     603    end;
     604
     605    if NewHeight < bmp.Height then
     606    begin
     607      newtemp := SimpleStretchSmaller(temp, temp.Width, NewHeight);
     608      if (temp <> bmp) then
     609        temp.Free;
     610      temp := newtemp;
     611    end;
     612
     613    if NewWidth > bmp.Width then
     614    begin
     615      newtemp := SimpleStretchLarger(temp, NewWidth, temp.Height);
     616      if (temp <> bmp) then
     617        temp.Free;
     618      temp := newtemp;
     619    end;
     620
     621    if NewHeight > bmp.Height then
     622    begin
     623      newtemp := SimpleStretchLarger(temp, temp.Width, NewHeight);
     624      if (temp <> bmp) then
     625        temp.Free;
     626      temp := newtemp;
     627    end;
     628
     629    if temp <> bmp then
     630      Result := temp
     631    else
     632      Result := bmp.Duplicate;
     633  end;
     634end;
     635
     636{---------------------------- Interpolation filters ----------------------------------------}
     637
     638function FineInterpolation(t: single; ResampleFilter: TResampleFilter): single;
     639begin
     640  if ResampleFilter = rfLinear then
     641    result := t else
     642  begin
     643    if t <= 0.5 then
     644      result := t*t*2 else
     645      result := 1-(1-t)*(1-t)*2;
     646    if ResampleFilter <> rfCosine then result := (result+t)*0.5;
     647  end;
     648end;
     649
     650{ TCubicKernel }
     651
     652function TCubicKernel.pow3(x: single): single;
     653begin
     654  if x <= 0.0 then
     655   result:=0.0
     656  else
     657   result:=x * x * x;
     658end;
     659
     660function TCubicKernel.Interpolation(t: single): single;
     661const globalfactor = 1/6;
     662begin
     663   if t > 2 then
     664     result := 0
     665   else
     666     result:= globalfactor *
     667       (pow3(t + 2 ) - 4 * pow3(t + 1 ) + 6 * pow3(t ) - 4 * pow3(t - 1 ) );
     668end;
     669
     670function TCubicKernel.ShouldCheckRange: boolean;
     671begin
     672  Result:= false;
     673end;
     674
     675function TCubicKernel.KernelWidth: single;
     676begin
     677  Result:= 2;
     678end;
     679
     680{ TMitchellKernel }
     681
     682function TMitchellKernel.Interpolation(t: single): single;
     683var
     684  tt, ttt: single;
     685const OneEighteenth = 1 / 18;
     686begin
     687  t := Abs(t);
     688  tt := Sqr(t);
     689  ttt := tt * t;
     690  if t < 1 then Result := (21 * ttt - 36 * tt + 16 ) * OneEighteenth
     691  else if t < 2 then Result := (- 7 * ttt + 36 * tt - 60 * t + 32) * OneEighteenth
     692  else Result := 0;
     693end;
     694
     695function TMitchellKernel.ShouldCheckRange: Boolean;
     696begin
     697  Result := True;
     698end;
     699
     700function TMitchellKernel.KernelWidth: single;
     701begin
     702  Result := 2;
     703end;
     704
     705{ TSplineKernel }
     706
     707constructor TSplineKernel.Create;
     708begin
     709  coeff := 0.5;
     710end;
     711
     712constructor TSplineKernel.Create(ACoeff: single);
     713begin
     714  Coeff := ACoeff;
     715end;
     716
     717function TSplineKernel.Interpolation(t: single): single;
     718var
     719  tt, ttt: single;
     720begin
     721  t := Abs(t);
     722  tt := Sqr(t);
     723  ttt := tt * t;
     724  if t < 1 then
     725    Result := (2 - Coeff) * ttt - (3 - Coeff) * tt + 1
     726  else if t < 2 then
     727    Result := -Coeff * (ttt - 5 * tt + 8 * t - 4)
     728  else
     729    Result := 0;
     730end;
     731
     732function TSplineKernel.ShouldCheckRange: Boolean;
     733begin
     734  Result := True;
     735end;
     736
     737function TSplineKernel.KernelWidth: single;
     738begin
     739  Result := 2;
     740end;
     741
     742{--------------------------------------------- Fine resample ------------------------------------------------}
     743
     744function FineResampleLarger(bmp: TBGRACustomBitmap;
     745  newWidth, newHeight: integer; ResampleFilter: TResampleFilter): TBGRACustomBitmap;
     746type
     747  TInterpolationEntry = record
     748    isrc1,isrc2,factCorr: integer;
     749  end;
     750var
     751  yb, xb: integer;
     752  pdest,psrc1,psrc2:  PBGRAPixel;
     753  xsrc, ysrc, xfactor, yfactor: double;
     754  xTab,yTab: array of TInterpolationEntry;
     755  xInfo,yInfo: TInterpolationEntry;
     756  cUpLeft, cUpRight, cLowLeft, cLowRight: TBGRAPixel;
     757  factHoriz, factVert: single;
     758  fUpLeft, fUpRight, fLowLeft, fLowRight: integer;
     759  faUpLeft, faUpRight, faLowLeft, faLowRight: integer;
     760  rSum, gSum, bSum, aSum: integer;
     761  temp:   TBGRACustomBitmap;
     762begin
     763  if (newWidth < bmp.Width) or (newHeight < bmp.Height) then
     764    raise ERangeError.Create('FineResampleLarger: New dimensions must be greater or equal ('+IntToStr(bmp.Width)+'x'+IntToStr(bmp.Height)+'->'+IntToStr(newWidth)+'x'+IntToStr(newHeight)+')');
     765
     766  if (newWidth = 0) or (newHeight = 0) then
     767  begin
     768    Result := bmp.NewBitmap(NewWidth, NewHeight);
     769    exit;
     770  end;
     771
     772  bmp.LoadFromBitmapIfNeeded;
     773
    43774  if (bmp.Width = 1) and (bmp.Height = 1) then
    44775  begin
     776    Result := bmp.NewBitmap(NewWidth, NewHeight);
    45777    Result.Fill(bmp.GetPixel(0, 0));
    46778    exit;
     
    52784    temp.PutImage(0, 0, bmp, dmSet);
    53785    temp.PutImage(1, 0, bmp, dmSet);
    54     Result := FineResampleLarger(temp, 2, newHeight);
     786    Result := FineResampleLarger(temp, 2, newHeight, ResampleFilter);
    55787    temp.Free;
    56788    temp := Result;
    57     Result := SimpleStretch(temp, 1,temp.Height);
     789    Result := SimpleStretch(temp, newWidth,temp.Height);
    58790    temp.Free;
    59791    exit;
     
    65797    temp.PutImage(0, 0, bmp, dmSet);
    66798    temp.PutImage(0, 1, bmp, dmSet);
    67     Result := FineResampleLarger(temp, newWidth, 2);
     799    Result := FineResampleLarger(temp, newWidth, 2, ResampleFilter);
    68800    temp.Free;
    69801    temp := Result;
    70     Result := SimpleStretch(temp, temp.Width,1);
     802    Result := SimpleStretch(temp, temp.Width,newHeight);
    71803    temp.Free;
    72804    exit;
    73805  end;
    74806
     807  Result := bmp.NewBitmap(NewWidth, NewHeight);
    75808  yfactor := (bmp.Height - 1) / (newHeight - 1);
    76809  xfactor := (bmp.Width - 1) / (newWidth - 1);
     810
     811  setlength(yTab, newHeight);
    77812  for yb := 0 to newHeight - 1 do
    78813  begin
     814    ysrc     := yb * yfactor;
     815    factVert := frac(ysrc);
     816    yTab[yb].isrc1   := floor(ysrc);
     817    yTab[yb].isrc2 := min(bmp.Height-1, ceil(ysrc));
     818    yTab[yb].factCorr := round(FineInterpolation(factVert,ResampleFilter)*256);
     819  end;
     820  setlength(xTab, newWidth);
     821  for xb := 0 to newWidth - 1 do
     822  begin
     823    xsrc     := xb * xfactor;
     824    factHoriz := frac(xsrc);
     825    xTab[xb].isrc1   := floor(xsrc);
     826    xTab[xb].isrc2 := min(bmp.Width-1,ceil(xsrc));
     827    xTab[xb].factCorr := round(FineInterpolation(factHoriz,ResampleFilter)*256);
     828  end;
     829
     830  for yb := 0 to newHeight - 1 do
     831  begin
    79832    pdest    := Result.Scanline[yb];
    80     ysrc     := yb * yfactor;
    81     iysrc1   := floor(ysrc);
    82     factVert := frac(ysrc);
    83     if (factVert = 0) then
    84       iysrc2 := iysrc1
    85     else
    86       iysrc2 := ceil(ysrc);
    87     factCorrY := 0.5 - cos(factVert * Pi) / 2;
     833    yInfo    := yTab[yb];
     834    psrc1    := bmp.scanline[yInfo.isrc1];
     835    psrc2    := bmp.scanline[yInfo.isrc2];
    88836    for xb := 0 to newWidth - 1 do
    89837    begin
    90       xsrc      := xb * xfactor;
    91       ixsrc1    := floor(xsrc);
    92       factHoriz := frac(xsrc);
    93       if (factHoriz = 0) then
    94         ixsrc2 := ixsrc1
    95       else
    96         ixsrc2 := ceil(xsrc);
    97       factCorrX := 0.5 - cos(factHoriz * Pi) / 2;
    98 
    99       cUpLeft   := bmp.GetPixel(ixsrc1, iysrc1);
    100       cUpRight  := bmp.GetPixel(ixsrc2, iysrc1);
    101       cLowLeft  := bmp.GetPixel(ixsrc1, iysrc2);
    102       cLowRight := bmp.GetPixel(ixsrc2, iysrc2);
    103 
    104       fUpLeft   := (1 - factCorrX) * (1 - factCorrY);
    105       fUpRight  := factCorrX * (1 - factCorrY);
    106       fLowLeft  := (1 - factCorrX) * factCorrY;
    107       fLowRight := factCorrX * factCorrY;
     838      xInfo  := xTab[xb];
     839
     840      cUpLeft   := (psrc1 + xInfo.isrc1)^;
     841      cUpRight  := (psrc1 + xInfo.isrc2)^;
     842      cLowLeft  := (psrc2 + xInfo.isrc1)^;
     843      cLowRight := (psrc2 + xInfo.isrc2)^;
     844
     845      fLowRight := (xInfo.factCorr * yInfo.factCorr + 128) shr 8;
     846      fLowLeft := yInfo.factCorr - fLowRight;
     847      fUpRight := xInfo.factCorr - fLowRight;
     848      fUpLeft := (256 - xInfo.factCorr) - fLowLeft;
    108849
    109850      faUpLeft   := fUpLeft * cUpLeft.alpha;
     
    112853      faLowRight := fLowRight * cLowRight.alpha;
    113854
    114       Sum  := fUpLeft + fUpRight + fLowLeft + fLowRight;
    115855      rSum := cUpLeft.red * faUpLeft + cUpRight.red * faUpRight +
    116856        cLowLeft.red * faLowLeft + cLowRight.red * faLowRight;
     
    125865        pdest^ := BGRAPixelTransparent
    126866      else
    127         pdest^ := BGRA(round(rSum / aSum), round(gSum / aSum),
    128           round(bSum / aSum), round(aSum / Sum));
     867        pdest^ := BGRA((rSum + aSum shr 1) div aSum, (gSum + aSum shr 1) div aSum,
     868          (bSum + aSum shr 1) div aSum, (aSum + 128) shr 8);
    129869      Inc(pdest);
    130870
     
    133873end;
    134874
    135 function FastSimpleStretchLarger(bmp: TBGRADefaultBitmap;
    136   xFactor, yFactor: integer): TBGRADefaultBitmap;
    137 var
    138   y_src, yb, y_dest: integer;
    139 
    140   x_src, xb: integer;
    141   srcColor:  TBGRAPixel;
    142 
    143   PSrc:  PBGRAPixel;
    144   PDest: array of PBGRAPixel;
    145   temp:  PBGRAPixel;
    146 
    147 begin
    148   if (xFactor < 1) or (yFactor < 1) then
    149     raise ERangeError.Create('FastSimpleStretchLarger: New dimensions must be greater or equal (*'+IntToStr(xFactor)+'x*'+IntToStr(yFactor)+')');
    150 
    151   Result := bmp.NewBitmap(bmp.Width * xFactor, bmp.Height * yFactor);
    152   if (Result.Width = 0) or (Result.Height = 0) then
    153     exit;
    154 
    155   bmp.LoadFromBitmapIfNeeded;
    156 
    157   SetLength(PDest, yFactor);
    158   y_dest := 0;
    159   for y_src := 0 to bmp.Height - 1 do
    160   begin
    161     PSrc := bmp.Scanline[y_src];
    162     for yb := 0 to yFactor - 1 do
    163       PDest[yb] := Result.scanLine[y_dest + yb];
    164 
    165     for x_src := 0 to bmp.Width - 1 do
    166     begin
    167       srcColor := PSrc^;
    168       Inc(PSrc);
    169 
    170       for yb := 0 to yFactor - 1 do
    171       begin
    172         temp := PDest[yb];
    173         for xb := 0 to xFactor - 1 do
    174         begin
    175           temp^ := srcColor;
    176           Inc(temp);
    177         end;
    178         PDest[yb] := temp;
    179       end;
    180     end;
    181     Inc(y_dest, yFactor);
    182   end;
    183 
    184   Result.InvalidateBitmap;
    185 end;
    186 
    187 function SimpleStretchLarger(bmp: TBGRADefaultBitmap;
    188   newWidth, newHeight: integer): TBGRADefaultBitmap;
    189 var
    190   x_src, y_src: integer;
    191   inc_x_dest, mod_x_dest, acc_x_dest, inc_y_dest, mod_y_dest, acc_y_dest: integer;
    192   x_dest, y_dest, prev_x_dest, prev_y_dest: integer;
    193 
    194   xb, yb:      integer;
    195   srcColor:    TBGRAPixel;
    196   PDest, PSrc: PBGRAPixel;
    197   delta, lineDelta: integer;
    198 
    199 begin
    200   if (newWidth < bmp.Width) or (newHeight < bmp.Height) then
    201     raise ERangeError.Create('SimpleStretchLarger: New dimensions must be greater or equal ('+IntToStr(bmp.Width)+'x'+IntToStr(bmp.Height)+'->'+IntToStr(newWidth)+'x'+IntToStr(newHeight)+')');
    202 
    203   if ((newWidth div bmp.Width) * bmp.Width = newWidth) and
    204     ((newHeight div bmp.Height) * bmp.Height = newHeight) then
    205   begin
    206     Result := FastSimpleStretchLarger(bmp, newWidth div bmp.Width,
    207       newHeight div bmp.Height);
    208     exit;
    209   end;
    210 
    211   Result := bmp.NewBitmap(NewWidth, NewHeight);
    212   if (newWidth = 0) or (newHeight = 0) then
    213     exit;
    214 
    215   bmp.LoadFromBitmapIfNeeded;
    216 
    217   inc_x_dest := newwidth div bmp.Width;
    218   mod_x_dest := newwidth mod bmp.Width;
    219   inc_y_dest := newheight div bmp.Height;
    220   mod_y_dest := newheight mod bmp.Height;
    221 
    222   y_dest     := 0;
    223   acc_y_dest := bmp.Height div 2;
    224   if Result.LineOrder = riloTopToBottom then
    225     lineDelta := newWidth
    226   else
    227     lineDelta := -newWidth;
    228   for y_src := 0 to bmp.Height - 1 do
    229   begin
    230     prev_y_dest := y_dest;
    231     Inc(y_dest, inc_y_dest);
    232     Inc(acc_y_dest, mod_y_dest);
    233     if acc_y_dest >= bmp.Height then
    234     begin
    235       Dec(acc_y_dest, bmp.Height);
    236       Inc(y_dest);
    237     end;
    238 
    239     PSrc := bmp.Scanline[y_src];
    240 
    241     x_dest     := 0;
    242     acc_x_dest := bmp.Width div 2;
    243     for x_src := 0 to bmp.Width - 1 do
    244     begin
    245       prev_x_dest := x_dest;
    246       Inc(x_dest, inc_x_dest);
    247       Inc(acc_x_dest, mod_x_dest);
    248       if acc_x_dest >= bmp.Width then
    249       begin
    250         Dec(acc_x_dest, bmp.Width);
    251         Inc(x_dest);
    252       end;
    253 
    254       srcColor := PSrc^;
    255       Inc(PSrc);
    256 
    257       PDest := Result.scanline[prev_y_dest] + prev_x_dest;
    258       delta := lineDelta - (x_dest - prev_x_dest);
    259       for yb := prev_y_dest to y_dest - 1 do
    260       begin
    261         for xb := prev_x_dest to x_dest - 1 do
    262         begin
    263           PDest^ := srcColor;
    264           Inc(PDest);
    265         end;
    266         Inc(PDest, delta);
    267       end;
    268     end;
    269   end;
    270   Result.InvalidateBitmap;
    271 end;
    272 
    273 function SimpleStretchSmaller(bmp: TBGRADefaultBitmap;
    274   newWidth, newHeight: integer): TBGRADefaultBitmap;
    275 var
    276   x_dest, y_dest: integer;
    277   inc_x_src, mod_x_src, acc_x_src, inc_y_src, mod_y_src, acc_y_src: integer;
    278   x_src, y_src, prev_x_src, prev_y_src: integer;
    279   x_src2, y_src2: integer;
    280 
    281   xb, yb: integer;
    282   v1, v2, v3, v4, v4shr1: int64;
    283   nb:     integer;
    284   c:      TBGRAPixel;
    285   pdest, psrc: PBGRAPixel;
    286   lineDelta, delta: integer;
    287 begin
    288   if (newWidth > bmp.Width) or (newHeight > bmp.Height) then
    289     raise ERangeError.Create('SimpleStretchSmaller: New dimensions must be smaller or equal ('+IntToStr(bmp.Width)+'x'+IntToStr(bmp.Height)+'->'+IntToStr(newWidth)+'x'+IntToStr(newHeight)+')');
    290   Result := bmp.NewBitmap(NewWidth, NewHeight);
    291   if (newWidth = 0) or (newHeight = 0) or (bmp.Width = 0) or (bmp.Height = 0) then
    292     exit;
    293 
    294   bmp.LoadFromBitmapIfNeeded;
    295 
    296   inc_x_src := bmp.Width div newWidth;
    297   mod_x_src := bmp.Width mod newWidth;
    298   inc_y_src := bmp.Height div newHeight;
    299   mod_y_src := bmp.Height mod newHeight;
    300 
    301   if bmp.lineOrder = riloTopToBottom then
    302     lineDelta := bmp.Width
    303   else
    304     lineDelta := -bmp.Width;
    305 
    306   y_src     := 0;
    307   acc_y_src := 0;
    308   for y_dest := 0 to newHeight - 1 do
    309   begin
    310     PDest := Result.ScanLine[y_dest];
    311 
    312     prev_y_src := y_src;
    313     Inc(y_src, inc_y_src);
    314     Inc(acc_y_src, mod_y_src);
    315     if acc_y_src >= newHeight then
    316     begin
    317       Dec(acc_y_src, newHeight);
    318       Inc(y_src);
    319     end;
    320     if y_src > prev_y_src then
    321       y_src2 := y_src - 1
    322     else
    323       y_src2 := y_src;
    324 
    325     x_src     := 0;
    326     acc_x_src := 0;
    327     for x_dest := 0 to newWidth - 1 do
    328     begin
    329       prev_x_src := x_src;
    330       Inc(x_src, inc_x_src);
    331       Inc(acc_x_src, mod_x_src);
    332       if acc_x_src >= newWidth then
    333       begin
    334         Dec(acc_x_src, newWidth);
    335         Inc(x_src);
    336       end;
    337       if x_src > prev_x_src then
    338         x_src2 := x_src - 1
    339       else
    340         x_src2 := x_src;
    341 
    342       v1    := 0;
    343       v2    := 0;
    344       v3    := 0;
    345       v4    := 0;
    346       nb    := 0;
    347       delta := lineDelta - (x_src2 - prev_x_src + 1);
    348       PSrc  := bmp.Scanline[prev_y_src] + prev_x_src;
    349       for yb := prev_y_src to y_src2 do
    350       begin
    351         for xb := prev_x_src to x_src2 do
    352         begin
    353           c := PSrc^;
    354           Inc(PSrc);
    355                   {$HINTS OFF}
    356           v1 += integer(c.red) * integer(c.alpha);
    357           v2 += integer(c.green) * integer(c.alpha);
    358           v3 += integer(c.blue) * integer(c.alpha);
    359                   {$HINTS ON}
    360           v4 += c.alpha;
    361           Inc(nb);
    362         end;
    363         Inc(PSrc, delta);
    364       end;
    365 
    366       if (v4 <> 0) and (nb <> 0) then
    367       begin
    368         v4shr1  := v4 shr 1;
    369         c.red   := (v1 + v4shr1) div v4;
    370         c.green := (v2 + v4shr1) div v4;
    371         c.blue  := (v3 + v4shr1) div v4;
    372         c.alpha := (v4 + (nb shr 1)) div nb;
    373       end
    374       else
    375       begin
    376         c.alpha := 0;
    377         c.red   := 0;
    378         c.green := 0;
    379         c.blue  := 0;
    380       end;
    381       PDest^ := c;
    382       Inc(PDest);
    383     end;
    384   end;
    385   Result.InvalidateBitmap;
    386 end;
    387 
    388 function FineResampleSmaller(bmp: TBGRADefaultBitmap;
    389   newWidth, newHeight: integer): TBGRADefaultBitmap;
     875function FineResampleSmaller(bmp: TBGRACustomBitmap;
     876  newWidth, newHeight: integer): TBGRACustomBitmap;
    390877var
    391878  yb, xb, yb2, xb2: integer;
     
    5711058end;
    5721059
    573 function FineResample(bmp: TBGRADefaultBitmap;
    574   NewWidth, NewHeight: integer): TBGRADefaultBitmap;
     1060function CreateInterpolator(style: TSplineStyle): TWideKernelFilter;
     1061begin
     1062  case Style of
     1063    ssInside, ssInsideWithEnds: result := TCubicKernel.Create;
     1064    ssCrossing, ssCrossingWithEnds: result := TMitchellKernel.Create;
     1065    ssOutside: result := TSplineKernel.Create(0.5);
     1066    ssRoundOutside: result := TSplineKernel.Create(0.75);
     1067    ssVertexToSide: result := TSplineKernel.Create(1);
     1068  else
     1069    raise Exception.Create('Unknown spline style');
     1070  end;
     1071end;
     1072
     1073function FineResample(bmp: TBGRACustomBitmap;
     1074  NewWidth, NewHeight: integer; ResampleFilter: TResampleFilter): TBGRACustomBitmap;
    5751075var
    576   temp, newtemp: TBGRADefaultBitmap;
    577 begin
     1076  temp, newtemp: TBGRACustomBitmap;
     1077  tempFilter1,tempFilter2: TWideKernelFilter;
     1078begin
     1079  case ResampleFilter of
     1080    rfBicubic: //blur
     1081    begin
     1082      tempFilter1 := TCubicKernel.Create;
     1083      result := WideKernelResample(bmp,NewWidth,NewHeight,tempFilter1,tempFilter1);
     1084      tempFilter1.Free;
     1085      exit;
     1086    end;
     1087    rfMitchell:
     1088    begin
     1089      tempFilter1 := TMitchellKernel.Create;
     1090      result := WideKernelResample(bmp,NewWidth,NewHeight,tempFilter1,tempFilter1);
     1091      tempFilter1.Free;
     1092      exit;
     1093    end;
     1094    rfSpline:
     1095    begin
     1096      tempFilter1 := TSplineKernel.Create;
     1097      result := WideKernelResample(bmp,NewWidth,NewHeight,tempFilter1,tempFilter1);
     1098      tempFilter1.Free;
     1099      exit;
     1100    end;
     1101    rfBestQuality:
     1102    begin
     1103      tempFilter1 := TSplineKernel.Create;
     1104      tempFilter2 := TMitchellKernel.Create;
     1105      result := WideKernelResample(bmp,NewWidth,NewHeight,tempFilter2,tempFilter1);
     1106      tempFilter1.Free;
     1107      tempFilter2.Free;
     1108      exit;
     1109    end;
     1110  end;
     1111
    5781112  if (NewWidth = bmp.Width) and (NewHeight = bmp.Height) then
    5791113    Result := bmp.Duplicate
    5801114  else
    5811115  if (NewWidth >= bmp.Width) and (NewHeight >= bmp.Height) then
    582     Result := FineResampleLarger(bmp, NewWidth, NewHeight)
     1116    Result := FineResampleLarger(bmp, NewWidth, NewHeight, ResampleFilter)
    5831117  else
    5841118  if (NewWidth <= bmp.Width) and (NewHeight <= bmp.Height) then
     
    6061140    if NewWidth > bmp.Width then
    6071141    begin
    608       newtemp := FineResampleLarger(temp, NewWidth, temp.Height);
     1142      newtemp := FineResampleLarger(temp, NewWidth, temp.Height, ResampleFilter);
    6091143      if (temp <> bmp) then
    6101144        temp.Free;
     
    6141148    if NewHeight > bmp.Height then
    6151149    begin
    616       newtemp := FineResampleLarger(temp, temp.Width, NewHeight);
     1150      newtemp := FineResampleLarger(temp, temp.Width, NewHeight, ResampleFilter);
    6171151      if (temp <> bmp) then
    6181152        temp.Free;
     
    6271161end;
    6281162
    629 function SimpleStretch(bmp: TBGRADefaultBitmap;
    630   NewWidth, NewHeight: integer): TBGRADefaultBitmap;
     1163{------------------------ Wide kernel filtering adapted from Graphics32 ---------------------------}
     1164
     1165function Constrain(const Value, Lo, Hi: Integer): Integer;
     1166begin
     1167  if Value < Lo then
     1168        Result := Lo
     1169  else if Value > Hi then
     1170        Result := Hi
     1171  else
     1172        Result := Value;
     1173end;
     1174
     1175type
     1176  TPointRec = record
     1177    Pos: Integer;
     1178    Weight: Single;
     1179  end;
     1180
     1181  TCluster = array of TPointRec;
     1182  TMappingTable = array of TCluster;
     1183
     1184{$warnings off}
     1185function BuildMappingTable(
     1186  DstLo, DstHi: Integer;
     1187  ClipLo, ClipHi: Integer;
     1188  SrcLo, SrcHi: Integer;
     1189  KernelSmaller,KernelLarger: TWideKernelFilter): TMappingTable;
     1190Const FullEdge = false;
    6311191var
    632   temp, newtemp: TBGRADefaultBitmap;
    633 begin
    634   if (NewWidth = bmp.Width) and (NewHeight = bmp.Height) then
    635     Result := bmp.Duplicate
    636   else
    637   if (NewWidth >= bmp.Width) and (NewHeight >= bmp.Height) then
    638     Result := SimpleStretchLarger(bmp, NewWidth, NewHeight)
    639   else
    640   if (NewWidth <= bmp.Width) and (NewHeight <= bmp.Height) then
    641     Result := SimpleStretchSmaller(bmp, NewWidth, NewHeight)
    642   else
    643   begin
    644     temp := bmp;
    645 
    646     if NewWidth < bmp.Width then
    647     begin
    648       newtemp := SimpleStretchSmaller(temp, NewWidth, temp.Height);
    649       if (temp <> bmp) then
    650         temp.Free;
    651       temp := newtemp;
    652     end;
    653 
    654     if NewHeight < bmp.Height then
    655     begin
    656       newtemp := SimpleStretchSmaller(temp, temp.Width, NewHeight);
    657       if (temp <> bmp) then
    658         temp.Free;
    659       temp := newtemp;
    660     end;
    661 
    662     if NewWidth > bmp.Width then
    663     begin
    664       newtemp := SimpleStretchLarger(temp, NewWidth, temp.Height);
    665       if (temp <> bmp) then
    666         temp.Free;
    667       temp := newtemp;
    668     end;
    669 
    670     if NewHeight > bmp.Height then
    671     begin
    672       newtemp := SimpleStretchLarger(temp, temp.Width, NewHeight);
    673       if (temp <> bmp) then
    674         temp.Free;
    675       temp := newtemp;
    676     end;
    677 
    678     if temp <> bmp then
    679       Result := temp
    680     else
    681       Result := bmp.Duplicate;
    682   end;
     1192  SrcW, DstW, ClipW: Integer;
     1193  FilterWidth: Single;
     1194  Scale, OldScale: Single;
     1195  Center: Single;
     1196  Left, Right: Integer;
     1197  I, J, K: Integer;
     1198  Weight: Single;
     1199begin
     1200  SrcW := SrcHi - SrcLo;
     1201  DstW := DstHi - DstLo;
     1202  ClipW := ClipHi - ClipLo;
     1203  if SrcW = 0 then
     1204  begin
     1205    Result := nil;
     1206    Exit;
     1207  end
     1208  else if SrcW = 1 then
     1209  begin
     1210    SetLength(Result, ClipW);
     1211    for I := 0 to ClipW - 1 do
     1212    begin
     1213      SetLength(Result[I], 1);
     1214      Result[I][0].Pos := 0;
     1215      Result[I][0].Weight := 1;
     1216    end;
     1217    Exit;
     1218  end;
     1219  SetLength(Result, ClipW);
     1220  if ClipW = 0 then Exit;
     1221
     1222  if FullEdge then Scale := DstW / SrcW
     1223  else Scale := (DstW - 1) / (SrcW - 1);
     1224
     1225  K := 0;
     1226
     1227  if Scale = 0 then
     1228  begin
     1229    SetLength(Result[0], 1);
     1230    Result[0][0].Pos := (SrcLo + SrcHi) div 2;
     1231    Result[0][0].Weight := 1;
     1232  end
     1233  else if Scale < 1 then
     1234  begin
     1235    FilterWidth := KernelSmaller.KernelWidth;
     1236    OldScale := Scale;
     1237    Scale := 1 / Scale;
     1238    FilterWidth := FilterWidth * Scale;
     1239    for I := 0 to ClipW - 1 do
     1240    begin
     1241      if FullEdge then
     1242        Center := SrcLo - 0.5 + (I - DstLo + ClipLo + 0.5) * Scale
     1243      else
     1244        Center := SrcLo + (I - DstLo + ClipLo) * Scale;
     1245      Left := Floor(Center - FilterWidth);
     1246      Right := Ceil(Center + FilterWidth);
     1247      for J := Left to Right do
     1248      begin
     1249        Weight := KernelSmaller.Interpolation((Center - J) * OldScale) * OldScale;
     1250        if Weight <> 0 then
     1251        begin
     1252          K := Length(Result[I]);
     1253          SetLength(Result[I], K + 1);
     1254          Result[I][K].Pos := Constrain(J, SrcLo, SrcHi - 1);
     1255          Result[I][K].Weight := Weight;
     1256        end;
     1257      end;
     1258      if Length(Result[I]) = 0 then
     1259      begin
     1260        SetLength(Result[I], 1);
     1261        Result[I][0].Pos := Floor(Center);
     1262        Result[I][0].Weight := 1;
     1263      end;
     1264    end;
     1265  end
     1266  else // scale > 1
     1267  begin
     1268    FilterWidth := KernelLarger.KernelWidth;
     1269    Scale := 1 / Scale;
     1270    for I := 0 to ClipW - 1 do
     1271    begin
     1272      if FullEdge then
     1273        Center := SrcLo - 0.5 + (I - DstLo + ClipLo + 0.5) * Scale
     1274      else
     1275        Center := SrcLo + (I - DstLo + ClipLo) * Scale;
     1276      Left := Floor(Center - FilterWidth);
     1277      Right := Ceil(Center + FilterWidth);
     1278      for J := Left to Right do
     1279      begin
     1280        Weight := KernelLarger.Interpolation(Center - j);
     1281        if Weight <> 0 then
     1282        begin
     1283          K := Length(Result[I]);
     1284          SetLength(Result[I], k + 1);
     1285          Result[I][K].Pos := Constrain(j, SrcLo, SrcHi - 1);
     1286          Result[I][K].Weight := Weight;
     1287        end;
     1288      end;
     1289    end;
     1290  end;
     1291end;
     1292{$warnings on}
     1293
     1294function WideKernelResample(bmp: TBGRACustomBitmap;
     1295  NewWidth, NewHeight: integer; ResampleFilterSmaller, ResampleFilterLarger: TWideKernelFilter): TBGRACustomBitmap;
     1296type
     1297  TSum = record
     1298    sumR,sumG,sumB,sumA: single;
     1299  end;
     1300
     1301var
     1302  mapX,mapY: TMappingTable;
     1303  xb,yb,xc,yc,MapXLoPos,MapXHiPos: integer;
     1304  clusterX,clusterY: TCluster;
     1305  verticalSum: array of TSum;
     1306  scanlinesSrc: array of PBGRAPixel;
     1307  sum: TSum;
     1308  c: TBGRAPixel;
     1309  w,wa: single;
     1310  pdest: PBGRAPixel;
     1311begin
     1312  result := bmp.NewBitmap(NewWidth,NewHeight);
     1313  if (NewWidth=0) or (NewHeight=0) then exit;
     1314  mapX := BuildMappingTable(0,NewWidth,0,NewWidth,0,bmp.Width,ResampleFilterSmaller,ResampleFilterLarger);
     1315  mapY := BuildMappingTable(0,NewHeight,0,NewHeight,0,bmp.Height,ResampleFilterSmaller,ResampleFilterLarger);
     1316
     1317  MapXLoPos := MapX[0][0].Pos;
     1318  MapXHiPos := MapX[NewWidth - 1][High(MapX[NewWidth - 1])].Pos;
     1319
     1320  setlength(verticalSum, MapXHiPos-MapXLoPos+1);
     1321
     1322  setlength(scanlinesSrc, bmp.Height);
     1323  for yb := 0 to bmp.Height-1 do
     1324    scanlinesSrc[yb] := bmp.ScanLine[yb];
     1325
     1326  for yb := 0 to NewHeight-1 do
     1327  begin
     1328    clusterY := mapY[yb];
     1329
     1330    for xb := MapXLoPos to MapXHiPos do
     1331    begin
     1332      fillchar(verticalSum[xb - MapXLoPos],sizeof(verticalSum[xb - MapXLoPos]),0);
     1333      for yc := 0 to high(clusterY) do
     1334      with verticalSum[xb - MapXLoPos] do
     1335      begin
     1336        c := (scanlinesSrc[clusterY[yc].Pos]+xb)^;
     1337        w := clusterY[yc].Weight;
     1338        wa := w * c.alpha;
     1339        sumA += wa;
     1340        sumR += c.red * wa;
     1341        sumG += c.green * wa;
     1342        sumB += c.blue * wa;
     1343      end;
     1344    end;
     1345
     1346    pdest := result.Scanline[yb];
     1347
     1348    for xb := 0 to NewWidth-1 do
     1349    begin
     1350      clusterX := mapX[xb];
     1351      {$hints off}
     1352      fillchar(sum,sizeof(sum),0);
     1353      {$hints on}
     1354      for xc := 0 to high(clusterX) do
     1355      begin
     1356        w := clusterX[xc].Weight;
     1357        with verticalSum[ClusterX[xc].Pos - MapXLoPos] do
     1358        begin
     1359          sum.sumA += sumA*w;
     1360          sum.sumR += sumR*w;
     1361          sum.sumG += sumG*w;
     1362          sum.sumB += sumB*w;
     1363        end;
     1364      end;
     1365
     1366      if sum.sumA < 0.5 then
     1367        pdest^ := BGRAPixelTransparent else
     1368      begin
     1369        c.red := constrain(round(sum.sumR/sum.sumA),0,255);
     1370        c.green := constrain(round(sum.sumG/sum.sumA),0,255);
     1371        c.blue := constrain(round(sum.sumB/sum.sumA),0,255);
     1372        if sum.sumA > 255 then
     1373          c.alpha := 255 else
     1374          c.alpha := round(sum.sumA);
     1375        pdest^ := c;
     1376      end;
     1377      inc(pdest);
     1378    end;
     1379  end;
     1380
    6831381end;
    6841382
  • GraphicTest/BGRABitmap/readme.txt

    r210 r317  
    1 BGRABitmap v2.2 - Drawing routines with alpha blending and antialiasing with Lazarus.
     1BGRABitmap v5.5 - Drawing routines with alpha blending and antialiasing with Lazarus.
    22
    33These routines allow to manipulate 32bit images in BGRA format.
  • GraphicTest/GraphicTest.lpi

    r222 r317  
    22<CONFIG>
    33  <ProjectOptions>
    4     <Version Value="7"/>
     4    <Version Value="9"/>
    55    <General>
    66      <MainUnit Value="0"/>
    7       <TargetFileExt Value=".exe"/>
     7      <UseXPManifest Value="True"/>
    88      <Icon Value="0"/>
    9       <UseXPManifest Value="True"/>
    10       <ActiveEditorIndexAtStart Value="2"/>
     9      <ActiveWindowIndexAtStart Value="0"/>
    1110    </General>
     11    <BuildModes Count="1">
     12      <Item1 Name="default" Default="True"/>
     13    </BuildModes>
    1214    <PublishOptions>
    1315      <Version Value="2"/>
     
    2123      </local>
    2224    </RunParams>
    23     <RequiredPackages Count="2">
     25    <RequiredPackages Count="3">
    2426      <Item1>
    25         <PackageName Value="lazopenglcontext"/>
     27        <PackageName Value="bgrabitmappack"/>
    2628      </Item1>
    2729      <Item2>
     30        <PackageName Value="lazopenglcontext"/>
     31      </Item2>
     32      <Item3>
    2833        <PackageName Value="LCL"/>
    29       </Item2>
     34      </Item3>
    3035    </RequiredPackages>
    31     <Units Count="50">
     36    <Units Count="61">
    3237      <Unit0>
    3338        <Filename Value="GraphicTest.lpr"/>
    3439        <IsPartOfProject Value="True"/>
    3540        <UnitName Value="GraphicTest"/>
     41        <TopLine Value="1"/>
    3642        <CursorPos X="51" Y="15"/>
    37         <TopLine Value="1"/>
    38         <UsageCount Value="56"/>
     43        <UsageCount Value="58"/>
    3944      </Unit0>
    4045      <Unit1>
     
    4449        <ResourceBaseClass Value="Form"/>
    4550        <UnitName Value="UMainForm"/>
    46         <CursorPos X="3" Y="188"/>
    47         <TopLine Value="186"/>
     51        <IsVisibleTab Value="True"/>
    4852        <EditorIndex Value="0"/>
    49         <UsageCount Value="56"/>
    50         <Loaded Value="True"/>
     53        <WindowIndex Value="0"/>
     54        <TopLine Value="118"/>
     55        <CursorPos X="32" Y="135"/>
     56        <UsageCount Value="58"/>
     57        <Loaded Value="True"/>
     58        <LoadedDesigner Value="True"/>
    5159      </Unit1>
    5260      <Unit2>
    5361        <Filename Value="StopWatch.pas"/>
    5462        <UnitName Value="StopWatch"/>
     63        <TopLine Value="1"/>
    5564        <CursorPos X="42" Y="22"/>
    56         <TopLine Value="1"/>
    5765        <UsageCount Value="15"/>
    5866      </Unit2>
     
    6169        <IsPartOfProject Value="True"/>
    6270        <UnitName Value="UPlatform"/>
     71        <TopLine Value="1"/>
    6372        <CursorPos X="1" Y="1"/>
    64         <TopLine Value="1"/>
    65         <UsageCount Value="56"/>
     73        <UsageCount Value="58"/>
    6674      </Unit3>
    6775      <Unit4>
    6876        <Filename Value="../../lazarus/lcl/intfgraphics.pas"/>
    6977        <UnitName Value="IntfGraphics"/>
     78        <TopLine Value="244"/>
    7079        <CursorPos X="49" Y="262"/>
    71         <TopLine Value="244"/>
    7280        <UsageCount Value="9"/>
    7381      </Unit4>
     
    7583        <Filename Value="/usr/share/fpcsrc/2.4.0/packages/fcl-image/src/fpimage.pp"/>
    7684        <UnitName Value="FPimage"/>
     85        <TopLine Value="121"/>
    7786        <CursorPos X="57" Y="142"/>
    78         <TopLine Value="121"/>
    7987        <UsageCount Value="9"/>
    8088      </Unit5>
    8189      <Unit6>
    8290        <Filename Value="../../lazarus/lcl/include/lclintfh.inc"/>
     91        <TopLine Value="85"/>
    8392        <CursorPos X="10" Y="102"/>
    84         <TopLine Value="85"/>
    8593        <UsageCount Value="9"/>
    8694      </Unit6>
    8795      <Unit7>
    8896        <Filename Value="../../lazarus/lcl/include/lclintf.inc"/>
     97        <TopLine Value="153"/>
    8998        <CursorPos X="1" Y="160"/>
    90         <TopLine Value="153"/>
    9199        <UsageCount Value="9"/>
    92100      </Unit7>
     
    94102        <Filename Value="../../lazarus/lcl/graphics.pp"/>
    95103        <UnitName Value="Graphics"/>
     104        <TopLine Value="1282"/>
    96105        <CursorPos X="15" Y="1299"/>
    97         <TopLine Value="1282"/>
    98106        <UsageCount Value="9"/>
    99107      </Unit8>
    100108      <Unit9>
    101109        <Filename Value="../../lazarus/lcl/include/rasterimage.inc"/>
     110        <TopLine Value="546"/>
    102111        <CursorPos X="11" Y="553"/>
    103         <TopLine Value="546"/>
    104112        <UsageCount Value="9"/>
    105113      </Unit9>
    106114      <Unit10>
    107115        <Filename Value="../../lazarus/lcl/include/picture.inc"/>
     116        <TopLine Value="389"/>
    108117        <CursorPos X="1" Y="411"/>
    109         <TopLine Value="389"/>
    110118        <UsageCount Value="6"/>
    111119      </Unit10>
    112120      <Unit11>
    113121        <Filename Value="../../lazarus/lcl/interfaces/gtk2/gtk2lclintf.inc"/>
     122        <TopLine Value="444"/>
    114123        <CursorPos X="1" Y="461"/>
    115         <TopLine Value="444"/>
    116124        <UsageCount Value="9"/>
    117125      </Unit11>
    118126      <Unit12>
    119127        <Filename Value="/usr/share/fpcsrc/2.4.0/packages/gtk2/src/gtk+/gdk/gdkimage.inc"/>
     128        <TopLine Value="14"/>
    120129        <CursorPos X="24" Y="21"/>
    121         <TopLine Value="14"/>
    122130        <UsageCount Value="9"/>
    123131      </Unit12>
    124132      <Unit13>
    125133        <Filename Value="/usr/share/fpcsrc/2.4.0/packages/fcl-image/src/fpimage.inc"/>
     134        <TopLine Value="313"/>
    126135        <CursorPos X="24" Y="316"/>
    127         <TopLine Value="313"/>
    128136        <UsageCount Value="9"/>
    129137      </Unit13>
    130138      <Unit14>
    131139        <Filename Value="/usr/share/fpcsrc/2.4.0/packages/fcl-image/src/fppalette.inc"/>
     140        <TopLine Value="149"/>
    132141        <CursorPos X="3" Y="151"/>
    133         <TopLine Value="149"/>
    134142        <UsageCount Value="9"/>
    135143      </Unit14>
     
    137145        <Filename Value="../../lazarus/lcl/graphtype.pp"/>
    138146        <UnitName Value="GraphType"/>
     147        <TopLine Value="171"/>
    139148        <CursorPos X="3" Y="188"/>
    140         <TopLine Value="171"/>
    141149        <UsageCount Value="8"/>
    142150      </Unit15>
    143151      <Unit16>
    144152        <Filename Value="/usr/share/fpcsrc/2.4.0/rtl/inc/systemh.inc"/>
     153        <TopLine Value="496"/>
    145154        <CursorPos X="11" Y="519"/>
    146         <TopLine Value="496"/>
    147155        <UsageCount Value="13"/>
    148156      </Unit16>
     
    151159        <IsPartOfProject Value="True"/>
    152160        <UnitName Value="UDrawMethod"/>
    153         <CursorPos X="29" Y="244"/>
    154         <TopLine Value="237"/>
    155161        <EditorIndex Value="2"/>
    156         <UsageCount Value="50"/>
     162        <WindowIndex Value="0"/>
     163        <TopLine Value="690"/>
     164        <CursorPos X="3" Y="709"/>
     165        <UsageCount Value="52"/>
    157166        <Loaded Value="True"/>
    158167      </Unit17>
     
    161170        <IsPartOfProject Value="True"/>
    162171        <UnitName Value="UFastBitmap"/>
    163         <CursorPos X="19" Y="110"/>
    164         <TopLine Value="101"/>
    165172        <EditorIndex Value="1"/>
    166         <UsageCount Value="50"/>
     173        <WindowIndex Value="0"/>
     174        <TopLine Value="185"/>
     175        <CursorPos X="39" Y="198"/>
     176        <UsageCount Value="52"/>
    167177        <Loaded Value="True"/>
    168178      </Unit18>
    169179      <Unit19>
    170         <Filename Value="../../../Projekty2/FreePascalManager/trunk/Instance/1/Lazarus/lcl/include/rasterimage.inc"/>
     180        <Filename Value="../../FreePascalManager/trunk/Instance/1/Lazarus/lcl/include/rasterimage.inc"/>
     181        <TopLine Value="292"/>
    171182        <CursorPos X="1" Y="308"/>
    172         <TopLine Value="292"/>
    173183        <UsageCount Value="12"/>
    174184      </Unit19>
    175185      <Unit20>
    176         <Filename Value="bgrabitmap/bgradefaultbitmap.pas"/>
     186        <Filename Value="BGRABitmap/bgradefaultbitmap.pas"/>
    177187        <UnitName Value="BGRADefaultBitmap"/>
    178         <CursorPos X="57" Y="292"/>
    179         <TopLine Value="279"/>
    180         <UsageCount Value="10"/>
     188        <EditorIndex Value="13"/>
     189        <WindowIndex Value="0"/>
     190        <TopLine Value="655"/>
     191        <CursorPos X="25" Y="666"/>
     192        <UsageCount Value="11"/>
     193        <Loaded Value="True"/>
    181194      </Unit20>
    182195      <Unit21>
    183196        <Filename Value="bgrabitmap/bgrawinbitmap.pas"/>
    184197        <UnitName Value="BGRAWinBitmap"/>
     198        <TopLine Value="133"/>
    185199        <CursorPos X="1" Y="146"/>
    186         <TopLine Value="133"/>
    187200        <UsageCount Value="10"/>
    188201      </Unit21>
    189202      <Unit22>
    190         <Filename Value="../../../Projekty2/FreePascalManager/trunk/Instance/1/Lazarus/lcl/extctrls.pp"/>
     203        <Filename Value="../../FreePascalManager/trunk/Instance/1/Lazarus/lcl/extctrls.pp"/>
    191204        <UnitName Value="ExtCtrls"/>
     205        <TopLine Value="584"/>
    192206        <CursorPos X="3" Y="597"/>
    193         <TopLine Value="584"/>
    194207        <UsageCount Value="9"/>
    195208      </Unit22>
    196209      <Unit23>
    197         <Filename Value="../../../Projekty2/FreePascalManager/trunk/Instance/1/Lazarus/lcl/include/winapih.inc"/>
     210        <Filename Value="../../FreePascalManager/trunk/Instance/1/Lazarus/lcl/include/winapih.inc"/>
     211        <TopLine Value="32"/>
    198212        <CursorPos X="10" Y="45"/>
    199         <TopLine Value="32"/>
    200213        <UsageCount Value="11"/>
    201214      </Unit23>
    202215      <Unit24>
    203         <Filename Value="../../../Projekty2/FreePascalManager/trunk/Instance/1/Lazarus/lcl/include/winapi.inc"/>
     216        <Filename Value="../../FreePascalManager/trunk/Instance/1/Lazarus/lcl/include/winapi.inc"/>
     217        <TopLine Value="51"/>
    204218        <CursorPos X="3" Y="53"/>
    205         <TopLine Value="51"/>
    206219        <UsageCount Value="11"/>
    207220      </Unit24>
    208221      <Unit25>
    209         <Filename Value="../../../Projekty2/FreePascalManager/trunk/Instance/1/Lazarus/lcl/graphics.pp"/>
     222        <Filename Value="../../FreePascalManager/trunk/Instance/1/Lazarus/lcl/graphics.pp"/>
    210223        <UnitName Value="Graphics"/>
     224        <TopLine Value="1314"/>
    211225        <CursorPos X="31" Y="1327"/>
    212         <TopLine Value="1314"/>
    213226        <UsageCount Value="11"/>
    214227      </Unit25>
    215228      <Unit26>
    216         <Filename Value="../../../Projekty2/FreePascalManager/trunk/Instance/1/FPC/rtl/objpas/classes/classesh.inc"/>
     229        <Filename Value="../../FreePascalManager/trunk/Instance/1/FPC/rtl/objpas/classes/classesh.inc"/>
     230        <TopLine Value="1883"/>
    217231        <CursorPos X="10" Y="1896"/>
    218         <TopLine Value="1883"/>
    219232        <UsageCount Value="11"/>
    220233      </Unit26>
    221234      <Unit27>
    222         <Filename Value="../../../Projekty2/FreePascalManager/trunk/Instance/1/FPC/rtl/inc/heaph.inc"/>
     235        <Filename Value="../../FreePascalManager/trunk/Instance/1/FPC/rtl/inc/heaph.inc"/>
     236        <TopLine Value="75"/>
    223237        <CursorPos X="31" Y="88"/>
    224         <TopLine Value="75"/>
    225238        <UsageCount Value="9"/>
    226239      </Unit27>
    227240      <Unit28>
    228         <Filename Value="../../../Projekty2/FreePascalManager/trunk/Instance/1/FPC/rtl/inc/heap.inc"/>
     241        <Filename Value="../../FreePascalManager/trunk/Instance/1/FPC/rtl/inc/heap.inc"/>
     242        <TopLine Value="309"/>
    229243        <CursorPos X="3" Y="311"/>
    230         <TopLine Value="309"/>
    231244        <UsageCount Value="8"/>
    232245      </Unit28>
     
    234247        <Filename Value="bgrabitmap/bgrabitmaptypes.pas"/>
    235248        <UnitName Value="BGRABitmapTypes"/>
     249        <TopLine Value="24"/>
    236250        <CursorPos X="3" Y="37"/>
    237         <TopLine Value="24"/>
    238251        <UsageCount Value="10"/>
    239252      </Unit29>
    240253      <Unit30>
    241         <Filename Value="../../../Projekty2/FreePascalManager/trunk/Instance/1/Lazarus/lcl/graphtype.pp"/>
     254        <Filename Value="../../FreePascalManager/trunk/Instance/1/Lazarus/lcl/graphtype.pp"/>
    242255        <UnitName Value="GraphType"/>
     256        <TopLine Value="271"/>
    243257        <CursorPos X="23" Y="292"/>
    244         <TopLine Value="271"/>
    245258        <UsageCount Value="9"/>
    246259      </Unit30>
     
    248261        <Filename Value="UBitmaps.pas"/>
    249262        <UnitName Value="UBitmaps"/>
     263        <TopLine Value="1"/>
    250264        <CursorPos X="41" Y="62"/>
    251         <TopLine Value="1"/>
    252265        <UsageCount Value="18"/>
    253266      </Unit31>
    254267      <Unit32>
    255         <Filename Value="../../../Projekty2/FreePascalManager/trunk/Instance/1/FPC/packages/fcl-image/src/fpimage.pp"/>
     268        <Filename Value="../../FreePascalManager/trunk/Instance/1/FPC/packages/fcl-image/src/fpimage.pp"/>
    256269        <UnitName Value="FPimage"/>
     270        <TopLine Value="23"/>
    257271        <CursorPos X="4" Y="35"/>
    258         <TopLine Value="23"/>
    259272        <UsageCount Value="8"/>
    260273      </Unit32>
    261274      <Unit33>
    262         <Filename Value="../../../Projekty2/FreePascalManager/trunk/Instance/1/Lazarus/lcl/include/canvas.inc"/>
     275        <Filename Value="../../FreePascalManager/trunk/Instance/1/Lazarus/lcl/include/canvas.inc"/>
     276        <TopLine Value="1456"/>
    263277        <CursorPos X="1" Y="1471"/>
    264         <TopLine Value="1456"/>
    265278        <UsageCount Value="8"/>
    266279      </Unit33>
    267280      <Unit34>
    268         <Filename Value="../../../Projekty2/FreePascalManager/trunk/Instance/1/FPC/rtl/win/wininc/func.inc"/>
     281        <Filename Value="../../FreePascalManager/trunk/Instance/1/FPC/rtl/win/wininc/func.inc"/>
     282        <TopLine Value="780"/>
    269283        <CursorPos X="10" Y="793"/>
    270         <TopLine Value="780"/>
    271284        <UsageCount Value="8"/>
    272285      </Unit34>
     
    274287        <Filename Value="bgrabitmap/bgrablend.pas"/>
    275288        <UnitName Value="BGRABlend"/>
     289        <TopLine Value="217"/>
    276290        <CursorPos X="3" Y="219"/>
    277         <TopLine Value="217"/>
    278291        <UsageCount Value="8"/>
    279292      </Unit35>
     
    281294        <Filename Value="BGRABitmap/bgrabitmap.pas"/>
    282295        <UnitName Value="BGRABitmap"/>
     296        <TopLine Value="52"/>
    283297        <CursorPos X="23" Y="72"/>
    284         <TopLine Value="52"/>
    285298        <UsageCount Value="18"/>
    286299      </Unit36>
     
    288301        <Filename Value="BGRABitmap/bgragtkbitmap.pas"/>
    289302        <UnitName Value="BGRAGtkBitmap"/>
     303        <TopLine Value="29"/>
    290304        <CursorPos X="36" Y="36"/>
    291         <TopLine Value="29"/>
    292305        <UsageCount Value="18"/>
    293306      </Unit37>
     
    295308        <Filename Value="BGRABitmap/bgraresample.pas"/>
    296309        <UnitName Value="bgraresample"/>
     310        <TopLine Value="629"/>
    297311        <CursorPos X="30" Y="638"/>
    298         <TopLine Value="629"/>
    299312        <UsageCount Value="18"/>
    300313      </Unit38>
     
    302315        <Filename Value="../../../lazarus/components/opengl/glqtcontext.pas"/>
    303316        <UnitName Value="GLQTContext"/>
     317        <TopLine Value="1"/>
    304318        <CursorPos X="1" Y="1"/>
    305         <TopLine Value="1"/>
    306319        <UsageCount Value="18"/>
    307320      </Unit39>
     
    309322        <Filename Value="../../../lazarus/components/opengl/openglcontext.pas"/>
    310323        <UnitName Value="OpenGLContext"/>
     324        <TopLine Value="135"/>
    311325        <CursorPos X="34" Y="152"/>
    312         <TopLine Value="135"/>
    313326        <UsageCount Value="18"/>
    314327      </Unit40>
     
    316329        <Filename Value="../../../lazarus/components/opengl/glgtkglxcontext.pas"/>
    317330        <UnitName Value="GLGtkGlxContext"/>
     331        <TopLine Value="699"/>
    318332        <CursorPos X="3" Y="704"/>
    319         <TopLine Value="699"/>
    320333        <UsageCount Value="18"/>
    321334      </Unit41>
     
    323336        <Filename Value="/usr/share/fpcsrc/2.4.0/packages/opengl/src/gl.pp"/>
    324337        <UnitName Value="GL"/>
     338        <TopLine Value="1502"/>
    325339        <CursorPos X="3" Y="1499"/>
    326         <TopLine Value="1502"/>
    327340        <UsageCount Value="18"/>
    328341      </Unit42>
    329342      <Unit43>
    330343        <Filename Value="../../../lazarus/lcl/include/customform.inc"/>
     344        <TopLine Value="898"/>
    331345        <CursorPos X="38" Y="928"/>
    332         <TopLine Value="898"/>
    333346        <UsageCount Value="17"/>
    334347      </Unit43>
    335348      <Unit44>
    336349        <Filename Value="/usr/share/fpcsrc/2.4.0/rtl/inc/heaph.inc"/>
     350        <TopLine Value="63"/>
    337351        <CursorPos X="43" Y="80"/>
    338         <TopLine Value="63"/>
    339352        <UsageCount Value="9"/>
    340353      </Unit44>
    341354      <Unit45>
    342355        <Filename Value="../../../lazarus/lcl/include/custombitmap.inc"/>
     356        <TopLine Value="21"/>
    343357        <CursorPos X="1" Y="38"/>
    344         <TopLine Value="21"/>
    345358        <UsageCount Value="9"/>
    346359      </Unit45>
     
    348361        <Filename Value="/usr/share/fpcsrc/2.4.0/packages/opengl/src/glext.pp"/>
    349362        <UnitName Value="GLext"/>
     363        <TopLine Value="2783"/>
    350364        <CursorPos X="15" Y="2800"/>
    351         <TopLine Value="2783"/>
    352365        <UsageCount Value="15"/>
    353366      </Unit46>
    354367      <Unit47>
    355368        <Filename Value="/usr/share/fpcsrc/2.4.0/rtl/i386/i386.inc"/>
     369        <TopLine Value="185"/>
    356370        <CursorPos X="11" Y="202"/>
    357         <TopLine Value="185"/>
    358371        <UsageCount Value="13"/>
    359372      </Unit47>
    360373      <Unit48>
    361374        <Filename Value="/usr/share/fpcsrc/2.4.0/rtl/inc/generic.inc"/>
     375        <TopLine Value="245"/>
    362376        <CursorPos X="3" Y="250"/>
    363         <TopLine Value="245"/>
    364377        <UsageCount Value="13"/>
    365378      </Unit48>
    366379      <Unit49>
    367380        <Filename Value="/usr/share/fpcsrc/2.4.0/rtl/inc/system.inc"/>
     381        <TopLine Value="188"/>
    368382        <CursorPos X="3" Y="190"/>
    369         <TopLine Value="188"/>
    370383        <UsageCount Value="13"/>
    371384      </Unit49>
     385      <Unit50>
     386        <Filename Value="../../../Lazarus/0.9.31_2.6.0/fpc/2.6.0/source/rtl/inc/mathh.inc"/>
     387        <EditorIndex Value="14"/>
     388        <WindowIndex Value="0"/>
     389        <TopLine Value="65"/>
     390        <CursorPos X="14" Y="78"/>
     391        <UsageCount Value="11"/>
     392        <Loaded Value="True"/>
     393      </Unit50>
     394      <Unit51>
     395        <Filename Value="../../../Lazarus/0.9.31_2.6.0/components/opengl/openglcontext.pas"/>
     396        <UnitName Value="OpenGLContext"/>
     397        <EditorIndex Value="9"/>
     398        <WindowIndex Value="0"/>
     399        <TopLine Value="387"/>
     400        <CursorPos X="3" Y="389"/>
     401        <UsageCount Value="11"/>
     402        <Loaded Value="True"/>
     403      </Unit51>
     404      <Unit52>
     405        <Filename Value="../../../Lazarus/0.9.31_2.6.0/components/opengl/glwin32wglcontext.pas"/>
     406        <UnitName Value="GLWin32WGLContext"/>
     407        <EditorIndex Value="10"/>
     408        <WindowIndex Value="0"/>
     409        <TopLine Value="236"/>
     410        <CursorPos X="3" Y="240"/>
     411        <UsageCount Value="11"/>
     412        <Loaded Value="True"/>
     413      </Unit52>
     414      <Unit53>
     415        <Filename Value="../../../Lazarus/0.9.31_2.6.0/fpc/2.6.0/source/rtl/win/wininc/func.inc"/>
     416        <EditorIndex Value="12"/>
     417        <WindowIndex Value="0"/>
     418        <TopLine Value="988"/>
     419        <CursorPos X="10" Y="1001"/>
     420        <UsageCount Value="11"/>
     421        <Loaded Value="True"/>
     422      </Unit53>
     423      <Unit54>
     424        <Filename Value="../../../Lazarus/0.9.31_2.6.0/fpc/2.6.0/source/rtl/win/wininc/ascdef.inc"/>
     425        <EditorIndex Value="11"/>
     426        <WindowIndex Value="0"/>
     427        <TopLine Value="236"/>
     428        <CursorPos X="10" Y="249"/>
     429        <UsageCount Value="11"/>
     430        <Loaded Value="True"/>
     431      </Unit54>
     432      <Unit55>
     433        <Filename Value="../../../Lazarus/0.9.31_2.6.0/fpc/2.6.0/source/rtl/objpas/objpas.pp"/>
     434        <UnitName Value="objpas"/>
     435        <EditorIndex Value="8"/>
     436        <WindowIndex Value="0"/>
     437        <TopLine Value="15"/>
     438        <CursorPos X="8" Y="28"/>
     439        <UsageCount Value="11"/>
     440        <Loaded Value="True"/>
     441      </Unit55>
     442      <Unit56>
     443        <Filename Value="../../../Lazarus/0.9.31_2.6.0/lcl/graphics.pp"/>
     444        <UnitName Value="Graphics"/>
     445        <EditorIndex Value="4"/>
     446        <WindowIndex Value="0"/>
     447        <TopLine Value="1292"/>
     448        <CursorPos X="15" Y="1305"/>
     449        <UsageCount Value="11"/>
     450        <Loaded Value="True"/>
     451      </Unit56>
     452      <Unit57>
     453        <Filename Value="../../../Lazarus/0.9.31_2.6.0/lcl/include/rasterimage.inc"/>
     454        <EditorIndex Value="5"/>
     455        <WindowIndex Value="0"/>
     456        <TopLine Value="247"/>
     457        <CursorPos X="1" Y="260"/>
     458        <UsageCount Value="11"/>
     459        <Loaded Value="True"/>
     460      </Unit57>
     461      <Unit58>
     462        <Filename Value="../../../Lazarus/0.9.31_2.6.0/fpc/2.6.0/source/rtl/inc/systemh.inc"/>
     463        <EditorIndex Value="3"/>
     464        <WindowIndex Value="0"/>
     465        <TopLine Value="501"/>
     466        <CursorPos X="11" Y="514"/>
     467        <UsageCount Value="11"/>
     468        <Loaded Value="True"/>
     469      </Unit58>
     470      <Unit59>
     471        <Filename Value="../../../Lazarus/0.9.31_2.6.0/lcl/include/custombitmap.inc"/>
     472        <EditorIndex Value="7"/>
     473        <WindowIndex Value="0"/>
     474        <TopLine Value="403"/>
     475        <CursorPos X="1" Y="416"/>
     476        <UsageCount Value="10"/>
     477        <Loaded Value="True"/>
     478      </Unit59>
     479      <Unit60>
     480        <Filename Value="../../../Lazarus/0.9.31_2.6.0/lcl/include/bitmapcanvas.inc"/>
     481        <EditorIndex Value="6"/>
     482        <WindowIndex Value="0"/>
     483        <TopLine Value="90"/>
     484        <CursorPos X="1" Y="103"/>
     485        <UsageCount Value="10"/>
     486        <Loaded Value="True"/>
     487      </Unit60>
    372488    </Units>
    373489    <JumpHistory Count="30" HistoryIndex="29">
    374490      <Position1>
    375         <Filename Value="UDrawMethod.pas"/>
    376         <Caret Line="248" Column="1" TopLine="224"/>
     491        <Filename Value="UMainForm.pas"/>
     492        <Caret Line="233" Column="30" TopLine="210"/>
    377493      </Position1>
    378494      <Position2>
    379         <Filename Value="UDrawMethod.pas"/>
    380         <Caret Line="250" Column="1" TopLine="224"/>
     495        <Filename Value="UMainForm.pas"/>
     496        <Caret Line="117" Column="1" TopLine="112"/>
    381497      </Position2>
    382498      <Position3>
    383         <Filename Value="UDrawMethod.pas"/>
    384         <Caret Line="251" Column="1" TopLine="224"/>
     499        <Filename Value="UMainForm.pas"/>
     500        <Caret Line="190" Column="12" TopLine="178"/>
    385501      </Position3>
    386502      <Position4>
    387         <Filename Value="UDrawMethod.pas"/>
    388         <Caret Line="254" Column="1" TopLine="226"/>
     503        <Filename Value="UMainForm.pas"/>
     504        <Caret Line="145" Column="21" TopLine="138"/>
    389505      </Position4>
    390506      <Position5>
    391         <Filename Value="UDrawMethod.pas"/>
    392         <Caret Line="256" Column="1" TopLine="228"/>
     507        <Filename Value="UMainForm.pas"/>
     508        <Caret Line="142" Column="1" TopLine="137"/>
    393509      </Position5>
    394510      <Position6>
    395         <Filename Value="UDrawMethod.pas"/>
    396         <Caret Line="257" Column="1" TopLine="229"/>
     511        <Filename Value="UMainForm.pas"/>
     512        <Caret Line="192" Column="14" TopLine="187"/>
    397513      </Position6>
    398514      <Position7>
    399         <Filename Value="UDrawMethod.pas"/>
    400         <Caret Line="105" Column="30" TopLine="98"/>
     515        <Filename Value="UMainForm.pas"/>
     516        <Caret Line="199" Column="1" TopLine="184"/>
    401517      </Position7>
    402518      <Position8>
    403         <Filename Value="UDrawMethod.pas"/>
    404         <Caret Line="260" Column="97" TopLine="233"/>
     519        <Filename Value="UMainForm.pas"/>
     520        <Caret Line="156" Column="1" TopLine="143"/>
    405521      </Position8>
    406522      <Position9>
    407         <Filename Value="UDrawMethod.pas"/>
    408         <Caret Line="237" Column="1" TopLine="218"/>
     523        <Filename Value="UMainForm.pas"/>
     524        <Caret Line="189" Column="82" TopLine="177"/>
    409525      </Position9>
    410526      <Position10>
    411         <Filename Value="UDrawMethod.pas"/>
    412         <Caret Line="224" Column="54" TopLine="207"/>
     527        <Filename Value="UMainForm.pas"/>
     528        <Caret Line="144" Column="43" TopLine="136"/>
    413529      </Position10>
    414530      <Position11>
    415         <Filename Value="UDrawMethod.pas"/>
    416         <Caret Line="237" Column="1" TopLine="220"/>
     531        <Filename Value="UMainForm.pas"/>
     532        <Caret Line="185" Column="20" TopLine="183"/>
    417533      </Position11>
    418534      <Position12>
    419         <Filename Value="UDrawMethod.pas"/>
    420         <Caret Line="240" Column="26" TopLine="223"/>
     535        <Filename Value="UMainForm.pas"/>
     536        <Caret Line="191" Column="3" TopLine="189"/>
    421537      </Position12>
    422538      <Position13>
    423         <Filename Value="UDrawMethod.pas"/>
    424         <Caret Line="237" Column="117" TopLine="220"/>
     539        <Filename Value="UMainForm.pas"/>
     540        <Caret Line="236" Column="58" TopLine="215"/>
    425541      </Position13>
    426542      <Position14>
    427         <Filename Value="UDrawMethod.pas"/>
    428         <Caret Line="240" Column="1" TopLine="224"/>
     543        <Filename Value="UMainForm.pas"/>
     544        <Caret Line="124" Column="14" TopLine="107"/>
    429545      </Position14>
    430546      <Position15>
    431         <Filename Value="UDrawMethod.pas"/>
    432         <Caret Line="281" Column="45" TopLine="263"/>
     547        <Filename Value="UMainForm.pas"/>
     548        <Caret Line="206" Column="19" TopLine="203"/>
    433549      </Position15>
    434550      <Position16>
    435551        <Filename Value="UMainForm.pas"/>
    436         <Caret Line="145" Column="49" TopLine="130"/>
     552        <Caret Line="117" Column="3" TopLine="115"/>
    437553      </Position16>
    438554      <Position17>
    439         <Filename Value="UDrawMethod.pas"/>
    440         <Caret Line="182" Column="3" TopLine="173"/>
     555        <Filename Value="UMainForm.pas"/>
     556        <Caret Line="118" Column="1" TopLine="113"/>
    441557      </Position17>
    442558      <Position18>
    443         <Filename Value="UDrawMethod.pas"/>
    444         <Caret Line="257" Column="42" TopLine="243"/>
     559        <Filename Value="UMainForm.pas"/>
     560        <Caret Line="119" Column="1" TopLine="113"/>
    445561      </Position18>
    446562      <Position19>
    447         <Filename Value="UDrawMethod.pas"/>
    448         <Caret Line="336" Column="18" TopLine="311"/>
     563        <Filename Value="UMainForm.pas"/>
     564        <Caret Line="242" Column="1" TopLine="223"/>
    449565      </Position19>
    450566      <Position20>
    451         <Filename Value="UDrawMethod.pas"/>
    452         <Caret Line="234" Column="38" TopLine="220"/>
     567        <Filename Value="UMainForm.pas"/>
     568        <Caret Line="243" Column="1" TopLine="223"/>
    453569      </Position20>
    454570      <Position21>
    455571        <Filename Value="UMainForm.pas"/>
    456         <Caret Line="117" Column="26" TopLine="106"/>
     572        <Caret Line="244" Column="1" TopLine="223"/>
    457573      </Position21>
    458574      <Position22>
    459575        <Filename Value="UMainForm.pas"/>
    460         <Caret Line="180" Column="3" TopLine="178"/>
     576        <Caret Line="245" Column="1" TopLine="223"/>
    461577      </Position22>
    462578      <Position23>
    463579        <Filename Value="UMainForm.pas"/>
    464         <Caret Line="182" Column="9" TopLine="179"/>
     580        <Caret Line="120" Column="1" TopLine="107"/>
    465581      </Position23>
    466582      <Position24>
    467583        <Filename Value="UMainForm.pas"/>
    468         <Caret Line="186" Column="92" TopLine="177"/>
     584        <Caret Line="121" Column="1" TopLine="107"/>
    469585      </Position24>
    470586      <Position25>
    471587        <Filename Value="UMainForm.pas"/>
    472         <Caret Line="183" Column="1" TopLine="177"/>
     588        <Caret Line="122" Column="1" TopLine="107"/>
    473589      </Position25>
    474590      <Position26>
    475591        <Filename Value="UMainForm.pas"/>
    476         <Caret Line="184" Column="1" TopLine="177"/>
     592        <Caret Line="123" Column="1" TopLine="107"/>
    477593      </Position26>
    478594      <Position27>
    479595        <Filename Value="UMainForm.pas"/>
    480         <Caret Line="140" Column="29" TopLine="133"/>
     596        <Caret Line="129" Column="37" TopLine="115"/>
    481597      </Position27>
    482598      <Position28>
    483599        <Filename Value="UMainForm.pas"/>
    484         <Caret Line="142" Column="29" TopLine="135"/>
     600        <Caret Line="148" Column="3" TopLine="139"/>
    485601      </Position28>
    486602      <Position29>
    487603        <Filename Value="UMainForm.pas"/>
    488         <Caret Line="141" Column="29" TopLine="134"/>
     604        <Caret Line="133" Column="32" TopLine="116"/>
    489605      </Position29>
    490606      <Position30>
    491607        <Filename Value="UMainForm.pas"/>
    492         <Caret Line="146" Column="20" TopLine="135"/>
     608        <Caret Line="134" Column="32" TopLine="117"/>
    493609      </Position30>
    494610    </JumpHistory>
    495611  </ProjectOptions>
    496612  <CompilerOptions>
    497     <Version Value="8"/>
     613    <Version Value="11"/>
    498614    <Target>
    499615      <Filename Value="GraphicTest"/>
    500616    </Target>
    501617    <SearchPaths>
    502       <IncludeFiles Value="$(ProjOutDir)/"/>
    503       <OtherUnitFiles Value="BGRABitmap/"/>
     618      <IncludeFiles Value="$(ProjOutDir)"/>
    504619      <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
    505620    </SearchPaths>
     621    <Parsing>
     622      <SyntaxOptions>
     623        <UseAnsiStrings Value="False"/>
     624      </SyntaxOptions>
     625    </Parsing>
    506626    <Linking>
    507627      <Options>
  • GraphicTest/GraphicTest.lpr

    r211 r317  
    88  {$ENDIF}{$ENDIF}
    99  Interfaces, // this includes the LCL widgetset
    10   Forms, lazopenglcontext, UMainForm, UPlatform, UDrawMethod, UFastBitmap;
     10  Forms, lazopenglcontext, UMainForm, UPlatform, UDrawMethod, UFastBitmap,
     11  bgrabitmappack;
    1112
    1213{$R *.res}
  • GraphicTest/UDrawMethod.pas

    r212 r317  
    4141  TDrawMethodClass = class of TDrawMethod;
    4242
     43  { TDummyMethod }
     44
     45  TDummyMethod = class(TDrawMethod)
     46    constructor Create; override;
     47    procedure DrawFrame(FastBitmap: TFastBitmap); override;
     48  end;
     49
    4350  { TCanvasPixels }
    4451
     
    8491
    8592  TBitmapRawImageDataPaintBox = class(TDrawMethod)
     93    constructor Create; override;
     94    procedure DrawFrame(FastBitmap: TFastBitmap); override;
     95  end;
     96
     97  { TBitmapRawImageDataMove }
     98
     99  TBitmapRawImageDataMove = class(TDrawMethod)
    86100    constructor Create; override;
    87101    procedure DrawFrame(FastBitmap: TFastBitmap); override;
     
    121135
    122136const
    123   DrawMethodClasses: array[0..8] of TDrawMethodClass = (
     137  DrawMethodClasses: array[0..10] of TDrawMethodClass = (
    124138    TCanvasPixels, TCanvasPixelsUpdateLock, TLazIntfImageColorsCopy,
    125139    TLazIntfImageColorsNoCopy, TBitmapRawImageData, TBitmapRawImageDataPaintBox,
    126     TBGRABitmapPaintBox, TOpenGLMethod, TOpenGLPBOMethod);
     140    TBitmapRawImageDataMove, TBGRABitmapPaintBox, TOpenGLMethod, TOpenGLPBOMethod,
     141    TDummyMethod);
    127142
    128143implementation
     144
     145{ TDummyMethod }
     146
     147constructor TDummyMethod.Create;
     148begin
     149  inherited Create;
     150  Caption := 'Dummy';
     151end;
     152
     153procedure TDummyMethod.DrawFrame(FastBitmap: TFastBitmap);
     154var
     155  Y, X: Integer;
     156  PixelPtr: PInteger;
     157  RowPtr: PInteger;
     158  P: TPixelFormat;
     159  RawImage: TRawImage;
     160  BytePerPixel: Integer;
     161  BytePerRow: Integer;
     162begin
     163  P := Bitmap.PixelFormat;
     164    with FastBitmap do
     165    try
     166      //Bitmap.BeginUpdate(False);
     167      RawImage := Bitmap.RawImage;
     168      RowPtr := PInteger(RawImage.Data);
     169      BytePerPixel := RawImage.Description.BitsPerPixel div 8;
     170      BytePerRow := RawImage.Description.BytesPerLine;
     171    finally
     172      //Bitmap.EndUpdate(False);
     173    end;
     174end;
     175
     176{ TBitmapRawImageDataMove }
     177
     178constructor TBitmapRawImageDataMove.Create;
     179begin
     180  inherited;
     181  Caption := 'TBitmap.RawImage.Data Move';
     182end;
     183
     184procedure TBitmapRawImageDataMove.DrawFrame(FastBitmap: TFastBitmap);
     185var
     186  Y, X: Integer;
     187  PixelPtr: PInteger;
     188  RowPtr: PInteger;
     189  P: TPixelFormat;
     190  RawImage: TRawImage;
     191  BytePerPixel: Integer;
     192  BytePerRow: Integer;
     193begin
     194  P := Bitmap.PixelFormat;
     195    with FastBitmap do
     196    try
     197      Bitmap.BeginUpdate(False);
     198      RawImage := Bitmap.RawImage;
     199      RowPtr := PInteger(RawImage.Data);
     200      BytePerPixel := RawImage.Description.BitsPerPixel div 8;
     201      BytePerRow := RawImage.Description.BytesPerLine;
     202      Move(FastBitmap.PixelsData^, RowPtr^, Size.Y * BytePerRow);
     203    finally
     204      Bitmap.EndUpdate(False);
     205    end;
     206end;
    129207
    130208{ TOpenGLPBOMethod }
     
    455533
    456534procedure TBitmapRawImageData.DrawFrame(FastBitmap: TFastBitmap);
    457 type
    458   TFastBitmapPixelComponents = packed record
    459   end;
    460535var
    461536  Y, X: Integer;
  • GraphicTest/UFastBitmap.pas

    r212 r317  
    3131    property Size: TPoint read FSize write SetSize;
    3232    property Pixels[X, Y: Integer]: TFastBitmapPixel read GetPixel write SetPixel;
     33    property PixelsData: PByte read FPixelsData;
    3334  end;
    3435
  • GraphicTest/UMainForm.lfm

    r212 r317  
    11object MainForm: TMainForm
    2   Left = 214
    3   Height = 393
    4   Top = 106
    5   Width = 680
     2  Left = 187
     3  Height = 421
     4  Top = 68
     5  Width = 735
    66  Caption = 'Graphic test'
    7   ClientHeight = 393
    8   ClientWidth = 680
     7  ClientHeight = 421
     8  ClientWidth = 735
    99  OnClose = FormClose
    1010  OnCreate = FormCreate
    1111  OnDestroy = FormDestroy
     12  OnShow = FormShow
    1213  LCLVersion = '0.9.31'
    1314  object PageControl1: TPageControl
    14     Left = 312
    15     Height = 373
     15    Left = 360
     16    Height = 401
    1617    Top = 16
    17     Width = 365
    18     ActivePage = TabSheet3
     18    Width = 372
     19    ActivePage = TabSheet1
    1920    Anchors = [akTop, akLeft, akRight, akBottom]
    20     TabIndex = 2
     21    TabIndex = 0
    2122    TabOrder = 0
    2223    object TabSheet1: TTabSheet
    2324      Caption = 'TImage'
    24       ClientHeight = 346
    25       ClientWidth = 361
     25      ClientHeight = 375
     26      ClientWidth = 364
    2627      object Image1: TImage
    2728        Left = 6
    28         Height = 278
     29        Height = 307
    2930        Top = 7
    30         Width = 351
     31        Width = 354
    3132        Anchors = [akTop, akLeft, akRight, akBottom]
    3233      end
     
    4849    end
    4950  end
    50   object ButtonStart: TButton
    51     Left = 7
    52     Height = 25
    53     Top = 9
    54     Width = 75
    55     Caption = 'Start'
    56     OnClick = ButtonStartClick
    57     TabOrder = 1
    58   end
    59   object Label1: TLabel
    60     Left = 9
    61     Height = 14
    62     Top = 95
    63     Width = 24
    64     Caption = 'FPS:'
    65     ParentColor = False
    66   end
    67   object Label2: TLabel
    68     Left = 128
    69     Height = 14
    70     Top = 95
    71     Width = 10
    72     Caption = '   '
    73     ParentColor = False
    74   end
    75   object ButtonStop: TButton
    76     Left = 95
    77     Height = 25
    78     Top = 9
    79     Width = 75
    80     Caption = 'Stop'
    81     Enabled = False
    82     OnClick = ButtonStopClick
    83     TabOrder = 2
    84   end
    85   object Label3: TLabel
    86     Left = 9
    87     Height = 14
    88     Top = 112
    89     Width = 83
    90     Caption = 'Frame duration'
    91     ParentColor = False
    92   end
    93   object Label4: TLabel
    94     Left = 128
    95     Height = 14
    96     Top = 112
    97     Width = 10
    98     Caption = '   '
    99     ParentColor = False
    100   end
    101   object ListView1: TListView
     51  object ListViewMethods: TListView
    10252    Left = 8
    103     Height = 253
    104     Top = 136
    105     Width = 296
     53    Height = 345
     54    Top = 8
     55    Width = 344
    10656    Anchors = [akTop, akLeft, akBottom]
    10757    Columns = <   
    10858      item
    10959        Caption = 'Method'
    110         Width = 140
     60        Width = 200
    11161      end   
    11262      item
     
    11868        Width = 75
    11969      end>
    120     TabOrder = 3
     70    OwnerData = True
     71    ReadOnly = True
     72    RowSelect = True
     73    TabOrder = 1
    12174    ViewStyle = vsReport
     75    OnData = ListViewMethodsData
     76    OnSelectItem = ListViewMethodsSelectItem
     77  end
     78  object ButtonSingleTest: TButton
     79    Left = 8
     80    Height = 25
     81    Top = 360
     82    Width = 115
     83    Anchors = [akLeft, akBottom]
     84    Caption = 'Test one method'
     85    OnClick = ButtonSingleTestClick
     86    TabOrder = 2
    12287  end
    12388  object ButtonBenchmark: TButton
    124     Left = 229
     89    Left = 136
    12590    Height = 25
    126     Top = 101
    127     Width = 75
    128     Caption = 'Benchmark'
     91    Top = 360
     92    Width = 112
     93    Anchors = [akLeft, akBottom]
     94    Caption = 'Test all methods'
    12995    OnClick = ButtonBenchmarkClick
    130     TabOrder = 4
    131   end
    132   object ComboBox1: TComboBox
    133     Left = 7
    134     Height = 25
    135     Top = 64
    136     Width = 297
    137     ItemHeight = 0
    138     Style = csDropDownList
    139     TabOrder = 5
    140   end
    141   object Label5: TLabel
    142     Left = 9
    143     Height = 14
    144     Top = 47
    145     Width = 46
    146     Caption = 'Method:'
    147     ParentColor = False
     96    TabOrder = 3
    14897  end
    14998  object FloatSpinEdit1: TFloatSpinEdit
    150     Left = 175
     99    Left = 160
    151100    Height = 21
    152     Top = 103
    153     Width = 50
     101    Top = 392
     102    Width = 58
     103    Anchors = [akLeft, akBottom]
    154104    Increment = 1
    155105    MaxValue = 100
    156106    MinValue = 0
    157     TabOrder = 6
     107    TabOrder = 4
    158108    Value = 1
     109  end
     110  object ButtonStop: TButton
     111    Left = 256
     112    Height = 25
     113    Top = 360
     114    Width = 75
     115    Anchors = [akLeft, akBottom]
     116    Caption = 'Stop'
     117    OnClick = ButtonStopClick
     118    TabOrder = 5
     119  end
     120  object Label1: TLabel
     121    Left = 8
     122    Height = 14
     123    Top = 395
     124    Width = 137
     125    Anchors = [akLeft, akBottom]
     126    Caption = 'Single method test duration:'
     127    ParentColor = False
     128  end
     129  object Label2: TLabel
     130    Left = 224
     131    Height = 14
     132    Top = 395
     133    Width = 6
     134    Anchors = [akLeft, akBottom]
     135    Caption = 's'
     136    ParentColor = False
    159137  end
    160138  object Timer1: TTimer
    161139    Interval = 500
    162140    OnTimer = Timer1Timer
    163     left = 209
    164     top = 16
     141    left = 238
     142    top = 136
    165143  end
    166144end
  • GraphicTest/UMainForm.pas

    r212 r317  
    2020
    2121  TMainForm = class(TForm)
     22    ButtonStop: TButton;
    2223    ButtonBenchmark: TButton;
    23     ButtonStart: TButton;
    24     ButtonStop: TButton;
    25     ComboBox1: TComboBox;
     24    ButtonSingleTest: TButton;
    2625    FloatSpinEdit1: TFloatSpinEdit;
    2726    Image1: TImage;
    2827    Label1: TLabel;
    2928    Label2: TLabel;
    30     Label3: TLabel;
    31     Label4: TLabel;
    32     Label5: TLabel;
    33     ListView1: TListView;
     29    ListViewMethods: TListView;
    3430    PageControl1: TPageControl;
    3531    PaintBox1: TPaintBox;
     
    3935    Timer1: TTimer;
    4036    procedure ButtonBenchmarkClick(Sender: TObject);
    41     procedure ButtonStartClick(Sender: TObject);
     37    procedure ButtonSingleTestClick(Sender: TObject);
    4238    procedure ButtonStopClick(Sender: TObject);
    4339    procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
    4440    procedure FormCreate(Sender: TObject);
    4541    procedure FormDestroy(Sender: TObject);
     42    procedure FormShow(Sender: TObject);
     43    procedure ListViewMethodsData(Sender: TObject; Item: TListItem);
     44    procedure ListViewMethodsSelectItem(Sender: TObject; Item: TListItem;
     45      Selected: Boolean);
    4646    procedure Timer1Timer(Sender: TObject);
    4747  private
     
    5050    TextureData: Pointer;
    5151    MethodIndex: Integer;
     52    SingleTestActive: Boolean;
     53    AllTestActive: Boolean;
    5254    procedure OpenGLControl1Resize(Sender: TObject);
    5355    procedure InitGL;
     56    procedure UpdateMethodList;
     57    procedure UpdateInterface;
    5458  public
    5559    DrawMethods: TObjectList; // TObjectList<TDrawMethod>
     
    8690  Bitmap.PixelFormat := pf24bit;
    8791  Image1.Picture.Bitmap.SetSize(TFastBitmap(Scenes[0]).Size.X, TFastBitmap(Scenes[0]).Size.Y);
     92  Image1.Picture.Bitmap.PixelFormat := pf32bit;
    8893  Bitmap.SetSize(TFastBitmap(Scenes[0]).Size.X, TFastBitmap(Scenes[0]).Size.Y);
    8994
     
    100105
    101106  DrawMethods := TObjectList.Create;
    102   ComboBox1.Clear;
    103107  for I := 0 to High(DrawMethodClasses) do begin
    104108    NewDrawMethod := DrawMethodClasses[I].Create;
     
    109113    NewDrawMethod.Init;
    110114    DrawMethods.Add(NewDrawMethod);
    111     ComboBox1.Items.Add(NewDrawMethod.Caption);
    112   end;
    113   ComboBox1.ItemIndex := DrawMethods.Count - 1;
    114 end;
    115 
    116 procedure TMainForm.ButtonStartClick(Sender: TObject);
    117 begin
    118   MethodIndex := ComboBox1.ItemIndex;
    119   ButtonStop.Enabled := True;
    120   ButtonStart.Enabled := False;
    121   Timer1.Enabled := True;
    122   if MethodIndex >= 0 then
    123   with TDrawMethod(DrawMethods[MethodIndex]) do begin
    124     PageControl1.TabIndex := Integer(PaintObject);
    125     Application.ProcessMessages;
    126     repeat
    127       DrawFrameTiming(TFastBitmap(Scenes[SceneIndex]));
    128       SceneIndex := (SceneIndex + 1) mod Scenes.Count;
     115  end;
     116end;
     117
     118procedure TMainForm.ButtonSingleTestClick(Sender: TObject);
     119begin
     120  try
     121    SingleTestActive := True;
     122    UpdateInterface;
     123    Timer1.Enabled := True;
     124    MethodIndex := ListViewMethods.Selected.Index;
     125    Timer1.Enabled := True;
     126    if MethodIndex >= 0 then
     127    with TDrawMethod(DrawMethods[MethodIndex]) do begin
     128      PageControl1.TabIndex := Integer(PaintObject);
    129129      Application.ProcessMessages;
    130     until not ButtonStop.Enabled;
    131   end;
    132   ButtonStopClick(Self);
     130      repeat
     131        DrawFrameTiming(TFastBitmap(Scenes[SceneIndex]));
     132        SceneIndex := (SceneIndex + 1) mod Scenes.Count;
     133        Application.ProcessMessages;
     134      until not SingleTestActive;
     135    end;
     136  finally
     137    Timer1.Enabled := False;
     138    SingleTestActive := False;
     139    UpdateInterface;
     140  end;
    133141end;
    134142
    135143procedure TMainForm.ButtonBenchmarkClick(Sender: TObject);
    136144var
    137   NewItem: TListItem;
    138145  I: Integer;
    139146  C: Integer;
    140147  StartTime: TDateTime;
    141148begin
    142   Timer1.Enabled := True;
    143   with ListView1, Items do
    144149  try
    145     //BeginUpdate;
    146     Clear;
     150    AllTestActive := True;
     151    UpdateInterface;
     152    Timer1.Enabled := True;
     153    with ListViewMethods, Items do
    147154    for I := 0 to DrawMethods.Count - 1 do
    148155    with TDrawMethod(DrawMethods[I]) do begin
     
    154161        SceneIndex := (SceneIndex + 1) mod Scenes.Count;
    155162        Application.ProcessMessages;
    156       until (NowPrecise - StartTime) > OneSecond * FloatSpinEdit1.Value;
    157       NewItem := Add;
    158       NewItem.Caption := Caption;
    159       NewItem.SubItems.Add(FloatToStr(RoundTo(FrameDuration / OneMillisecond, -3)));
    160       NewItem.SubItems.Add(FloatToStr(RoundTo(1 / (FrameDuration / OneSecond), -3)));
     163      until ((NowPrecise - StartTime) > OneSecond * FloatSpinEdit1.Value) or not AllTestActive;
    161164    end;
    162165  finally
    163     //EndUpdate;
     166    Timer1.Enabled := False;
     167    AllTestActive := False;
     168    UpdateInterface;
    164169  end;
    165170end;
     
    167172procedure TMainForm.ButtonStopClick(Sender: TObject);
    168173begin
    169   ButtonStart.Enabled := True;
    170   ButtonStop.Enabled := False;
     174  SingleTestActive := False;
     175  AllTestActive := False;
    171176end;
    172177
     
    184189end;
    185190
     191procedure TMainForm.FormShow(Sender: TObject);
     192begin
     193  UpdateMethodList;
     194  UpdateInterface;
     195end;
     196
     197procedure TMainForm.ListViewMethodsData(Sender: TObject; Item: TListItem);
     198begin
     199  if (Item.Index >= 0) and (Item.Index < DrawMethods.Count) then
     200  with TDrawMethod(DrawMethods[Item.Index]) do begin
     201    Item.Caption := Caption;
     202    if FrameDuration > 0 then
     203      Item.SubItems.Add(FloatToStr(RoundTo(1 / (FrameDuration / OneSecond), -3)))
     204      else Item.SubItems.Add('0');
     205    Item.SubItems.Add(FloatToStr(RoundTo(FrameDuration / OneMillisecond, -3)) + ' ms');
     206  end;
     207end;
     208
     209procedure TMainForm.ListViewMethodsSelectItem(Sender: TObject; Item: TListItem;
     210  Selected: Boolean);
     211begin
     212  UpdateInterface;
     213end;
     214
    186215procedure TMainForm.Timer1Timer(Sender: TObject);
    187216begin
    188   if (MethodIndex >= 0) then
    189   with TDrawMethod(DrawMethods[MethodIndex]) do begin
    190     if (FrameDuration > 0) then
    191       Label2.Caption := FloatToStr(RoundTo(1 / (FrameDuration / OneSecond), -3))
    192       else Label2.Caption := '0';
    193     Label4.Caption := FloatToStr(RoundTo(FrameDuration / OneMillisecond, -3)) + ' ms';
    194   end;
     217  UpdateMethodList;
    195218end;
    196219
     
    220243end;
    221244
     245procedure TMainForm.UpdateMethodList;
     246begin
     247  ListViewMethods.Items.Count := DrawMethods.Count;
     248  ListViewMethods.Refresh;
     249end;
     250
     251procedure TMainForm.UpdateInterface;
     252begin
     253  ButtonSingleTest.Enabled := not SingleTestActive and not AllTestActive and Assigned(ListViewMethods.Selected);
     254  ButtonBenchmark.Enabled := not AllTestActive and not SingleTestActive;
     255  ButtonStop.Enabled := SingleTestActive or AllTestActive;
     256end;
     257
    222258end.
    223259
Note: See TracChangeset for help on using the changeset viewer.