Changeset 521 for GraphicTest


Ignore:
Timestamp:
Apr 17, 2019, 12:58:41 AM (6 years ago)
Author:
chronos
Message:
  • Modified: Propagate project build mode options to used packages.
  • Added: Check memory leaks using heaptrc.
  • Modified: Update BGRABitmap package.
Location:
GraphicTest
Files:
206 added
93 edited

Legend:

Unmodified
Added
Removed
  • GraphicTest

    • Property svn:ignore
      •  

        old new  
        88GraphicTest.lps
        99GraphicTest.dbg
         10heaptrclog.trc
  • GraphicTest/GraphicTest.lpi

    r494 r521  
    22<CONFIG>
    33  <ProjectOptions>
    4     <Version Value="9"/>
     4    <Version Value="11"/>
    55    <General>
    66      <SessionStorage Value="InProjectDir"/>
     
    2020            <IncludeFiles Value="$(ProjOutDir)"/>
    2121            <OtherUnitFiles Value="Methods"/>
    22             <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
     22            <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)-$(BuildMode)"/>
    2323          </SearchPaths>
    2424          <Parsing>
     
    4848            </Options>
    4949          </Linking>
     50          <Other>
     51            <CompilerMessages>
     52              <IgnoredMessages idx5024="True"/>
     53            </CompilerMessages>
     54          </Other>
    5055        </CompilerOptions>
    5156      </Item2>
     57      <SharedMatrixOptions Count="2">
     58        <Item1 ID="838068306737" Targets="GR32_L, bgrabitmappack" Modes="Debug" Value="-g -gl -gh -CirotR -O1"/>
     59        <Item2 ID="108912769980" Targets="GR32_L, bgrabitmappack" Modes="Release" Value="-CX -XX -O3"/>
     60      </SharedMatrixOptions>
    5261    </BuildModes>
    5362    <PublishOptions>
    5463      <Version Value="2"/>
    55       <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
    56       <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/>
    5764    </PublishOptions>
    5865    <RunParams>
    59       <local>
    60         <FormatVersion Value="1"/>
    61       </local>
     66      <FormatVersion Value="2"/>
     67      <Modes Count="1">
     68        <Mode0 Name="default"/>
     69      </Modes>
    6270    </RunParams>
    6371    <RequiredPackages Count="5">
     
    169177      <IncludeFiles Value="$(ProjOutDir)"/>
    170178      <OtherUnitFiles Value="Methods"/>
    171       <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
     179      <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)-$(BuildMode)"/>
    172180    </SearchPaths>
    173181    <Parsing>
     
    191199    </CodeGeneration>
    192200    <Linking>
     201      <Debugging>
     202        <UseHeaptrc Value="True"/>
     203      </Debugging>
    193204      <Options>
    194205        <Win32>
     
    198209    </Linking>
    199210    <Other>
     211      <CompilerMessages>
     212        <IgnoredMessages idx5024="True"/>
     213      </CompilerMessages>
    200214      <CustomOptions Value="-dopengl"/>
    201215    </Other>
  • GraphicTest/GraphicTest.lpr

    r494 r521  
    88  {$ENDIF}{$ENDIF}
    99  Interfaces, // this includes the LCL widgetset
    10   Forms, openglcontext, UMainForm, UPlatform, UDrawMethod, UFastBitmap,
     10  Forms, SysUtils, openglcontext, UMainForm, UPlatform, UDrawMethod, UFastBitmap,
    1111  UDrawForm, bgrabitmappack,
    1212  {$IFDEF GRAPHICS32}GR32_L,{$ENDIF}
     
    1818{$R *.res}
    1919
     20{$if declared(UseHeapTrace)}
     21const
     22  HeapTraceLog = 'heaptrclog.trc';
     23{$ENDIF}
     24
    2025begin
     26  {$if declared(UseHeapTrace)}
     27  // Heap trace
     28  DeleteFile(ExtractFilePath(ParamStr(0)) + HeapTraceLog);
     29  SetHeapTraceOutput(ExtractFilePath(ParamStr(0)) + HeapTraceLog);
     30  {$ENDIF}
     31
    2132  RequireDerivedFormResource := True;
    2233  Application.Initialize;
  • GraphicTest/Packages/Graphics32/Packages/GR32_L.lpk

    r452 r521  
    1 <?xml version="1.0"?>
     1<?xml version="1.0" encoding="UTF-8"?>
    22<CONFIG>
    33  <Package Version="4">
     
    1313        <IncludeFiles Value=".."/>
    1414        <OtherUnitFiles Value=".."/>
    15         <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\$(LCLWidgetType)"/>
     15        <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)-$(BuildMode)\$(LCLWidgetType)"/>
    1616      </SearchPaths>
    1717      <Parsing>
     
    2323        </SyntaxOptions>
    2424      </Parsing>
    25       <Other>
    26         <CompilerMessages>
    27           <UseMsgFile Value="True"/>
    28         </CompilerMessages>
    29         <CompilerPath Value="$(CompPath)"/>
    30       </Other>
     25      <CodeGeneration>
     26        <Optimizations>
     27          <OptimizationLevel Value="0"/>
     28        </Optimizations>
     29      </CodeGeneration>
     30      <Linking>
     31        <Debugging>
     32          <GenerateDebugInfo Value="False"/>
     33        </Debugging>
     34      </Linking>
    3135    </CompilerOptions>
    3236    <Description Value="Graphics32 is a library designed for fast 32-bit graphics handling on Delphi and Kylix. Optimized for 32-bit pixel formats, it provides fast operations with pixels and graphic primitives, and in most cases Graphics32 outperforms the standard TCanvas classes. It is almost a hundred times faster in per-pixel access and about 2–5 times faster in drawing lines.
     
    154158    <PublishOptions>
    155159      <Version Value="2"/>
    156       <IgnoreBinaries Value="False"/>
    157160    </PublishOptions>
    158161    <CustomOptions Items="ExternHelp" Version="2">
  • GraphicTest/Packages/bgrabitmap/basiccolorspace.inc

    r494 r521  
    1313
    1414  // TExpandedPixel -> TBGRAPixel
    15   GammaCompressionTab: packed array[0..65535] of byte;
     15  GammaCompressionTab : packed array[0..65535] of byte;          //rounded value
     16  GammaCompressionTabFrac : packed array[0..65535] of shortint;  //fractional part of value from -0.5 to +0.5
    1617
    1718procedure BGRASetGamma(AGamma: single = 1.7);
     
    4243  {** Returns the lightness of an gamma-expanded pixel. The lightness is the
    4344     perceived brightness, 0 being black and 65535 being white }
    44   function GetLightness(const c: TExpandedPixel): word; inline;
     45  function GetLightness(const c: TExpandedPixel): word; inline; overload;
    4546  {** Sets the lightness of a gamma-expanded pixel }
    46   function SetLightness(const c: TExpandedPixel; lightness: word): TExpandedPixel;
     47  function SetLightness(const c: TExpandedPixel; lightness: word): TExpandedPixel; overload;
    4748  {** Sets the lightness of a gamma expanded pixel, provided you already know the current
    4849     value of lightness ''curLightness''. It is a bit faster than the previous function }
    49   function SetLightness(const c: TExpandedPixel; lightness: word; curLightness: word): TExpandedPixel;
     50  function SetLightness(const c: TExpandedPixel; lightness: word; curLightness: word): TExpandedPixel; overload;
    5051  {** Returns the importance of the color. It is similar to saturation
    5152      in HSL colorspace, except it is gamma corrected. A value of zero indicates
     
    8889    {** Hue of the pixel. Extremum values 0 and 65535 are red }
    8990    hue: word;
    90     {** Saturation of the color. 0 is gray and 65535 is the brightest color }
     91    {** Saturation of the color. 0 is gray and 65535 is the brightest color (including white) }
    9192    saturation: word;
    9293    {** Lightness of the color. 0 is black, 32768 is normal, and 65535 is white }
     
    116117  {* Pixel color defined in corrected HSL colorspace. G stands for corrected hue
    117118     and B stands for actual brightness. Values range from 0 to 65535 }
    118   TGSBAPixel = THSLAPixel;
     119  TGSBAPixel = packed record
     120    {** Hue of the pixel. Extremum values 0 and 65535 are red }
     121    hue: word;
     122    {** Saturation of the color. 0 is gray and 65535 is the brightest color (excluding white) }
     123    saturation: word;
     124    {** Actual perceived brightness. 0 is black, 32768 is normal, and 65535 is white }
     125    lightness: word;
     126    {** Opacity of the pixel. 0 is transparent and 65535 is opaque }
     127    alpha: word;
     128  end;
    119129
    120130  {** Converts a pixel from sRGB to correct HSL color space }
     
    127137  function HtoG(hue: word): word;
    128138  {** Converts a pixel from corrected HSL to sRGB }
    129   function GSBAToBGRA(c: TGSBAPixel): TBGRAPixel;
     139  function GSBAToBGRA(c: TGSBAPixel): TBGRAPixel; overload;
     140  function GSBAToBGRA(const c: THSLAPixel): TBGRAPixel; overload;
    130141  {** Converts a pixel from correct HSL to gamma expanded RGB }
    131   function GSBAToExpanded(c: TGSBAPixel): TExpandedPixel;
     142  function GSBAToExpanded(c: TGSBAPixel): TExpandedPixel; overload;
     143  function GSBAToExpanded(const c: THSLAPixel): TExpandedPixel; overload;
    132144  {** Converts a pixel from correct HSL to usual HSL }
    133   function GSBAToHSLA(c: TGSBAPixel): THSLAPixel;
     145  function GSBAToHSLA(const c: TGSBAPixel): THSLAPixel; overload;
     146  function GSBAToHSLA(const c: THSLAPixel): THSLAPixel; overload;
     147  function HSLAToGSBA(const c: THSLAPixel): TGSBAPixel;
    134148
    135149type
    136   { TBGRAPixelHelper }
    137 
    138   TBGRAPixelHelper = record helper for TBGRAPixel
     150  { TBGRAPixelBasicHelper }
     151
     152  TBGRAPixelBasicHelper = record helper for TBGRAPixel
    139153    function ToExpanded: TExpandedPixel;
    140154    procedure FromExpanded(const AValue: TExpandedPixel);
     
    142156    procedure FromHSLAPixel(const AValue: THSLAPixel);
    143157    function ToGSBAPixel: TGSBAPixel;
    144     procedure FromGSBAPixel(const AValue: TGSBAPixel);
     158    procedure FromGSBAPixel(const AValue: TGSBAPixel); overload;
     159    procedure FromGSBAPixel(const AValue: THSLAPixel); overload;
    145160    function ToColorF(AGammaExpansion: boolean): TColorF;
    146161    procedure FromColorF(const AValue: TColorF; AGammaCompression: boolean);
    147162  end;
    148163
    149   { TExpandedPixelHelper }
    150 
    151   TExpandedPixelHelper = record helper for TExpandedPixel
     164  { TExpandedPixelBasicHelper }
     165
     166  TExpandedPixelBasicHelper = record helper for TExpandedPixel
     167    function ToFPColor(AGammaCompression: boolean = true): TFPColor;
     168    procedure FromFPColor(const AValue: TFPColor; AGammaExpansion: boolean = true);
     169    function ToColor: TColor;
     170    procedure FromColor(const AValue: TColor);
     171    function ToBGRAPixel: TBGRAPixel;
     172    procedure FromBGRAPixel(AValue: TBGRAPixel);
     173    function ToHSLAPixel: THSLAPixel;
     174    procedure FromHSLAPixel(const AValue: THSLAPixel);
     175    function ToGSBAPixel: TGSBAPixel;
     176    procedure FromGSBAPixel(const AValue: TGSBAPixel); overload;
     177    procedure FromGSBAPixel(const AValue: THSLAPixel); overload;
     178  end;
     179
     180operator := (const AValue: TExpandedPixel): TColor;
     181operator := (const AValue: TColor): TExpandedPixel;
     182Operator := (const Source: TExpandedPixel): TBGRAPixel;
     183Operator := (const Source: TBGRAPixel): TExpandedPixel;
     184
     185type
     186  { TFPColorBasicHelper }
     187
     188  TFPColorBasicHelper = record helper for TFPColor
     189    function ToColor: TColor;
     190    procedure FromColor(const AValue: TColor);
     191    function ToBGRAPixel: TBGRAPixel;
     192    procedure FromBGRAPixel(AValue: TBGRAPixel);
     193    function ToExpanded(AGammaExpansion: boolean = true): TExpandedPixel;
     194    procedure FromExpanded(const AValue: TExpandedPixel; AGammaCompression: boolean = true);
     195  end;
     196
     197  { THSLAPixelBasicHelper }
     198
     199  THSLAPixelBasicHelper = record helper for THSLAPixel
     200    function ToColor: TColor;
     201    procedure FromColor(const AValue: TColor);
     202    function ToBGRAPixel: TBGRAPixel;
     203    procedure FromBGRAPixel(AValue: TBGRAPixel);
     204    function ToGSBAPixel: TGSBAPixel;
     205    procedure FromGSBAPixel(AValue: TGSBAPixel);
     206    function ToExpanded: TExpandedPixel;
     207    procedure FromExpanded(AValue: TExpandedPixel);
     208  end;
     209
     210Operator := (const Source: THSLAPixel): TBGRAPixel;
     211Operator := (const Source: TBGRAPixel): THSLAPixel;
     212Operator := (const Source: THSLAPixel): TExpandedPixel;
     213Operator := (const Source: TExpandedPixel): THSLAPixel;
     214operator := (const AValue: TColor): THSLAPixel;
     215operator := (const AValue: THSLAPixel): TColor;
     216
     217type
     218  { TGSBAPixelBasicHelper }
     219
     220  TGSBAPixelBasicHelper = record helper for TGSBAPixel
     221    function ToColor: TColor;
     222    procedure FromColor(const AValue: TColor);
    152223    function ToBGRAPixel: TBGRAPixel;
    153224    procedure FromBGRAPixel(AValue: TBGRAPixel);
    154225    function ToHSLAPixel: THSLAPixel;
    155226    procedure FromHSLAPixel(AValue: THSLAPixel);
    156   end;
    157 
    158   { THSLAPixelHelper }
    159 
    160   THSLAPixelHelper = record helper for THSLAPixel
    161     function ToBGRAPixel: TBGRAPixel;
    162     procedure FromBGRAPixel(AValue: TBGRAPixel);
    163227    function ToExpanded: TExpandedPixel;
    164228    procedure FromExpanded(AValue: TExpandedPixel);
    165229  end;
    166230
    167 Operator := (Source: TExpandedPixel): TBGRAPixel;
     231Operator := (const Source: TGSBAPixel): TBGRAPixel;
     232Operator := (const Source: TBGRAPixel): TGSBAPixel;
     233Operator := (const Source: TGSBAPixel): TExpandedPixel;
     234Operator := (const Source: TExpandedPixel): TGSBAPixel;
     235operator := (const AValue: TColor): TGSBAPixel;
     236operator := (const AValue: TGSBAPixel): TColor;
     237Operator := (const Source: TGSBAPixel): THSLAPixel; //no conversion, just copying for backward compatibility (use ToHSLAPixel instead for conversion)
     238Operator := (const Source: THSLAPixel): TGSBAPixel; //no conversion, just copying for backward compatibility (use ToGSBAPixel instead for conversion)
    168239{$ENDIF}
    169240
     
    317388      nextpos := round(power(i+0.5, GammaExpFactor) * GammaLinearFactor);
    318389    GammaExpansionTab[i] := midpos;
    319     for j := prevpos to nextpos-1 do
     390    for j := prevpos to midpos-1 do
     391    begin
    320392      GammaCompressionTab[j] := i;
     393      GammaCompressionTabFrac[j] := -128 + (j-prevpos)*128 div (midpos-prevpos);
     394    end;
     395    for j := midpos to nextpos-1 do
     396    begin
     397      GammaCompressionTab[j] := i;
     398      GammaCompressionTabFrac[j] := (j-midpos)*128 div (nextpos-midpos);
     399    end;
    321400  end;
    322401  GammaCompressionTab[0] := 0;
     
    358437  Result.blue  := GammaCompressionTab[blue];
    359438  Result.alpha := alpha shr 8;
     439end;
     440
     441function GammaExpansionW(ACompressed: word): word;
     442var
     443  intPart: Integer;
     444  f,fracPart: Single;
     445begin
     446  if ACompressed = 0 then
     447    result := 0
     448  else if ACompressed = $ffff then
     449    result := $ffff
     450  else
     451  begin
     452    f := ACompressed/$101;
     453    intPart := trunc(f);
     454    fracPart := f - intPart;
     455    if fracPart = 0 then
     456      result := GammaExpansionTab[intPart]
     457    else
     458      result := round(GammaExpansionTab[intPart]*(1-fracPart)+GammaExpansionTab[intPart+1]*fracPart);
     459  end;
     460end;
     461
     462function GammaCompressionW(AExpanded: word): word;
     463begin
     464  if AExpanded = 0 then
     465    result := 0
     466  else if AExpanded = $ffff then
     467    result := $ffff
     468  else
     469  begin
     470    result := GammaCompressionTab[AExpanded];
     471    result := (result shl 8) + result;
     472    result += GammaCompressionTabFrac[AExpanded];
     473  end;
    360474end;
    361475
     
    871985var lightness: UInt32Or64;
    872986    red,green,blue: Int32or64;
     987    hsla: THSLAPixel;
    873988begin
    874989  red   := GammaExpansionTab[c.red];
    875990  green := GammaExpansionTab[c.green];
    876991  blue  := GammaExpansionTab[c.blue];
    877   result.alpha := c.alpha shl 8 + c.alpha;
     992  hsla.alpha := c.alpha shl 8 + c.alpha;
    878993
    879994  lightness := (red * redWeightShl10 + green * greenWeightShl10 +
    880995    blue * blueWeightShl10 + 512) shr 10;
    881996
    882   ExpandedToHSLAInline(red,green,blue,result);
     997  ExpandedToHSLAInline(red,green,blue,hsla);
     998  result := TGSBAPixel(hsla);
     999
    8831000  if result.lightness > 32768 then
    8841001    result.saturation := result.saturation* UInt32or64(not result.lightness) div 32767;
     
    8901007var lightness: UInt32Or64;
    8911008    red,green,blue: Int32or64;
     1009    hsla: THSLAPixel;
    8921010begin
    8931011  red   := ec.red;
    8941012  green := ec.green;
    8951013  blue  := ec.blue;
    896   result.alpha := ec.alpha;
     1014  hsla.alpha := ec.alpha;
    8971015
    8981016  lightness := (red * redWeightShl10 + green * greenWeightShl10 +
    8991017    blue * blueWeightShl10 + 512) shr 10;
    9001018
    901   ExpandedToHSLAInline(red,green,blue,result);
     1019  ExpandedToHSLAInline(red,green,blue,hsla);
     1020  result := TGSBAPixel(hsla);
     1021
    9021022  if result.lightness > 32768 then
    9031023    result.saturation := result.saturation* UInt32or64(not result.lightness) div 32767;
     
    10021122  lightness := c.lightness;
    10031123  c.lightness := 32768;
    1004   ec := HSLAToExpanded(c);
     1124  ec := HSLAToExpanded(THSLAPixel(c));
    10051125  result := GammaCompression(SetLightness(ec, lightness));
     1126end;
     1127
     1128function GSBAToBGRA(const c: THSLAPixel): TBGRAPixel;
     1129begin
     1130  result := GSBAToBGRA(TGSBAPixel(c));
    10061131end;
    10071132
     
    10121137  lightness := c.lightness;
    10131138  c.lightness := 32768;
    1014   result := SetLightness(HSLAToExpanded(c),lightness);
    1015 end;
    1016 
    1017 function GSBAToHSLA(c: TGSBAPixel): THSLAPixel;
    1018 begin
    1019   result := BGRAToHSLA(GSBAToBGRA(c));
    1020 end;
    1021 
    1022 { TBGRAPixelHelper }
    1023 
    1024 function TBGRAPixelHelper.ToExpanded: TExpandedPixel;
     1139  result := SetLightness(HSLAToExpanded(THSLAPixel(c)),lightness);
     1140end;
     1141
     1142function GSBAToExpanded(const c: THSLAPixel): TExpandedPixel;
     1143begin
     1144  result := GSBAToExpanded(TGSBAPixel(c));
     1145end;
     1146
     1147function GSBAToHSLA(const c: TGSBAPixel): THSLAPixel;
     1148begin
     1149  result := ExpandedToHSLA(GSBAToExpanded(c));
     1150end;
     1151
     1152function GSBAToHSLA(const c: THSLAPixel): THSLAPixel;
     1153begin
     1154  result := ExpandedToHSLA(GSBAToExpanded(TGSBAPixel(c)));
     1155end;
     1156
     1157function HSLAToGSBA(const c: THSLAPixel): TGSBAPixel;
     1158begin
     1159  result := ExpandedToGSBA(HSLAToExpanded(c));
     1160end;
     1161
     1162{ TBGRAPixelBasicHelper }
     1163
     1164function TBGRAPixelBasicHelper.ToExpanded: TExpandedPixel;
    10251165begin
    10261166  result := GammaExpansion(self);
    10271167end;
    10281168
    1029 procedure TBGRAPixelHelper.FromExpanded(const AValue: TExpandedPixel);
     1169procedure TBGRAPixelBasicHelper.FromExpanded(const AValue: TExpandedPixel);
    10301170begin
    10311171  Self := GammaCompression(AValue);
    10321172end;
    10331173
    1034 function TBGRAPixelHelper.ToHSLAPixel: THSLAPixel;
     1174function TBGRAPixelBasicHelper.ToHSLAPixel: THSLAPixel;
    10351175begin
    10361176  result := BGRAToHSLA(Self);
    10371177end;
    10381178
    1039 procedure TBGRAPixelHelper.FromHSLAPixel(const AValue: THSLAPixel);
     1179procedure TBGRAPixelBasicHelper.FromHSLAPixel(const AValue: THSLAPixel);
    10401180begin
    10411181  Self := HSLAToBGRA(AValue);
    10421182end;
    10431183
    1044 function TBGRAPixelHelper.ToGSBAPixel: TGSBAPixel;
     1184function TBGRAPixelBasicHelper.ToGSBAPixel: TGSBAPixel;
    10451185begin
    10461186  result := BGRAToGSBA(Self);
    10471187end;
    10481188
    1049 procedure TBGRAPixelHelper.FromGSBAPixel(const AValue: TGSBAPixel);
     1189procedure TBGRAPixelBasicHelper.FromGSBAPixel(const AValue: TGSBAPixel);
    10501190begin
    10511191  Self := GSBAToBGRA(AValue);
    10521192end;
    10531193
    1054 function TBGRAPixelHelper.ToColorF(AGammaExpansion: boolean): TColorF;
     1194procedure TBGRAPixelBasicHelper.FromGSBAPixel(const AValue: THSLAPixel);
     1195begin
     1196  Self := GSBAToBGRA(AValue);
     1197end;
     1198
     1199function TBGRAPixelBasicHelper.ToColorF(AGammaExpansion: boolean): TColorF;
    10551200begin
    10561201  result := BGRAToColorF(Self,AGammaExpansion);
    10571202end;
    10581203
    1059 procedure TBGRAPixelHelper.FromColorF(const AValue: TColorF;
     1204procedure TBGRAPixelBasicHelper.FromColorF(const AValue: TColorF;
    10601205    AGammaCompression: boolean);
    10611206begin
     
    10631208end;
    10641209
    1065 { TExpandedPixelHelper }
    1066 
    1067 function TExpandedPixelHelper.ToBGRAPixel: TBGRAPixel;
     1210{ TExpandedPixelBasicHelper }
     1211
     1212function TExpandedPixelBasicHelper.ToFPColor(AGammaCompression: boolean): TFPColor;
     1213begin
     1214  if AGammaCompression then
     1215  begin
     1216    result.red := GammaCompressionW(self.red);
     1217    result.green := GammaCompressionW(self.green);
     1218    result.blue := GammaCompressionW(self.blue);
     1219  end else
     1220  begin
     1221    result.red := self.red;
     1222    result.green := self.green;
     1223    result.blue := self.blue;
     1224  end;
     1225  result.alpha := self.alpha;
     1226end;
     1227
     1228procedure TExpandedPixelBasicHelper.FromFPColor(const AValue: TFPColor;
     1229  AGammaExpansion: boolean);
     1230begin
     1231  if AGammaExpansion then
     1232  begin
     1233    self.red := GammaExpansionW(AValue.red);
     1234    self.green := GammaExpansionW(AValue.green);
     1235    self.blue := GammaExpansionW(AValue.blue);
     1236  end else
     1237  begin
     1238    self.red := AValue.red;
     1239    self.green := AValue.green;
     1240    self.blue := AValue.blue;
     1241  end;
     1242  self.alpha := AValue.alpha;
     1243end;
     1244
     1245function TExpandedPixelBasicHelper.ToColor: TColor;
     1246begin
     1247  result := BGRAToColor(GammaCompression(self));
     1248end;
     1249
     1250procedure TExpandedPixelBasicHelper.FromColor(const AValue: TColor);
     1251begin
     1252  self := GammaExpansion(ColorToBGRA(AValue));
     1253end;
     1254
     1255function TExpandedPixelBasicHelper.ToBGRAPixel: TBGRAPixel;
    10681256begin
    10691257  result := GammaCompression(Self);
    10701258end;
    10711259
    1072 procedure TExpandedPixelHelper.FromBGRAPixel(AValue: TBGRAPixel);
     1260procedure TExpandedPixelBasicHelper.FromBGRAPixel(AValue: TBGRAPixel);
    10731261begin
    10741262  Self := GammaExpansion(AValue);
    10751263end;
    10761264
    1077 function TExpandedPixelHelper.ToHSLAPixel: THSLAPixel;
     1265function TExpandedPixelBasicHelper.ToHSLAPixel: THSLAPixel;
    10781266begin
    10791267  result := ExpandedToHSLA(Self);
    10801268end;
    10811269
    1082 procedure TExpandedPixelHelper.FromHSLAPixel(AValue: THSLAPixel);
     1270procedure TExpandedPixelBasicHelper.FromHSLAPixel(const AValue: THSLAPixel);
    10831271begin
    10841272  Self := HSLAToExpanded(AValue);
    10851273end;
    10861274
    1087 operator :=(Source: TExpandedPixel): TBGRAPixel;
     1275function TExpandedPixelBasicHelper.ToGSBAPixel: TGSBAPixel;
     1276begin
     1277  result := ExpandedToGSBA(Self);
     1278end;
     1279
     1280procedure TExpandedPixelBasicHelper.FromGSBAPixel(const AValue: TGSBAPixel);
     1281begin
     1282  Self := GSBAToExpanded(AValue);
     1283end;
     1284
     1285procedure TExpandedPixelBasicHelper.FromGSBAPixel(const AValue: THSLAPixel);
     1286begin
     1287  Self := GSBAToExpanded(AValue);
     1288end;
     1289
     1290operator := (const AValue: TExpandedPixel): TColor;
     1291begin Result := BGRAToColor(GammaCompression(AValue)); end;
     1292
     1293operator := (const AValue: TColor): TExpandedPixel;
     1294begin Result := GammaExpansion(ColorToBGRA(ColorToRGB(AValue))) end;
     1295
     1296operator :=(const Source: TExpandedPixel): TBGRAPixel;
    10881297begin
    10891298  result := GammaCompression(Source);
    10901299end;
    10911300
    1092 { THSLAPixelHelper }
    1093 
    1094 function THSLAPixelHelper.ToBGRAPixel: TBGRAPixel;
     1301operator :=(const Source: TBGRAPixel): TExpandedPixel;
     1302begin
     1303  result := GammaExpansion(Source);
     1304end;
     1305
     1306{ TFPColorBasicHelper }
     1307
     1308function TFPColorBasicHelper.ToColor: TColor;
     1309begin
     1310  result := FPColorToTColor(self);
     1311end;
     1312
     1313procedure TFPColorBasicHelper.FromColor(const AValue: TColor);
     1314begin
     1315  self := TColorToFPColor(AValue);
     1316end;
     1317
     1318function TFPColorBasicHelper.ToBGRAPixel: TBGRAPixel;
     1319begin
     1320  result := FPColorToBGRA(self);
     1321end;
     1322
     1323procedure TFPColorBasicHelper.FromBGRAPixel(AValue: TBGRAPixel);
     1324begin
     1325  self := BGRAToFPColor(AValue);
     1326end;
     1327
     1328function TFPColorBasicHelper.ToExpanded(AGammaExpansion: boolean): TExpandedPixel;
     1329begin
     1330  result.FromFPColor(self, AGammaExpansion);
     1331end;
     1332
     1333procedure TFPColorBasicHelper.FromExpanded(const AValue: TExpandedPixel;
     1334  AGammaCompression: boolean);
     1335begin
     1336  self := AValue.ToFPColor(AGammaCompression);
     1337end;
     1338
     1339{ THSLAPixelBasicHelper }
     1340
     1341function THSLAPixelBasicHelper.ToColor: TColor;
     1342begin
     1343  result := BGRAToColor(HSLAToBGRA(self));
     1344end;
     1345
     1346procedure THSLAPixelBasicHelper.FromColor(const AValue: TColor);
     1347begin
     1348  self := BGRAToHSLA(ColorToBGRA(AValue));
     1349end;
     1350
     1351function THSLAPixelBasicHelper.ToBGRAPixel: TBGRAPixel;
    10951352begin
    10961353  result := HSLAToBGRA(self);
    10971354end;
    10981355
    1099 procedure THSLAPixelHelper.FromBGRAPixel(AValue: TBGRAPixel);
     1356procedure THSLAPixelBasicHelper.FromBGRAPixel(AValue: TBGRAPixel);
    11001357begin
    11011358  self := BGRAToHSLA(AValue);
    11021359end;
    11031360
    1104 function THSLAPixelHelper.ToExpanded: TExpandedPixel;
     1361function THSLAPixelBasicHelper.ToGSBAPixel: TGSBAPixel;
     1362begin
     1363  result := HSLAToGSBA(self);
     1364end;
     1365
     1366procedure THSLAPixelBasicHelper.FromGSBAPixel(AValue: TGSBAPixel);
     1367begin
     1368  self := GSBAToHSLA(AValue);
     1369end;
     1370
     1371function THSLAPixelBasicHelper.ToExpanded: TExpandedPixel;
    11051372begin
    11061373  result := HSLAToExpanded(Self);
    11071374end;
    11081375
    1109 procedure THSLAPixelHelper.FromExpanded(AValue: TExpandedPixel);
     1376procedure THSLAPixelBasicHelper.FromExpanded(AValue: TExpandedPixel);
    11101377begin
    11111378  Self := ExpandedToHSLA(AValue);
    11121379end;
     1380
     1381operator :=(const Source: THSLAPixel): TBGRAPixel;
     1382begin
     1383  result := HSLAToBGRA(Source);
     1384end;
     1385
     1386operator :=(const Source: TBGRAPixel): THSLAPixel;
     1387begin
     1388  result := BGRAToHSLA(Source);
     1389end;
     1390
     1391operator :=(const Source: THSLAPixel): TExpandedPixel;
     1392begin
     1393  result := HSLAToExpanded(Source);
     1394end;
     1395
     1396operator:=(const Source: TExpandedPixel): THSLAPixel;
     1397begin
     1398  result := ExpandedToHSLA(Source);
     1399end;
     1400
     1401operator := (const AValue: TColor): THSLAPixel;
     1402begin Result := BGRAToHSLA(ColorToBGRA(ColorToRGB(AValue))) end;
     1403
     1404operator := (const AValue: THSLAPixel): TColor;
     1405begin Result := BGRAToColor(HSLAToBGRA(AValue)) end;
     1406
     1407{ TGSBAPixelBasicHelper }
     1408
     1409function TGSBAPixelBasicHelper.ToColor: TColor;
     1410begin
     1411  result := BGRAToColor(GSBAToBGRA(self));
     1412end;
     1413
     1414procedure TGSBAPixelBasicHelper.FromColor(const AValue: TColor);
     1415begin
     1416  self := BGRAToGSBA(ColorToBGRA(AValue));
     1417end;
     1418
     1419function TGSBAPixelBasicHelper.ToBGRAPixel: TBGRAPixel;
     1420begin
     1421  result := GSBAToBGRA(self);
     1422end;
     1423
     1424procedure TGSBAPixelBasicHelper.FromBGRAPixel(AValue: TBGRAPixel);
     1425begin
     1426  self := BGRAToGSBA(AValue);
     1427end;
     1428
     1429function TGSBAPixelBasicHelper.ToHSLAPixel: THSLAPixel;
     1430begin
     1431  result := GSBAToHSLA(self);
     1432end;
     1433
     1434procedure TGSBAPixelBasicHelper.FromHSLAPixel(AValue: THSLAPixel);
     1435begin
     1436  self := HSLAToGSBA(AValue);
     1437end;
     1438
     1439function TGSBAPixelBasicHelper.ToExpanded: TExpandedPixel;
     1440begin
     1441  result := GSBAToExpanded(self);
     1442end;
     1443
     1444procedure TGSBAPixelBasicHelper.FromExpanded(AValue: TExpandedPixel);
     1445begin
     1446  self := ExpandedToGSBA(AValue);
     1447end;
     1448
     1449operator :=(const Source: TGSBAPixel): TBGRAPixel;
     1450begin
     1451  result := GSBAToBGRA(Source);
     1452end;
     1453
     1454operator :=(const Source: TBGRAPixel): TGSBAPixel;
     1455begin
     1456  result := BGRAToGSBA(Source);
     1457end;
     1458
     1459operator :=(const Source: TGSBAPixel): TExpandedPixel;
     1460begin
     1461  result := GSBAToExpanded(Source);
     1462end;
     1463
     1464operator:=(const Source: TExpandedPixel): TGSBAPixel;
     1465begin
     1466  result := ExpandedToGSBA(Source);
     1467end;
     1468
     1469operator := (const AValue: TColor): TGSBAPixel;
     1470begin Result := BGRAToGSBA(ColorToBGRA(ColorToRGB(AValue))) end;
     1471
     1472operator := (const AValue: TGSBAPixel): TColor;
     1473begin Result := BGRAToColor(GSBAToBGRA(AValue)) end;
     1474
     1475operator :=(const Source: TGSBAPixel): THSLAPixel;
     1476begin
     1477  result := THSLAPixel(Pointer(@Source)^);
     1478end;
     1479
     1480operator:=(const Source: THSLAPixel): TGSBAPixel;
     1481begin
     1482  result := TGSBAPixel(Pointer(@Source)^);
     1483end;
    11131484{$ENDIF}
  • GraphicTest/Packages/bgrabitmap/bglvirtualscreen.pas

    r494 r521  
    1616  TBGLElapseEvent = procedure (Sender: TObject; BGLContext: TBGLContext; ElapsedMs: integer) of object;
    1717  TBGLFramesPerSecondEvent = procedure (Sender: TObject; BGLContext: TBGLContext; FramesPerSecond: integer) of object;
     18  TBGLUseContextCallback = procedure (Sender: TObject; BGLContext: TBGLContext; Data: Pointer) of object;
    1819
    1920  { TCustomBGLVirtualScreen }
     
    6061    procedure QueryLoadTextures; virtual;
    6162    procedure UnloadTextures; virtual;
     63    procedure UseContext(ACallback: TBGLUseContextCallback; AData: Pointer = nil);
    6264    constructor Create(TheOwner: TComponent); override;
    6365    destructor Destroy; override;
     
    350352end;
    351353
     354procedure TCustomBGLVirtualScreen.UseContext(ACallback: TBGLUseContextCallback; AData: Pointer);
     355var
     356  ctx: TBGLContext;
     357begin
     358  if not MakeCurrent then
     359    raise exception.Create('Unable to switch to the OpenGL context');
     360  ctx := PrepareBGLContext;
     361  try
     362    ACallback(self, ctx, AData);
     363  finally
     364    ReleaseBGLContext(ctx);
     365  end;
     366end;
     367
    352368procedure TCustomBGLVirtualScreen.RedrawContent(ctx: TBGLContext);
    353369var
  • GraphicTest/Packages/bgrabitmap/bgraanimatedgif.pas

    r494 r521  
    3939
    4040    procedure CheckFrameIndex(AIndex: integer);
     41    function GetAverageDelayMs: integer;
    4142    function GetCount: integer;
    4243    function GetFrameDelayMs(AIndex: integer): integer;
     
    8182    EraseColor:     TColor;
    8283    BackgroundMode: TGifBackgroundMode;
    83 
    84     constructor Create(filenameUTF8: string);
    85     constructor Create(stream: TStream);
    86     constructor Create; override;
     84    LoopCount:      Word;
     85    LoopDone:       Integer;
     86
     87    constructor Create(filenameUTF8: string); overload;
     88    constructor Create(stream: TStream); overload;
     89    constructor Create(stream: TStream; AMaxImageCount: integer); overload;
     90    constructor Create; overload; override;
    8791    function Duplicate: TBGRAAnimatedGif;
    8892    function AddFrame(AImage: TFPCustomImage; X,Y: integer; ADelayMs: integer;
    8993      ADisposeMode: TDisposeMode = dmErase; AHasLocalPalette: boolean = false) : integer;
    90     procedure InsertFrame(AIndex: integer; AImage: TBGRABitmap; X,Y: integer; ADelayMs: integer;
     94    procedure InsertFrame(AIndex: integer; AImage: TFPCustomImage; X,Y: integer; ADelayMs: integer;
    9195      ADisposeMode: TDisposeMode = dmErase; AHasLocalPalette: boolean = false);
     96    procedure DeleteFrame(AIndex: integer; AEnsureNextFrameDoesNotChange: boolean);
     97
     98    //add a frame that replaces completely the previous one
     99    function AddFullFrame(AImage: TFPCustomImage; ADelayMs: integer;
     100                          AHasLocalPalette: boolean = true): integer;
     101    procedure InsertFullFrame(AIndex: integer;
     102                              AImage: TFPCustomImage; ADelayMs: integer;
     103                              AHasLocalPalette: boolean = true);
     104    procedure ReplaceFullFrame(AIndex: integer;
     105                              AImage: TFPCustomImage; ADelayMs: integer;
     106                              AHasLocalPalette: boolean = true);
    92107
    93108    {TGraphic}
    94     procedure LoadFromStream(Stream: TStream); override;
    95     procedure SaveToStream(Stream: TStream); override;
     109    procedure LoadFromStream(Stream: TStream); overload; override;
     110    procedure LoadFromStream(Stream: TStream; AMaxImageCount: integer); overload;
     111    procedure LoadFromResource(AFilename: string);
     112    procedure SaveToStream(Stream: TStream); overload; override;
    96113    procedure LoadFromFile(const AFilenameUTF8: string); override;
    97114    procedure SaveToFile(const AFilenameUTF8: string); override;
     
    100117    procedure SetSize(AWidth,AHeight: integer); virtual;
    101118    procedure SaveToStream(Stream: TStream; AQuantizer: TBGRAColorQuantizerAny;
    102       ADitheringAlgorithm: TDitheringAlgorithm); virtual; overload;
     119      ADitheringAlgorithm: TDitheringAlgorithm); overload; virtual;
    103120    procedure Clear; override;
    104121    destructor Destroy; override;
     
    126143    property AspectRatio: single read FAspectRatio write SetAspectRatio;
    127144    property TotalAnimationTimeMs: Int64 read FTotalAnimationTime;
     145    property AverageDelayMs: integer read GetAverageDelayMs;
    128146  end;
    129147
     
    184202  data.BackgroundColor := BackgroundColor;
    185203  data.Images := FImages;
     204  data.LoopCount := LoopCount;
    186205  GIFSaveToStream(data, Stream, AQuantizer, ADitheringAlgorithm);
    187206end;
     
    233252      Inc(nextImage);
    234253      if nextImage >= Count then
    235         nextImage := 0;
     254      begin
     255        if (LoopCount > 0) and (LoopDone >= LoopCount-1) then
     256        begin
     257          LoopDone := LoopCount;
     258          dec(nextImage);
     259          break;
     260        end else
     261        begin
     262          nextImage := 0;
     263          inc(LoopDone);
     264        end;
     265      end;
    236266
    237267      if nextImage = previousImage then
    238268      begin
    239         Inc(nextImage);
    240         if nextImage >= Count then
    241           nextImage := 0;
     269        if not ((LoopCount > 0) and (LoopDone >= LoopCount-1)) then
     270        begin
     271          Inc(nextImage);
     272          if nextImage >= Count then
     273            nextImage := 0;
     274        end;
    242275        break;
    243276      end;
     
    370403end;
    371404
     405function TBGRAAnimatedGif.GetAverageDelayMs: integer;
     406var sum: int64;
     407  i: Integer;
     408begin
     409  if Count > 0 then
     410  begin
     411    sum := 0;
     412    for i := 0 to Count-1 do
     413      inc(sum, FrameDelayMs[i]);
     414    result := sum div Count;
     415  end else
     416    result := 100; //default
     417end;
     418
    372419function TBGRAAnimatedGif.GetCount: integer;
    373420begin
     
    437484end;
    438485
     486constructor TBGRAAnimatedGif.Create(stream: TStream; AMaxImageCount: integer);
     487begin
     488  inherited Create;
     489  Init;
     490  LoadFromStream(stream, AMaxImageCount);
     491end;
     492
    439493constructor TBGRAAnimatedGif.Create;
    440494begin
     
    478532end;
    479533
    480 procedure TBGRAAnimatedGif.InsertFrame(AIndex: integer; AImage: TBGRABitmap; X,
     534procedure TBGRAAnimatedGif.InsertFrame(AIndex: integer; AImage: TFPCustomImage; X,
    481535  Y: integer; ADelayMs: integer; ADisposeMode: TDisposeMode;
    482536  AHasLocalPalette: boolean);
     
    491545  with FImages[AIndex] do
    492546  begin
    493     Image := AImage.Duplicate as TBGRABitmap;
     547    Image := TBGRABitmap.Create(AImage);
    494548    Position := Point(x,y);
    495549    DelayMs := ADelayMs;
     
    500554end;
    501555
     556function TBGRAAnimatedGif.AddFullFrame(AImage: TFPCustomImage;
     557  ADelayMs: integer; AHasLocalPalette: boolean): integer;
     558begin
     559  if (AImage.Width <> Width) or (AImage.Height <> Height) then
     560    raise exception.Create('Size mismatch');
     561  if Count > 0 then
     562    FrameDisposeMode[Count-1] := dmErase;
     563  result := AddFrame(AImage, 0,0, ADelayMs, dmErase, AHasLocalPalette);
     564end;
     565
     566procedure TBGRAAnimatedGif.InsertFullFrame(AIndex: integer;
     567  AImage: TFPCustomImage; ADelayMs: integer; AHasLocalPalette: boolean);
     568var nextImage: TBGRABitmap;
     569begin
     570  if (AIndex < 0) or (AIndex > Count) then
     571    raise ERangeError.Create('Index out of bounds');
     572
     573  if AIndex = Count then
     574    AddFullFrame(AImage, ADelayMs, AHasLocalPalette)
     575  else
     576  begin
     577    //if previous image did not clear up, ensure that
     578    //next image will stay the same
     579    if (AIndex > 0) and (FrameDisposeMode[AIndex-1] <> dmErase) then
     580    begin
     581      CurrentImage := AIndex;
     582      nextImage := MemBitmap.Duplicate as TBGRABitmap;
     583      FrameImagePos[AIndex] := Point(0,0);
     584      FrameImage[AIndex] := nextImage;
     585      FrameHasLocalPalette[AIndex] := true;
     586      FreeAndNil(nextImage);
     587
     588      FrameDisposeMode[AIndex-1] := dmErase;
     589    end;
     590
     591    InsertFrame(AIndex, AImage, 0,0, ADelayMs, dmErase, AHasLocalPalette);
     592  end;
     593end;
     594
     595procedure TBGRAAnimatedGif.ReplaceFullFrame(AIndex: integer;
     596  AImage: TFPCustomImage; ADelayMs: integer; AHasLocalPalette: boolean);
     597begin
     598  DeleteFrame(AIndex, True);
     599  if AIndex > 0 then FrameDisposeMode[AIndex-1] := dmErase;
     600  InsertFrame(AIndex, AImage, 0,0, ADelayMs, dmErase, AHasLocalPalette);
     601end;
     602
     603procedure TBGRAAnimatedGif.DeleteFrame(AIndex: integer;
     604  AEnsureNextFrameDoesNotChange: boolean);
     605var
     606  nextImage: TBGRABitmap;
     607  i: Integer;
     608begin
     609  CheckFrameIndex(AIndex);
     610
     611  //if this frame did not clear up, ensure that
     612  //next image will stay the same
     613  if AEnsureNextFrameDoesNotChange and
     614    ((AIndex < Count-1) and (FrameDisposeMode[AIndex] <> dmErase)) then
     615  begin
     616    CurrentImage := AIndex+1;
     617    nextImage := MemBitmap.Duplicate as TBGRABitmap;
     618    FrameImagePos[AIndex+1] := Point(0,0);
     619    FrameImage[AIndex+1] := nextImage;
     620    FrameHasLocalPalette[AIndex+1] := true;
     621    FreeAndNil(nextImage);
     622  end;
     623
     624  dec(FTotalAnimationTime, FImages[AIndex].DelayMs);
     625
     626  FImages[AIndex].Image.FreeReference;
     627  for i := AIndex to Count-2 do
     628    FImages[i] := FImages[i+1];
     629  SetLength(FImages, Count-1);
     630
     631  if (CurrentImage >= Count) then
     632    CurrentImage := 0;
     633end;
     634
    502635procedure TBGRAAnimatedGif.LoadFromStream(Stream: TStream);
     636begin
     637  LoadFromStream(Stream, maxLongint);
     638end;
     639
     640procedure TBGRAAnimatedGif.LoadFromStream(Stream: TStream;
     641  AMaxImageCount: integer);
    503642var data: TGIFData;
    504643  i: integer;
    505644begin
    506   data := GIFLoadFromStream(Stream);
     645  data := GIFLoadFromStream(Stream, AMaxImageCount);
    507646
    508647  ClearViewer;
     
    512651  FBackgroundColor := data.BackgroundColor;
    513652  FAspectRatio:= data.AspectRatio;
     653  LoopDone := 0;
     654  LoopCount := data.LoopCount;
    514655
    515656  SetLength(FImages, length(data.Images));
     
    519660    FImages[i] := data.Images[i];
    520661    FTotalAnimationTime += FImages[i].DelayMs;
     662  end;
     663end;
     664
     665procedure TBGRAAnimatedGif.LoadFromResource(AFilename: string);
     666var
     667  stream: TStream;
     668begin
     669  stream := BGRAResource.GetResourceStream(AFilename);
     670  try
     671    LoadFromStream(stream);
     672  finally
     673    stream.Free;
    521674  end;
    522675end;
     
    658811    FImages[i].Image.FreeReference;
    659812  FImages := nil;
     813  LoopDone := 0;
     814  LoopCount := 0;
    660815end;
    661816
     
    9591114begin
    9601115  BackgroundMode := gbmSaveBackgroundOnce;
     1116  LoopCount := 0;
     1117  LoopDone := 0;
    9611118end;
    9621119
     
    9811138  Mem:  TBGRABitmap;
    9821139begin
    983   gif := TBGRAAnimatedGif.Create(Str);
     1140  gif := TBGRAAnimatedGif.Create(Str, 1);
    9841141  Mem := gif.MemBitmap;
    9851142  if Img is TBGRABitmap then
  • GraphicTest/Packages/bgrabitmap/bgrabitmap.inc

    r494 r521  
    1717  to comment them if the functions are not available }
    1818{$DEFINE BGRABITMAP_USE_LCL12} { Use functions of Lazarus 1.2 }
    19 //{$DEFINE BGRABITMAP_USE_LCL15} { Use functions of Lazarus 1.5 }
     19{$DEFINE BGRABITMAP_USE_LCL15} { Use functions of Lazarus 1.5 }
    2020
    2121{$MODESWITCH ADVANCEDRECORDS}
     22{$MODESWITCH TypeHelpers}
     23
  • GraphicTest/Packages/bgrabitmap/bgrabitmap.pas

    r494 r521  
    133133  begin
    134134    ...
    135     BGRAReplace(temp, someBmp.Filter... );
     135    BGRAReplace(someBmp, someBmp.Filter... );
    136136  end;
    137137}
  • GraphicTest/Packages/bgrabitmap/bgrabitmappack.lpk

    r494 r521  
    99      <PathDelim Value="\"/>
    1010      <SearchPaths>
    11         <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\$(FPCVer)"/>
     11        <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)-$(BuildMode)"/>
    1212      </SearchPaths>
    1313      <Parsing>
     
    1818      <CodeGeneration>
    1919        <Optimizations>
    20           <OptimizationLevel Value="3"/>
     20          <OptimizationLevel Value="0"/>
    2121          <VariablesInRegisters Value="True"/>
    2222        </Optimizations>
     
    3030    <Description Value="Drawing routines with alpha blending and antialiasing"/>
    3131    <License Value="modified LGPL"/>
    32     <Version Major="9" Minor="3"/>
    33     <Files Count="108">
     32    <Version Major="9" Minor="9" Release="3"/>
     33    <Files Count="120">
    3434      <Item1>
    3535        <Filename Value="bgraanimatedgif.pas"/>
     
    454454      <Item106>
    455455        <Filename Value="bgramultifiletype.pas"/>
    456         <UnitName Value="bgramultifiletype"/>
     456        <UnitName Value="BGRAMultiFileType"/>
    457457      </Item106>
    458458      <Item107>
     
    464464        <UnitName Value="BGRALazResource"/>
    465465      </Item108>
     466      <Item109>
     467        <Filename Value="bgraiconcursor.pas"/>
     468        <UnitName Value="BGRAIconCursor"/>
     469      </Item109>
     470      <Item110>
     471        <Filename Value="bgrablurgl.pas"/>
     472        <UnitName Value="BGRABlurGL"/>
     473      </Item110>
     474      <Item111>
     475        <Filename Value="bgrareadtiff.pas"/>
     476        <UnitName Value="BGRAReadTiff"/>
     477      </Item111>
     478      <Item112>
     479        <Filename Value="bgralazpaint.pas"/>
     480        <UnitName Value="BGRALazPaint"/>
     481      </Item112>
     482      <Item113>
     483        <Filename Value="bgramemdirectory.pas"/>
     484        <UnitName Value="BGRAMemDirectory"/>
     485      </Item113>
     486      <Item114>
     487        <Filename Value="bgraunicode.pas"/>
     488        <UnitName Value="BGRAUnicode"/>
     489      </Item114>
     490      <Item115>
     491        <Filename Value="bgratextbidi.pas"/>
     492        <UnitName Value="BGRATextBidi"/>
     493      </Item115>
     494      <Item116>
     495        <Filename Value="bgralayeroriginal.pas"/>
     496        <UnitName Value="BGRALayerOriginal"/>
     497      </Item116>
     498      <Item117>
     499        <Filename Value="bgrasvgoriginal.pas"/>
     500        <UnitName Value="BGRASVGOriginal"/>
     501      </Item117>
     502      <Item118>
     503        <Filename Value="bgragradientoriginal.pas"/>
     504        <UnitName Value="BGRAGradientOriginal"/>
     505      </Item118>
     506      <Item119>
     507        <Filename Value="bgrapixel.inc"/>
     508        <Type Value="Include"/>
     509      </Item119>
     510      <Item120>
     511        <Filename Value="bezier.inc"/>
     512        <Type Value="Binary"/>
     513      </Item120>
    466514    </Files>
    467515    <RequiredPkgs Count="2">
     
    479527    <PublishOptions>
    480528      <Version Value="2"/>
    481       <IgnoreBinaries Value="False"/>
    482529    </PublishOptions>
    483530    <CustomOptions Items="ExternHelp" Version="2">
  • GraphicTest/Packages/bgrabitmap/bgrabitmappack.pas

    r494 r521  
    55unit BGRABitmapPack;
    66
     7{$warn 5023 off : no warning about unused units}
    78interface
    89
     
    2425  BGRAWriteBmpMioMap, BGRAOpenGLType, BGRASpriteGL, BGRAOpenGL, BGRACanvasGL,
    2526  BGRAFontGL, BGRAOpenGL3D, BGRAPhoxo, BGRAFilterScanner, BGRAFilterType,
    26   BGRAFilterBlur, BGRAMultiFileType, BGRAWinResource, BGRALazResource;
     27  BGRAFilterBlur, BGRAMultiFileType, BGRAWinResource, BGRALazResource,
     28  BGRAIconCursor, BGRABlurGL, BGRAReadTiff, BGRALazPaint, BGRAMemDirectory,
     29  BGRAUnicode, BGRATextBidi, BGRALayerOriginal, BGRASVGOriginal,
     30  BGRAGradientOriginal;
    2731
    2832implementation
  • GraphicTest/Packages/bgrabitmap/bgrabitmappack4fpgui.lpk

    r494 r521  
    3434    <Description Value="Drawing routines with alpha blending and antialiasing"/>
    3535    <License Value="modified LGPL"/>
    36     <Version Major="9" Minor="3"/>
    37     <Files Count="96">
     36    <Version Major="9" Minor="9" Release="3"/>
     37    <Files Count="97">
    3838      <Item1>
    3939        <Filename Value="bgraanimatedgif.pas"/>
     
    417417      </Item95>
    418418      <Item96>
    419         <Filename Value="bgralazresource.pas"/>
    420         <UnitName Value="BGRALazResource"/>
     419        <Filename Value="bgraunicode.pas"/>
     420        <UnitName Value="BGRAUnicode"/>
    421421      </Item96>
     422      <Item97>
     423        <Filename Value="bezier.inc"/>
     424        <Type Value="Include"/>
     425      </Item97>
    422426    </Files>
    423427    <RequiredPkgs Count="3">
  • GraphicTest/Packages/bgrabitmap/bgrabitmappack4fpgui.pas

    r494 r521  
    2323  BGRAWritePNG, BGRAGifFormat, BGRASceneTypes, BGRARenderer3D,
    2424  BGRAWriteBmpMioMap, BGRAPhoxo, BGRAFilterScanner, BGRAFilterType,
    25   BGRAFilterBlur;
     25  BGRAFilterBlur, BGRAMultiFileType, BGRAWinResource, BGRAUnicode;
    2626
    2727implementation
  • GraphicTest/Packages/bgrabitmap/bgrabitmappack4nogui.lpk

    r494 r521  
    3636    <Description Value="Drawing routines with alpha blending and antialiasing"/>
    3737    <License Value="modified LGPL"/>
    38     <Version Major="9" Minor="3"/>
    39     <Files Count="100">
     38    <Version Major="9" Minor="9" Release="3"/>
     39    <Files Count="101">
    4040      <Item1>
    4141        <Filename Value="bgraanimatedgif.pas"/>
     
    435435      </Item99>
    436436      <Item100>
    437         <Filename Value="bgralazresource.pas"/>
    438         <UnitName Value="BGRALazResource"/>
     437        <Filename Value="bgraunicode.pas"/>
     438        <UnitName Value="BGRAUnicode"/>
    439439      </Item100>
     440      <Item101>
     441        <Filename Value="bezier.inc"/>
     442        <Type Value="Include"/>
     443      </Item101>
    440444    </Files>
    441445    <RequiredPkgs Count="2">
  • GraphicTest/Packages/bgrabitmap/bgrabitmappack4nogui.pas

    r494 r521  
    55unit BGRABitmapPack4NoGUI;
    66
     7{$warn 5023 off : no warning about unused units}
    78interface
    89
     
    2324  BGRANoGUIBitmap, BGRASceneTypes, BGRARenderer3D, BGRAWriteBmpMioMap,
    2425  BGRASpriteGL, BGRAOpenGLType, BGRAOpenGL, BGRACanvasGL, BGRAPhoxo,
    25   BGRAFilterScanner, BGRAFilterType;
     26  BGRAFilterScanner, BGRAFilterType, BGRAFilterBlur, BGRAMultiFileType,
     27  BGRAWinResource, BGRAUnicode;
    2628
    2729implementation
  • GraphicTest/Packages/bgrabitmap/bgrabitmaptypes.pas

    r494 r521  
    3333uses
    3434  Classes, Types, BGRAGraphics,
    35   FPImage, FPImgCanv{$IFDEF BGRABITMAP_USE_LCL}, GraphType{$ENDIF},
     35  FPImage, FPImgCanv{$IFDEF BGRABITMAP_USE_LCL}, LCLType, GraphType, LResources{$ENDIF},
    3636  BGRAMultiFileType;
    3737
     
    4040  Int32or64 = {$IFDEF CPU64}Int64{$ELSE}LongInt{$ENDIF};
    4141  UInt32or64 = {$IFDEF CPU64}UInt64{$ELSE}LongWord{$ENDIF};
     42  HDC = {$IFDEF BGRABITMAP_USE_LCL}LCLType.HDC{$ELSE}PtrUInt{$ENDIF};
    4243
    4344{=== Miscellaneous types ===}
     
    7879
    7980  TTextLayout = BGRAGraphics.TTextLayout;
     81  TFontBidiMode = (fbmAuto, fbmLeftToRight, fbmRightToLeft);
     82  TBidiTextAlignment = (btaNatural, btaOpposite, btaLeftJustify, btaRightJustify, btaCenter);
    8083
    8184const
     85  RadialBlurTypeToStr: array[TRadialBlurType] of string =
     86  ('Normal','Disk','Corona','Precise','Fast','Box');
     87
     88
    8289  tlTop = BGRAGraphics.tlTop;
    8390  tlCenter = BGRAGraphics.tlCenter;
     
    285292    {** Returns the total size of the string provided using the current font.
    286293        Orientation is not taken into account, so that the width is along the text }
    287     function TextSize(sUTF8: string): TSize; virtual; abstract;
     294    function TextSize(sUTF8: string): TSize; overload; virtual; abstract;
     295    function TextSize(sUTF8: string; AMaxWidth: integer; ARightToLeft: boolean): TSize; overload; virtual; abstract;
     296
     297    function TextFitInfo(sUTF8: string; AMaxWidth: integer): integer; virtual; abstract;
     298    function TextSizeAngle(sUTF8: string; {%H-}orientationTenthDegCCW: integer): TSize; virtual;
    288299
    289300    {** Draws the UTF8 encoded string, with color ''c''.
     
    292303        If align is taRightJustify, (''x'',''y'') is the top-right corner.
    293304        The value of ''FontOrientation'' is taken into account, so that the text may be rotated }
    294     procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment); virtual; abstract;
     305    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment); overload; virtual; abstract;
     306    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment; {%H-}ARightToLeft: boolean); overload; virtual;
    295307
    296308    {** Same as above functions, except that the text is filled using texture.
    297309        The value of ''FontOrientation'' is taken into account, so that the text may be rotated }
    298     procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment); virtual; abstract;
     310    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment); overload; virtual; abstract;
     311    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment; {%H-}ARightToLeft: boolean); overload; virtual;
    299312
    300313    {** Same as above, except that the orientation is specified, overriding the value of the property ''FontOrientation'' }
    301     procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; c: TBGRAPixel; align: TAlignment); virtual; abstract;
     314    procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; c: TBGRAPixel; align: TAlignment); overload; virtual; abstract;
    302315    {** Same as above, except that the orientation is specified, overriding the value of the property ''FontOrientation'' }
    303     procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; texture: IBGRAScanner; align: TAlignment); virtual; abstract;
     316    procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; texture: IBGRAScanner; align: TAlignment); overload; virtual; abstract;
    304317
    305318    {** Draw the UTF8 encoded string at the coordinate (''x'',''y''), clipped inside the rectangle ''ARect''.
    306319        Additional style information is provided by the style parameter.
    307320        The color ''c'' is used to fill the text. No rotation is applied. }
    308     procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; c: TBGRAPixel); virtual; abstract;
     321    procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; c: TBGRAPixel); overload; virtual; abstract;
    309322
    310323    {** Same as above except a ''texture'' is used to fill the text }
    311     procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; texture: IBGRAScanner); virtual; abstract;
     324    procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; texture: IBGRAScanner); overload; virtual; abstract;
    312325
    313326    {** Copy the path for the UTF8 encoded string into ''ADest''.
     
    316329        If ''align'' is ''taRightJustify'', (''x'',''y'') is the top-right corner. }
    317330    procedure CopyTextPathTo({%H-}ADest: IBGRAPath; {%H-}x, {%H-}y: single; {%H-}s: string; {%H-}align: TAlignment); virtual; //optional
     331    function HandlesTextPath: boolean; virtual;
    318332  end;
    319333
     
    332346    byte index }
    333347function RemoveLineEndingUTF8(var sUTF8: string; indexUTF8: integer): boolean;
    334 {** Default word break handler, that simply divide when there is a space }
     348{** Default word break handler }
    335349procedure BGRADefaultWordBreakHandler(var ABefore, AAfter: string);
    336350
     
    395409    ifGif,
    396410    {** BMP format, transparency, no compression. Note that transparency is
    397         not supported by all BMP readers so it is not recommended to avoid
     411        not supported by all BMP readers so it is recommended to avoid
    398412        storing images with transparency in this format }
    399413    ifBmp,
     414    {** iGO BMP (16-bit, rudimentary lossless compression) }
     415    ifBmpMioMap,
    400416    {** ICO format, contains different sizes of the same image }
    401417    ifIco,
     418    {** CUR format, has hotspot, contains different sizes of the same image }
     419    ifCur,
    402420    {** PCX format, opaque, rudimentary lossless compression }
    403421    ifPcx,
     
    420438    {** X-Pixmap, text encoded image, limited support }
    421439    ifXPixMap,
    422     {** iGO BMP, limited support }
    423     ifBmpMioMap);
     440    {** Scalable Vector Graphic, vectorial, read-only as raster }
     441    ifSvg);
     442
     443  {* Image information from superficial analysis }
     444  TQuickImageInfo = record
     445    {** Width in pixels }
     446    Width,
     447    {** Height in pixels }
     448    Height,
     449    {** Bitdepth for colors (1, 2, 4, 8 for images with palette/grayscale, 16, 24 or 48 if each channel is present) }
     450    ColorDepth,
     451    {** Bitdepth for alpha (0 if no alpha channel, 1 if bit mask, 8 or 16 if alpha channel) }
     452    AlphaDepth: integer;
     453  end;
     454
     455  {* Bitmap reader with additional features }
     456  TBGRAImageReader = class(TFPCustomImageReader)
     457    {** Return bitmap information (size, bit depth) }
     458    function GetQuickInfo(AStream: TStream): TQuickImageInfo; virtual; abstract;
     459    {** Return a draft of the bitmap, the ratio may change compared to the original width and height (useful to make thumbnails) }
     460    function GetBitmapDraft(AStream: TStream; AMaxWidth, AMaxHeight: integer; out AOriginalWidth,AOriginalHeight: integer): TBGRACustomBitmap; virtual; abstract;
     461  end;
    424462
    425463  {* Options when loading an image }
     
    458496{$I bgracustombitmap.inc}
    459497
     498operator =(const AGuid1, AGuid2: TGuid): boolean;
     499
     500type
     501  { TBGRAResourceManager }
     502
     503  TBGRAResourceManager = class
     504  protected
     505    function GetWinResourceType(AExtension: string): pchar;
     506  public
     507    function GetResourceStream(AFilename: string): TStream; virtual;
     508    function IsWinResource(AFilename: string): boolean; virtual;
     509  end;
     510
     511var
     512  BGRAResource : TBGRAResourceManager;
     513
    460514implementation
    461515
    462 uses Math, SysUtils, BGRAUTF8,
    463   FPReadTiff, FPReadXwd, FPReadXPM,
     516uses Math, SysUtils, BGRAUTF8, BGRAUnicode,
     517  FPReadXwd, FPReadXPM,
    464518  FPWriteTiff, FPWriteJPEG, BGRAWritePNG, FPWriteBMP, FPWritePCX,
    465519  FPWriteTGA, FPWriteXPM;
     
    532586
    533587procedure BGRADefaultWordBreakHandler(var ABefore, AAfter: string);
    534 var p: integer;
    535 begin
    536   if (AAfter <> '') and (ABefore <> '') and (AAfter[1]<> ' ') and (ABefore[length(ABefore)] <> ' ') then
     588const spacingChars = [' '];
     589  wordBreakChars = [' ',#9,'-','?','!'];
     590var p, charLen: integer;
     591  u: Cardinal;
     592begin
     593  if (AAfter <> '') and (ABefore <> '') and not (AAfter[1] in spacingChars) and not (ABefore[length(ABefore)] in wordBreakChars) then
    537594  begin
    538595    p := length(ABefore);
    539     while (p > 1) and (ABefore[p-1] <> ' ') do dec(p);
     596    while (p > 1) and not (ABefore[p-1] in wordBreakChars) do dec(p);
     597    while (p < length(ABefore)+1) and (ABefore[p] in [#$80..#$BF]) do inc(p); //do not split UTF8 char
     598    //keep non-spacing mark together
     599    while p <= length(ABefore) do
     600    begin
     601      charLen := UTF8CharacterLength(@ABefore[p]);
     602      if p+charLen > length(ABefore)+1 then charLen := length(ABefore)+1-p;
     603      u := UTF8CodepointToUnicode(@ABefore[p],charLen);
     604      if GetUnicodeBidiClass(u) = ubcNonSpacingMark then
     605        inc(p,charLen)
     606      else
     607        break;
     608    end;
     609
     610    if p = 1 then
     611    begin
     612      //keep ideographic punctuation together
     613      charLen := UTF8CharacterLength(@AAfter[p]);
     614      if charLen > length(AAfter) then charLen := length(AAfter);
     615      u := UTF8CodepointToUnicode(@AAfter[p],charLen);
     616      case u of
     617      UNICODE_IDEOGRAPHIC_COMMA,
     618      UNICODE_IDEOGRAPHIC_FULL_STOP,
     619      UNICODE_FULLWIDTH_COMMA,
     620      UNICODE_HORIZONTAL_ELLIPSIS:
     621        begin
     622          p := length(ABefore)+1;
     623          while p > 1 do
     624          begin
     625            charLen := 1;
     626            dec(p);
     627            while (p > 0) and (ABefore[p] in [#$80..#$BF]) do
     628            begin
     629              dec(p); //do not split UTF8 char
     630              inc(charLen);
     631            end;
     632            if charLen <= 4 then
     633              u := UTF8CodepointToUnicode(@ABefore[p],charLen)
     634            else
     635              u := ord('A');
     636            case GetUnicodeBidiClass(u) of
     637              ubcNonSpacingMark: ;   // include NSM
     638              ubcOtherNeutrals, ubcWhiteSpace, ubcCommonSeparator, ubcEuropeanNumberSeparator:
     639                begin
     640                  p := 1;
     641                  break;
     642                end
     643            else
     644              break;
     645            end;
     646          end;
     647        end;
     648      end;
     649    end;
     650
    540651    if p > 1 then //can put the word after
    541652    begin
     
    547658    end;
    548659  end;
    549   while (ABefore <> '') and (ABefore[length(ABefore)] =' ') do delete(ABefore,length(ABefore),1);
    550   while (AAfter <> '') and (AAfter[1] =' ') do delete(AAfter,1,1);
     660  while (ABefore <> '') and (ABefore[length(ABefore)] in spacingChars) do delete(ABefore,length(ABefore),1);
     661  while (AAfter <> '') and (AAfter[1] in spacingChars) do delete(AAfter,1,1);
    551662end;
    552663
     
    567678{ TBGRACustomFontRenderer }
    568679
     680function TBGRACustomFontRenderer.TextSizeAngle(sUTF8: string;
     681  orientationTenthDegCCW: integer): TSize;
     682begin
     683  result := TextSize(sUTF8); //ignore orientation by default
     684end;
     685
     686procedure TBGRACustomFontRenderer.TextOut(ADest: TBGRACustomBitmap; x,
     687  y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment;
     688  ARightToLeft: boolean);
     689begin
     690  //if RightToLeft is not handled
     691  TextOut(ADest,x,y,sUTF8,c,align);
     692end;
     693
     694procedure TBGRACustomFontRenderer.TextOut(ADest: TBGRACustomBitmap; x,
     695  y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment;
     696  ARightToLeft: boolean);
     697begin
     698  //if RightToLeft is not handled
     699  TextOut(ADest,x,y,sUTF8,texture,align);
     700end;
     701
    569702procedure TBGRACustomFontRenderer.CopyTextPathTo(ADest: IBGRAPath; x, y: single; s: string; align: TAlignment);
    570703begin {optional implementation} end;
     704
     705function TBGRACustomFontRenderer.HandlesTextPath: boolean;
     706begin
     707  result := false;
     708end;
    571709
    572710
     
    825963    end;
    826964
    827     if (magic[0] = $00) and (magic[1] = $00) and (magic[2] in[$01,$02]) and (magic[3] = $00) and
    828       (magic[4] + (magic[5] shl 8) > 0) then inc(scores[ifIco]);
     965    if (magic[0] = $00) and (magic[1] = $00) and (magic[3] = $00) and
     966      (magic[4] + (magic[5] shl 8) > 0) then
     967    begin
     968      if magic[2] = $01 then
     969        inc(scores[ifIco])
     970      else if magic[2] = $02 then
     971        inc(scores[ifCur]);
     972    end;
    829973
    830974    if (copy(magicAsText,1,4) = 'PDN3') then
     
    852996      with CreateBGRAImageReader(ifOpenRaster) do
    853997        try
     998          AStream.Position := streamStartPos;
    854999          if CheckContents(AStream) then inc(scores[ifOpenRaster],2);
    8551000        finally
     
    8661011
    8671012    if (copy(magicAsText,1,8) = '/* XPM *') or (copy(magicAsText,1,6) = '! XPM2') then inc(scores[ifXPixMap]);
     1013
     1014    if (copy(magicAsText,1,6) = '<?xml ') then inc(scores[ifSvg]);
    8681015
    8691016    AStream.Position := streamStartPos;
     
    9151062  if (ext = '.pcx') then result := ifPcx else
    9161063  if (ext = '.bmp') then result := ifBmp else
    917   if (ext = '.ico') or (ext = '.cur') then result := ifIco else
     1064  if (ext = '.ico') then result := ifIco else
     1065  if (ext = '.cur') then result := ifCur else
    9181066  if (ext = '.pdn') then result := ifPaintDotNet else
    9191067  if (ext = '.lzp') then result := ifLazPaint else
     
    9241072  if (ext = '.xwd') then result := ifXwd else
    9251073  if (ext = '.xpm') then result := ifXPixMap else
    926   if (ext = '.oxo') then result := ifPhoxo;
     1074  if (ext = '.oxo') then result := ifPhoxo else
     1075  if (ext = '.svg') then result := ifSvg;
    9271076end;
    9281077
     
    9341083    ifGif: result := 'gif';
    9351084    ifBmp: result := 'bmp';
     1085    ifBmpMioMap: result := 'bmp';
    9361086    ifIco: result := 'ico';
     1087    ifCur: result := 'ico';
    9371088    ifPcx: result := 'pcx';
    9381089    ifPaintDotNet: result := 'pdn';
    9391090    ifLazPaint: result := 'lzp';
    9401091    ifOpenRaster: result := 'ora';
     1092    ifPhoxo: result := 'oXo';
    9411093    ifPsd: result := 'psd';
    9421094    ifTarga: result := 'tga';
     
    9441096    ifXwd: result := 'xwd';
    9451097    ifXPixMap: result := 'xpm';
    946     ifBmpMioMap: result := 'bmp';
     1098    ifSvg: result := 'svg';
    9471099    else result := '?';
    9481100  end;
     
    9571109      ifOpenRaster: raise exception.Create('You need to call BGRAOpenRaster.RegisterOpenRasterFormat to read this image.');
    9581110      ifPaintDotNet: raise exception.Create('You need to call BGRAPaintNet.RegisterPaintNetFormat to read this image.');
     1111      ifSvg: raise exception.Create('You need to call BGRA.RegisterSvgFormat to read this image.');
    9591112    else
    9601113      raise exception.Create('The image reader is not registered for this image format.');
     
    9711124      ifUnknown: raise exception.Create('The image format is unknown');
    9721125      ifOpenRaster: raise exception.Create('You need to call BGRAOpenRaster.RegisterOpenRasterFormat to write with this image format.');
     1126      ifPhoxo: raise exception.Create('You need to call BGRAPhoxo.RegisterPhoxoFormat to write with this image format.');
    9731127    else
    9741128      raise exception.Create('The image writer is not registered for this image format.');
     
    9951149    result := DefaultBGRAImageWriter[AFormat].Create;
    9961150end;
     1151
     1152operator =(const AGuid1, AGuid2: TGuid): boolean;
     1153begin
     1154  result := CompareMem(@AGuid1, @AGuid2, sizeof(TGuid));
     1155end;
     1156
     1157type
     1158  TResourceType = record
     1159    ext: string;
     1160    code: pchar;
     1161  end;
     1162
     1163const
     1164  ResourceTypes: array[1..7] of TResourceType =
     1165   ((ext: 'CUR'; code: RT_GROUP_CURSOR),
     1166    (ext: 'BMP'; code: RT_BITMAP),
     1167    (ext: 'ICO'; code: RT_GROUP_ICON),
     1168    (ext: 'DAT'; code: RT_RCDATA),
     1169    (ext: 'DATA'; code: RT_RCDATA),
     1170    (ext: 'HTM'; code: RT_HTML),
     1171    (ext: 'HTML'; code: RT_HTML));
     1172
     1173{ TBGRAResourceManager }
     1174
     1175function TBGRAResourceManager.GetWinResourceType(AExtension: string): pchar;
     1176var
     1177  i: Integer;
     1178begin
     1179  if (AExtension <> '') and (AExtension[1]='.') then delete(AExtension,1,1);
     1180  for i := low(ResourceTypes) to high(ResourceTypes) do
     1181    if AExtension = ResourceTypes[i].ext then
     1182      exit(ResourceTypes[i].code);
     1183
     1184  exit(RT_RCDATA);
     1185end;
     1186
     1187function TBGRAResourceManager.GetResourceStream(AFilename: string): TStream;
     1188var
     1189  name,ext: RawByteString;
     1190  rt: PChar;
     1191begin
     1192  ext := UpperCase(ExtractFileExt(AFilename));
     1193  name := ChangeFileExt(AFilename,'');
     1194  rt := GetWinResourceType(ext);
     1195
     1196  if (rt = RT_GROUP_CURSOR) or (rt = RT_GROUP_ICON) then
     1197    raise exception.Create('Not implemented');
     1198
     1199  result := TResourceStream.Create(HINSTANCE, name, rt);
     1200end;
     1201
     1202function TBGRAResourceManager.IsWinResource(AFilename: string): boolean;
     1203var
     1204  name,ext: RawByteString;
     1205  rt: PChar;
     1206begin
     1207  ext := UpperCase(ExtractFileExt(AFilename));
     1208  name := ChangeFileExt(AFilename,'');
     1209  rt := GetWinResourceType(ext);
     1210  result := FindResource(HINSTANCE, pchar(name), rt)<>0;
     1211end;
     1212
     1213{$IFDEF BGRABITMAP_USE_LCL}
     1214type
     1215
     1216  { TLCLResourceManager }
     1217
     1218  TLCLResourceManager = class(TBGRAResourceManager)
     1219  protected
     1220    function FindLazarusResource(AFilename: string): TLResource;
     1221  public
     1222    function GetResourceStream(AFilename: string): TStream; override;
     1223    function IsWinResource(AFilename: string): boolean; override;
     1224  end;
     1225
     1226function TLCLResourceManager.FindLazarusResource(AFilename: string): TLResource;
     1227var
     1228  name,ext: RawByteString;
     1229begin
     1230  ext := UpperCase(ExtractFileExt(AFilename));
     1231  if (ext<>'') and (ext[1]='.') then Delete(ext,1,1);
     1232  name := ChangeFileExt(AFilename,'');
     1233  if ext<>'' then
     1234    result := LazarusResources.Find(name,ext)
     1235  else
     1236    result := LazarusResources.Find(name);
     1237end;
     1238
     1239function TLCLResourceManager.GetResourceStream(AFilename: string): TStream;
     1240var
     1241  res: TLResource;
     1242begin
     1243  res := FindLazarusResource(AFilename);
     1244  if Assigned(res) then
     1245    result := TLazarusResourceStream.CreateFromHandle(res)
     1246  else
     1247    result := inherited GetResourceStream(AFilename);
     1248end;
     1249
     1250function TLCLResourceManager.IsWinResource(AFilename: string): boolean;
     1251begin
     1252  if FindLazarusResource(AFilename)<>nil then
     1253    result := false
     1254  else
     1255    Result:=inherited IsWinResource(AFilename);
     1256end;
     1257
     1258{$ENDIF}
    9971259
    9981260initialization
     
    10131275  //writing XWD not implemented
    10141276
    1015   DefaultBGRAImageReader[ifTiff] := TFPReaderTiff;
    10161277  DefaultBGRAImageReader[ifXwd] := TFPReaderXWD;
    10171278  //the other readers are registered by their unit
    10181279
     1280  {$IFDEF BGRABITMAP_USE_LCL}
     1281  BGRAResource := TLCLResourceManager.Create;
     1282  {$ELSE}
     1283  BGRAResource := TBGRAResourceManager.Create;
     1284  {$ENDIF}
     1285
    10191286finalization
    10201287
     
    10241291  {$DEFINE INCLUDE_FINAL}
    10251292  {$I bgrapixel.inc}
     1293
     1294  BGRAResource.Free;
    10261295end.
  • GraphicTest/Packages/bgrabitmap/bgrablend.pas

    r494 r521  
    698698procedure DrawPixelInlineWithAlphaCheck(dest: PBGRAPixel; const c: TBGRAPixel);
    699699begin
    700   if c.alpha = 0 then
    701     exit;
    702   if c.alpha = 255 then
    703   begin
    704     dest^ := c;
    705     exit;
    706   end;
    707   DrawPixelInlineNoAlphaCheck(dest,c);
     700  case c.alpha of
     701  0: ;
     702  255: dest^ := c;
     703  else
     704    DrawPixelInlineNoAlphaCheck(dest,c);
     705  end;
    708706end;
    709707
     
    711709begin
    712710  c.alpha := ApplyOpacity(c.alpha,appliedOpacity);
    713   if c.alpha = 0 then
    714     exit;
    715   if c.alpha = 255 then
    716   begin
    717     dest^ := c;
    718     exit;
    719   end;
    720   DrawPixelInlineNoAlphaCheck(dest,c);
     711  DrawPixelInlineWithAlphaCheck(dest, c);
    721712end;
    722713
     
    748739begin
    749740  calpha := ec.alpha shr 8;
    750   if calpha = 0 then
    751     exit;
    752   if calpha = 255 then
    753   begin
    754     dest^ := GammaCompression(ec);
    755     exit;
    756   end;
    757   DrawExpandedPixelInlineNoAlphaCheck(dest,ec,calpha);
     741  case calpha of
     742  0: ;
     743  255: dest^ := GammaCompression(ec);
     744  else
     745    DrawExpandedPixelInlineNoAlphaCheck(dest,ec,calpha);
     746  end;
    758747end;
    759748
    760749procedure DrawPixelInlineExpandedOrNotWithAlphaCheck(dest: PBGRAPixel; const ec: TExpandedPixel; c: TBGRAPixel);
    761750begin
    762   if c.alpha = 0 then
    763     exit;
    764   if c.alpha = 255 then
    765   begin
    766     dest^ := c;
    767     exit;
    768   end;
    769   DrawExpandedPixelInlineNoAlphaCheck(dest,ec,c.alpha);
     751  case c.alpha of
     752  0: ;
     753  255: dest^ := c;
     754  else
     755    DrawExpandedPixelInlineNoAlphaCheck(dest,ec,c.alpha);
     756  end;
    770757end;
    771758
    772759procedure DrawPixelInlineNoAlphaCheck(dest: PBGRAPixel; const c: TBGRAPixel);
    773760var
    774   a1f, a2f, a12, a12m: cardinal;
    775 begin
    776   {$HINTS OFF}
    777   a12  := 65025 - (not dest^.alpha) * (not c.alpha);
    778   {$HINTS ON}
    779   a12m := a12 shr 1;
    780 
    781   a1f := dest^.alpha * (not c.alpha);
    782   a2f := (c.alpha shl 8) - c.alpha;
    783 
    784   PDWord(dest)^ := ((GammaCompressionTab[(GammaExpansionTab[dest^.red] * a1f +
    785                      GammaExpansionTab[c.red] * a2f + a12m) div a12]) shl TBGRAPixel_RedShift) or
    786                    ((GammaCompressionTab[(GammaExpansionTab[dest^.green] * a1f +
    787                      GammaExpansionTab[c.green] * a2f + a12m) div a12]) shl TBGRAPixel_GreenShift) or
    788                    ((GammaCompressionTab[(GammaExpansionTab[dest^.blue] * a1f +
    789                      GammaExpansionTab[c.blue] * a2f + a12m) div a12]) shl TBGRAPixel_BlueShift) or
    790                    (((a12 + a12 shr 7) shr 8) shl TBGRAPixel_AlphaShift);
     761  a1f, a2f, a12, a12m, alphaCorr: NativeUInt;
     762begin
     763  case dest^.alpha of
     764    0: dest^ := c;
     765    255:
     766      begin
     767        alphaCorr := c.alpha;
     768        if alphaCorr >= 128 then alphaCorr += 1;
     769        dest^.red := GammaCompressionTab[(GammaExpansionTab[dest^.red] * NativeUInt(256-alphaCorr) + GammaExpansionTab[c.red]*alphaCorr) shr 8];
     770        dest^.green := GammaCompressionTab[(GammaExpansionTab[dest^.green] * NativeUInt(256-alphaCorr) + GammaExpansionTab[c.green]*alphaCorr) shr 8];
     771        dest^.blue := GammaCompressionTab[(GammaExpansionTab[dest^.blue] * NativeUInt(256-alphaCorr) + GammaExpansionTab[c.blue]*alphaCorr) shr 8];
     772      end;
     773    else
     774    begin
     775      {$HINTS OFF}
     776      a12  := 65025 - (not dest^.alpha) * (not c.alpha);
     777      {$HINTS ON}
     778      a12m := a12 shr 1;
     779
     780      a1f := dest^.alpha * (not c.alpha);
     781      a2f := (c.alpha shl 8) - c.alpha;
     782
     783      PDWord(dest)^ := ((GammaCompressionTab[(GammaExpansionTab[dest^.red] * a1f +
     784                         GammaExpansionTab[c.red] * a2f + a12m) div a12]) shl TBGRAPixel_RedShift) or
     785                       ((GammaCompressionTab[(GammaExpansionTab[dest^.green] * a1f +
     786                         GammaExpansionTab[c.green] * a2f + a12m) div a12]) shl TBGRAPixel_GreenShift) or
     787                       ((GammaCompressionTab[(GammaExpansionTab[dest^.blue] * a1f +
     788                         GammaExpansionTab[c.blue] * a2f + a12m) div a12]) shl TBGRAPixel_BlueShift) or
     789                       (((a12 + a12 shr 7) shr 8) shl TBGRAPixel_AlphaShift);
     790    end;
     791  end;
    791792end;
    792793
     
    794795  const ec: TExpandedPixel; calpha: byte);
    795796var
    796   a1f, a2f, a12, a12m: cardinal;
    797 begin
    798   {$HINTS OFF}
    799   a12  := 65025 - (not dest^.alpha) * (not calpha);
    800   {$HINTS ON}
    801   a12m := a12 shr 1;
    802 
    803   a1f := dest^.alpha * (not calpha);
    804   a2f := (calpha shl 8) - calpha;
    805 
    806   PDWord(dest)^ := ((GammaCompressionTab[(GammaExpansionTab[dest^.red] * a1f +
    807                      ec.red * a2f + a12m) div a12]) shl TBGRAPixel_RedShift) or
    808                    ((GammaCompressionTab[(GammaExpansionTab[dest^.green] * a1f +
    809                      ec.green * a2f + a12m) div a12]) shl TBGRAPixel_GreenShift) or
    810                    ((GammaCompressionTab[(GammaExpansionTab[dest^.blue] * a1f +
    811                      ec.blue * a2f + a12m) div a12]) shl TBGRAPixel_BlueShift) or
    812                    (((a12 + a12 shr 7) shr 8) shl TBGRAPixel_AlphaShift);
     797  a1f, a2f, a12, a12m, alphaCorr: NativeUInt;
     798begin
     799  case dest^.alpha of
     800    0: begin
     801         dest^.red := GammaCompressionTab[ec.red];
     802         dest^.green := GammaCompressionTab[ec.green];
     803         dest^.blue := GammaCompressionTab[ec.blue];
     804         dest^.alpha := calpha;
     805      end;
     806    255:
     807      begin
     808        alphaCorr := calpha;
     809        if alphaCorr >= 128 then alphaCorr += 1;
     810        dest^.red := GammaCompressionTab[(GammaExpansionTab[dest^.red] * NativeUInt(256-alphaCorr) + ec.red*alphaCorr) shr 8];
     811        dest^.green := GammaCompressionTab[(GammaExpansionTab[dest^.green] * NativeUInt(256-alphaCorr) + ec.green*alphaCorr) shr 8];
     812        dest^.blue := GammaCompressionTab[(GammaExpansionTab[dest^.blue] * NativeUInt(256-alphaCorr) + ec.blue*alphaCorr) shr 8];
     813      end;
     814    else
     815    begin
     816      {$HINTS OFF}
     817      a12  := 65025 - (not dest^.alpha) * (not calpha);
     818      {$HINTS ON}
     819      a12m := a12 shr 1;
     820
     821      a1f := dest^.alpha * (not calpha);
     822      a2f := (calpha shl 8) - calpha;
     823
     824      PDWord(dest)^ := ((GammaCompressionTab[(GammaExpansionTab[dest^.red] * a1f +
     825                         ec.red * a2f + a12m) div a12]) shl TBGRAPixel_RedShift) or
     826                       ((GammaCompressionTab[(GammaExpansionTab[dest^.green] * a1f +
     827                         ec.green * a2f + a12m) div a12]) shl TBGRAPixel_GreenShift) or
     828                       ((GammaCompressionTab[(GammaExpansionTab[dest^.blue] * a1f +
     829                         ec.blue * a2f + a12m) div a12]) shl TBGRAPixel_BlueShift) or
     830                       (((a12 + a12 shr 7) shr 8) shl TBGRAPixel_AlphaShift);
     831    end;
     832  end;
    813833end;
    814834
    815835procedure FastBlendPixelInline(dest: PBGRAPixel; const c: TBGRAPixel);
    816836var
    817   a1f, a2f, a12, a12m: cardinal;
    818 begin
    819   if c.alpha = 0 then
    820     exit;
    821   if c.alpha = 255 then
    822   begin
    823     dest^ := c;
    824     exit;
    825   end;
    826 
    827   {$HINTS OFF}
    828   a12  := 65025 - (not dest^.alpha) * (not c.alpha);
    829   {$HINTS ON}
    830   a12m := a12 shr 1;
    831 
    832   a1f := dest^.alpha * (not c.alpha);
    833   a2f := (c.alpha shl 8) - c.alpha;
    834 
    835   PDWord(dest)^ := (((dest^.red * a1f + c.red * a2f + a12m) div a12) shl TBGRAPixel_RedShift) or
    836                    (((dest^.green * a1f + c.green * a2f + a12m) div a12) shl TBGRAPixel_GreenShift) or
    837                    (((dest^.blue * a1f + c.blue * a2f + a12m) div a12) shl TBGRAPixel_BlueShift) or
    838                    (((a12 + a12 shr 7) shr 8) shl TBGRAPixel_AlphaShift);
     837  a1f, a2f, a12, a12m, alphaCorr: NativeUInt;
     838begin
     839  case c.alpha of
     840    0: ;
     841    255: dest^ := c;
     842    else
     843    begin
     844      case dest^.alpha of
     845        0: dest^ := c;
     846        255:
     847        begin
     848          alphaCorr := c.alpha;
     849          if alphaCorr >= 128 then alphaCorr += 1;
     850          dest^.red := (dest^.red * NativeUInt(256-alphaCorr) + c.red*(alphaCorr+1)) shr 8;
     851          dest^.green := (dest^.green * NativeUInt(256-alphaCorr) + c.green*(alphaCorr+1)) shr 8;
     852          dest^.blue := (dest^.blue * NativeUInt(256-alphaCorr) + c.blue*(alphaCorr+1)) shr 8;
     853        end;
     854        else
     855        begin
     856          {$HINTS OFF}
     857          a12  := 65025 - (not dest^.alpha) * (not c.alpha);
     858          {$HINTS ON}
     859          a12m := a12 shr 1;
     860
     861          a1f := dest^.alpha * (not c.alpha);
     862          a2f := (c.alpha shl 8) - c.alpha;
     863
     864          PDWord(dest)^ := (((dest^.red * a1f + c.red * a2f + a12m) div a12) shl TBGRAPixel_RedShift) or
     865                           (((dest^.green * a1f + c.green * a2f + a12m) div a12) shl TBGRAPixel_GreenShift) or
     866                           (((dest^.blue * a1f + c.blue * a2f + a12m) div a12) shl TBGRAPixel_BlueShift) or
     867                           (((a12 + a12 shr 7) shr 8) shl TBGRAPixel_AlphaShift);
     868        end;
     869      end;
     870    end;
     871  end;
    839872end;
    840873
  • GraphicTest/Packages/bgrabitmap/bgracanvas.pas

    r494 r521  
    188188                         Filled: boolean = False;
    189189                         Continuous: boolean = False);
    190     procedure Draw(X,Y: Integer; SrcBitmap: TBGRACustomBitmap);
     190    procedure Draw(X,Y: Integer; SrcBitmap: TBGRACustomBitmap); overload;
     191    procedure Draw(X,Y: Integer; SrcBitmap: TBitmap); overload;
    191192    procedure CopyRect(X,Y: Integer; SrcBitmap: TBGRACustomBitmap; SrcRect: TRect);
    192193    procedure StretchDraw(DestRect: TRect; SrcBitmap: TBGRACustomBitmap; HorizFlip: Boolean = false; VertFlip: Boolean = false);
     
    420421begin
    421422  FCustomPenStyle := DuplicatePenStyle(AValue);
    422 
    423   if IsSolidPenStyle(AValue) then FPenStyle := psSolid else
    424   if IsClearPenStyle(AValue) then FPenStyle := psClear else
    425     FPenStyle := psPattern;
     423  FPenStyle:= BGRAToPenStyle(AValue);
    426424end;
    427425
    428426procedure TBGRAPen.SetPenStyle(const AValue: TPenStyle);
    429427begin
     428  if AValue = psPattern then exit;
    430429  Case AValue of
    431430  psSolid: FCustomPenStyle := SolidPenStyle;
     
    811810begin
    812811  if not ComputeEllipseC(x1,y1,x2,y2,cx,cy,rx,ry) then exit;
    813   angle1 := round(arctan2(-(sy-cy)/ry,(sx-cx)/rx)*65536/(2*Pi));
    814   angle2 := round(arctan2(-(ey-cy)/ry,(ex-cx)/rx)*65536/(2*Pi));
     812  angle1 := round(arctan2(-(sy-cy)/ry,(sx-cx)/rx)*65536/(2*Pi)) and 65535;
     813  angle2 := round(arctan2(-(ey-cy)/ry,(ex-cx)/rx)*65536/(2*Pi)) and 65535;
    815814  Arc65536(x1,y1,x2,y2,angle1, angle2, [aoClosePath,aoFillPath]);
    816815end;
     
    828827begin
    829828  if not ComputeEllipseC(x1,y1,x2,y2,cx,cy,rx,ry) then exit;
    830   angle1 := round(arctan2(-(sy-cy)/ry,(sx-cx)/rx)*65536/(2*Pi));
    831   angle2 := round(arctan2(-(ey-cy)/ry,(ex-cx)/rx)*65536/(2*Pi));
     829  angle1 := round(arctan2(-(sy-cy)/ry,(sx-cx)/rx)*65536/(2*Pi)) and 65535;
     830  angle2 := round(arctan2(-(ey-cy)/ry,(ex-cx)/rx)*65536/(2*Pi)) and 65535;
    832831  Arc65536(x1,y1,x2,y2,angle1, angle2, [aoPie,aoFillPath]);
    833832end;
     
    11211120    multi := TBGRAMultishapeFiller.Create;
    11221121    multi.Antialiasing := AntialiasingMode <> amOff;
    1123     with bounds do
    1124     begin
    1125       multi.AddPolygon([PointF(Left-0.5,Top-0.5),PointF(Right-0.5,Top-0.5),
    1126                         PointF(Right-0.5-width,Top-0.5+width),PointF(Left-0.5+width,Top-0.5+width),
    1127                         PointF(Left-0.5+width,Bottom-0.5-width),PointF(Left-0.5,Bottom-0.5)],color1);
    1128       multi.AddPolygon([PointF(Right-0.5,Bottom-0.5),PointF(Left-0.5,Bottom-0.5),
    1129                         PointF(Left-0.5+width,Bottom-0.5-width),PointF(Right-0.5-width,Bottom-0.5-width),
    1130                         PointF(Right-0.5-width,Top-0.5+width),PointF(Right-0.5,Top-0.5)],color2);
    1131     end;
     1122    multi.AddPolygon([PointF(bounds.Left-0.5,bounds.Top-0.5),PointF(bounds.Right-0.5,bounds.Top-0.5),
     1123                      PointF(bounds.Right-0.5-width,bounds.Top-0.5+width),PointF(bounds.Left-0.5+width,bounds.Top-0.5+width),
     1124                      PointF(bounds.Left-0.5+width,bounds.Bottom-0.5-width),PointF(bounds.Left-0.5,bounds.Bottom-0.5)],color1);
     1125    multi.AddPolygon([PointF(bounds.Right-0.5,bounds.Bottom-0.5),PointF(bounds.Left-0.5,bounds.Bottom-0.5),
     1126                      PointF(bounds.Left-0.5+width,bounds.Bottom-0.5-width),PointF(bounds.Right-0.5-width,bounds.Bottom-0.5-width),
     1127                      PointF(bounds.Right-0.5-width,bounds.Top-0.5+width),PointF(bounds.Right-0.5,bounds.Top-0.5)],color2);
    11321128    multi.Draw(FBitmap);
    11331129    multi.Free;
     
    14341430end;
    14351431
     1432procedure TBGRACanvas.Draw(X, Y: Integer; SrcBitmap: TBitmap);
     1433begin
     1434  FBitmap.PutImage(X,Y,SrcBitmap,dmDrawWithTransparency);
     1435end;
     1436
    14361437procedure TBGRACanvas.CopyRect(X, Y: Integer; SrcBitmap: TBGRACustomBitmap;
    14371438  SrcRect: TRect);
  • GraphicTest/Packages/bgrabitmap/bgracanvas2d.pas

    r494 r521  
    3232    procedure addColorStop(APosition: single; AColor: string);
    3333    procedure setColors(ACustomGradient: TBGRACustomGradient);
     34    function GetGammaCorrection: boolean;
     35    procedure SetGammaCorrection(AValue: boolean);
     36    property gammaCorrection: boolean read GetGammaCorrection write SetGammaCorrection;
    3437  end;
    3538
     
    5154    strokeTextureProvider: IBGRACanvasTextureProvider2D;
    5255    fillColor: TBGRAPixel;
     56    fillMode: TFillMode;
    5357    fillTextureProvider: IBGRACanvasTextureProvider2D;
    5458    globalAlpha: byte;
     
    9195    FPathPoints: array of TPointF;
    9296    FPathPointCount: integer;
     97    FTextPaths: array of record
     98        Text: string;
     99        FontName: string;
     100        FontMatrix: TAffineMatrix;
     101        FontAlign: TAlignment;
     102        FontAnchor: TFontVerticalAnchor;
     103        FontStyle: TFontStyles;
     104      end;
    93105    FFontRenderer: TBGRACustomFontRenderer;
    94106    FLastCoord, FStartCoord: TPointF;
     
    119131    function GetTextAlignLCL: TAlignment;
    120132    function GetTextBaseline: string;
     133    function GetFillMode: TFillMode;
    121134    function GetWidth: Integer;
    122135    procedure SetFontName(AValue: string);
     
    131144    procedure FillPoly(const points: array of TPointF);
    132145    procedure FillStrokePoly(const points: array of TPointF; fillOver: boolean);
     146    procedure FillTexts(AErase: boolean);
    133147    procedure SetLineJoinLCL(AValue: TPenJoinStyle);
    134148    procedure SetLineWidth(const AValue: single);
     
    145159    procedure SetTextAlignLCL(AValue: TAlignment);
    146160    procedure SetTextBaseine(AValue: string);
     161    procedure SetFillMode(mode: TFillMode);
    147162    procedure StrokePoly(const points: array of TPointF);
    148     procedure DrawShadow(const points, points2: array of TPointF);
     163    procedure DrawShadow(const points, points2: array of TPointF; AFillMode: TFillMode = fmWinding);
     164    procedure DrawShadowMask(X,Y: integer; AMask: TBGRACustomBitmap; AMaskOwned: boolean);
    149165    procedure ClearPoly(const points: array of TPointF);
    150166    function ApplyTransform(const points: array of TPointF; matrix: TAffineMatrix): ArrayOfTPointF; overload;
     
    163179    function getCursor: TBGRACustomPathCursor; //IBGRAPath
    164180  public
    165     antialiasing, linearBlend: boolean;
     181    antialiasing, linearBlend, gradientGammaCorrection: boolean;
    166182    constructor Create(ASurface: TBGRACustomBitmap);
    167183    destructor Destroy; override;
     
    202218    procedure shadowNone;
    203219    function getShadowColor: TBGRAPixel;
     220
    204221    function createLinearGradient(x0,y0,x1,y1: single): IBGRACanvasGradient2D; overload;
    205222    function createLinearGradient(p0,p1: TPointF): IBGRACanvasGradient2D; overload;
    206223    function createLinearGradient(x0,y0,x1,y1: single; Colors: TBGRACustomGradient): IBGRACanvasGradient2D; overload;
    207224    function createLinearGradient(p0,p1: TPointF; Colors: TBGRACustomGradient): IBGRACanvasGradient2D; overload;
     225
     226    function createRadialGradient(x0,y0,r0,x1,y1,r1: single; flipGradient: boolean=false): IBGRACanvasGradient2D; overload;
     227    function createRadialGradient(p0: TPointF; r0: single; p1: TPointF; r1: single; flipGradient: boolean=false): IBGRACanvasGradient2D; overload;
     228    function createRadialGradient(x0,y0,r0,x1,y1,r1: single; Colors: TBGRACustomGradient; flipGradient: boolean=false): IBGRACanvasGradient2D; overload;
     229    function createRadialGradient(p0: TPointF; r0: single; p1: TPointF; r1: single; Colors: TBGRACustomGradient; flipGradient: boolean=false): IBGRACanvasGradient2D; overload;
     230
    208231    function createPattern(image: TBGRACustomBitmap; repetition: string): IBGRACanvasTextureProvider2D; overload;
    209232    function createPattern(texture: IBGRAScanner): IBGRACanvasTextureProvider2D; overload;
     
    222245    procedure moveTo(x,y: single); overload;
    223246    procedure lineTo(x,y: single); overload;
    224     procedure moveTo(const pt: TPointF); overload;
    225     procedure lineTo(const pt: TPointF); overload;
     247    procedure moveTo(constref pt: TPointF); overload;
     248    procedure lineTo(constref pt: TPointF); overload;
    226249    procedure polylineTo(const pts: array of TPointF);
    227250    procedure quadraticCurveTo(cpx,cpy,x,y: single); overload;
    228     procedure quadraticCurveTo(const cp,pt: TPointF); overload;
     251    procedure quadraticCurveTo(constref cp,pt: TPointF); overload;
    229252    procedure bezierCurveTo(cp1x,cp1y,cp2x,cp2y,x,y: single); overload;
    230     procedure bezierCurveTo(const cp1,cp2,pt: TPointF); overload;
     253    procedure bezierCurveTo(constref cp1,cp2,pt: TPointF); overload;
    231254    procedure rect(x,y,w,h: single);
    232255    procedure roundRect(x,y,w,h,radius: single); overload;
     
    240263    procedure arc(cx, cy, rx,ry, xAngleRadCW, startAngleRadCW, endAngleRadCW: single; anticlockwise: boolean); overload;
    241264    procedure arc(cx, cy, rx,ry, xAngleRadCW, startAngleRadCW, endAngleRadCW: single); overload;
    242     procedure arc(const arcDef: TArcDef); overload;
     265    procedure arc(constref arcDef: TArcDef); overload;
    243266    procedure arcTo(x1, y1, x2, y2, radius: single); overload;
    244267    procedure arcTo(p1,p2: TPointF; radius: single); overload;
     
    297320    property textAlign: string read GetTextAlign write SetTextAlign;
    298321    property textBaseline: string read GetTextBaseline write SetTextBaseine;
     322   
     323    property fillMode: TFillMode read GetFillMode write SetFillMode;
    299324
    300325    property currentPath: ArrayOfTPointF read GetCurrentPathAsPoints;
     
    327352    nbColorStops: integer;
    328353    FCustomGradient: TBGRACustomGradient;
     354    FGammaCorrection: boolean;
    329355  protected
    330356    scanner: TBGRAGradientScanner;
     
    332358    function getColorArray: TGradientArrayOfColors;
    333359    function getPositionArray: TGradientArrayOfPositions;
     360    procedure GetBGRAGradient(out ABGRAGradient: TBGRACustomGradient; out AOwned: boolean);
     361    function GetGammaCorrection: boolean;
     362    procedure SetGammaCorrection(AValue: boolean);
    334363  public
     364    constructor Create;
    335365    function getTexture: IBGRAScanner; override;
    336366    destructor Destroy; override;
     
    341371    property texture: IBGRAScanner read GetTexture;
    342372    property colorStopCount: integer read nbColorStops;
     373    property gammaCorrection: boolean read GetGammaCorrection write SetGammaCorrection;
    343374  end;
    344375
     
    348379  protected
    349380    o1,o2: TPointF;
     381    FTransform: TAffineMatrix;
    350382    procedure CreateScanner; override;
    351383  public
    352     constructor Create(x0,y0,x1,y1: single);
    353     constructor Create(p0,p1: TPointF);
     384    constructor Create(x0,y0,x1,y1: single; transform: TAffineMatrix);
     385    constructor Create(p0,p1: TPointF; transform: TAffineMatrix);
     386  end;
     387
     388  { TBGRACanvasRadialGradient2D }
     389
     390  TBGRACanvasRadialGradient2D = class(TBGRACanvasGradient2D)
     391  protected
     392    c0,c1: TPointF;
     393    cr0,cr1: single;
     394    FFlipGradient: boolean;
     395    FTransform: TAffineMatrix;
     396    procedure CreateScanner; override;
     397  public
     398    constructor Create(x0,y0,r0,x1,y1,r1: single; transform: TAffineMatrix; flipGradient: boolean=false);
     399    constructor Create(p0: TPointF; r0: single; p1: TPointF; r1: single; transform: TAffineMatrix; flipGradient: boolean=false);
    354400  end;
    355401
     
    452498    GradientColors: TBGRACustomGradient;
    453499begin
    454   if FCustomGradient = nil then
    455   begin
    456     GradientColors := TBGRAMultiGradient.Create(getColorArray,getPositionArray,False,False);
    457     GradientOwner := true;
    458   end else
    459   begin
    460     GradientColors := FCustomGradient;
    461     GradientOwner := false;
    462   end;
     500  GetBGRAGradient(GradientColors,GradientOwner);
    463501  scanner := TBGRAGradientScanner.Create(GradientColors,gtLinear,o1,o2,False,GradientOwner);
    464 end;
    465 
    466 constructor TBGRACanvasLinearGradient2D.Create(x0, y0, x1, y1: single);
     502  scanner.Transform := FTransform;
     503end;
     504
     505constructor TBGRACanvasLinearGradient2D.Create(x0, y0, x1, y1: single; transform: TAffineMatrix);
    467506begin
    468507  o1 := PointF(x0,y0);
    469508  o2 := PointF(x1,y1);
    470 end;
    471 
    472 constructor TBGRACanvasLinearGradient2D.Create(p0, p1: TPointF);
     509  FTransform := transform;
     510end;
     511
     512constructor TBGRACanvasLinearGradient2D.Create(p0, p1: TPointF; transform: TAffineMatrix);
    473513begin
    474514  o1 := p0;
    475515  o2 := p1;
     516  FTransform := transform;
     517end;
     518
     519{ TBGRACanvasRadialGradient2D }
     520
     521procedure TBGRACanvasRadialGradient2D.CreateScanner;
     522var GradientOwner: boolean;
     523    GradientColors: TBGRACustomGradient;
     524begin
     525  GetBGRAGradient(GradientColors,GradientOwner);
     526  scanner := TBGRAGradientScanner.Create(GradientColors,c0,cr0,c1,cr1,GradientOwner);
     527  scanner.FlipGradient := not FFlipGradient;
     528  scanner.Transform := FTransform;
     529end;
     530
     531constructor TBGRACanvasRadialGradient2D.Create(x0, y0, r0, x1, y1, r1: single;
     532  transform: TAffineMatrix; flipGradient: boolean);
     533begin
     534  self.c0 := PointF(x0,y0);
     535  self.cr0 := r0;
     536  self.c1 := PointF(x1,y1);
     537  self.cr1 := r1;
     538  FTransform := transform;
     539  FFlipGradient := flipGradient;
     540end;
     541
     542constructor TBGRACanvasRadialGradient2D.Create(p0: TPointF; r0: single;
     543  p1: TPointF; r1: single; transform: TAffineMatrix; flipGradient: boolean);
     544begin
     545  self.c0 := p0;
     546  self.cr0 := r0;
     547  self.c1 := p1;
     548  self.cr1 := r1;
     549  FTransform := transform;
     550  FFlipGradient := flipGradient;
    476551end;
    477552
    478553{ TBGRACanvasGradient2D }
    479554
    480 function TBGRACanvasGradient2D.GetTexture: IBGRAScanner;
     555function TBGRACanvasGradient2D.getTexture: IBGRAScanner;
    481556begin
    482557  if scanner = nil then CreateScanner;
    483558  result := scanner;
     559end;
     560
     561function TBGRACanvasGradient2D.GetGammaCorrection: boolean;
     562begin
     563  result := FGammaCorrection;
     564end;
     565
     566procedure TBGRACanvasGradient2D.SetGammaCorrection(AValue: boolean);
     567begin
     568  FGammaCorrection:= AValue;
     569  FreeAndNil(scanner);
     570end;
     571
     572constructor TBGRACanvasGradient2D.Create;
     573begin
     574  inherited Create;
     575  scanner := nil;
     576  FGammaCorrection:= false;
    484577end;
    485578
     
    500593  for i := 0 to nbColorStops-1 do
    501594    result[i] := colorStops[i].position;
     595end;
     596
     597procedure TBGRACanvasGradient2D.GetBGRAGradient(out
     598  ABGRAGradient: TBGRACustomGradient; out AOwned: boolean);
     599begin
     600  if FCustomGradient = nil then
     601  begin
     602    if (colorStopCount = 2) and (colorStops[0].position = 0) and (colorStops[1].position = 1) then
     603    begin
     604      if FGammaCorrection then
     605        ABGRAGradient := TBGRASimpleGradientWithGammaCorrection.Create(colorStops[0].color, colorStops[1].color)
     606      else
     607        ABGRAGradient := TBGRASimpleGradientWithoutGammaCorrection.Create(colorStops[0].color, colorStops[1].color);
     608    end
     609    else
     610      ABGRAGradient := TBGRAMultiGradient.Create(getColorArray,getPositionArray,FGammaCorrection,False);
     611    AOwned := true;
     612  end else
     613  begin
     614    ABGRAGradient := FCustomGradient;
     615    AOwned := false;
     616  end;
    502617end;
    503618
     
    593708  result.strokeTextureProvider := strokeTextureProvider;
    594709  result.fillColor := fillColor;
     710  result.fillMode := fillMode;
    595711  result.fillTextureProvider := fillTextureProvider;
    596712  result.globalAlpha := globalAlpha;
     
    9451061procedure TBGRACanvas2D.FillPoly(const points: array of TPointF);
    9461062var
     1063  bfill: boolean;
    9471064  tempScan: TBGRACustomScanner;
    9481065begin
    9491066  if (length(points) = 0) or (surface = nil) then exit;
    950   If hasShadow then DrawShadow(points,[]);
     1067  If hasShadow then DrawShadow(points,[],fillMode);
     1068  bfill:= currentState.fillMode = fmWinding;
    9511069  if currentState.clipMaskReadOnly <> nil then
    9521070  begin
     
    9561074      tempScan := TBGRASolidColorMaskScanner.Create(currentState.clipMaskReadOnly,Point(0,0),ApplyGlobalAlpha(currentState.fillColor));
    9571075    if self.antialiasing then
    958       BGRAPolygon.FillPolyAntialiasWithTexture(surface, points, tempScan, true, linearBlend)
     1076      BGRAPolygon.FillPolyAntialiasWithTexture(surface, points, tempScan, bfill, linearBlend)
    9591077    else
    960       BGRAPolygon.FillPolyAliasedWithTexture(surface, points, tempScan, true, GetDrawMode);
     1078      BGRAPolygon.FillPolyAliasedWithTexture(surface, points, tempScan, bfill, GetDrawMode);
    9611079    tempScan.free;
    9621080  end else
     
    9681086        tempScan := TBGRAOpacityScanner.Create(currentState.fillTextureProvider.texture, currentState.globalAlpha);
    9691087        if self.antialiasing then
    970           BGRAPolygon.FillPolyAntialiasWithTexture(surface, points, tempScan, true, linearBlend)
     1088          BGRAPolygon.FillPolyAntialiasWithTexture(surface, points, tempScan, bfill, linearBlend)
    9711089        else
    972           BGRAPolygon.FillPolyAliasedWithTexture(surface, points, tempScan, true, GetDrawMode);
     1090          BGRAPolygon.FillPolyAliasedWithTexture(surface, points, tempScan, bfill, GetDrawMode);
    9731091        tempScan.Free;
    9741092      end else
    9751093      begin
    9761094        if self.antialiasing then
    977           BGRAPolygon.FillPolyAntialiasWithTexture(surface, points, currentState.fillTextureProvider.texture, true, linearBlend)
     1095          BGRAPolygon.FillPolyAntialiasWithTexture(surface, points, currentState.fillTextureProvider.texture, bfill, linearBlend)
    9781096        else
    979           BGRAPolygon.FillPolyAliasedWithTexture(surface, points, currentState.fillTextureProvider.texture, true, GetDrawMode);
     1097          BGRAPolygon.FillPolyAliasedWithTexture(surface, points, currentState.fillTextureProvider.texture, bfill, GetDrawMode);
    9801098      end
    9811099    end
     
    9831101    begin
    9841102      if self.antialiasing then
    985         BGRAPolygon.FillPolyAntialias(surface, points, ApplyGlobalAlpha(currentState.fillColor), false, true, linearBlend)
     1103        BGRAPolygon.FillPolyAntialias(surface, points, ApplyGlobalAlpha(currentState.fillColor), false, bfill, linearBlend)
    9861104      else
    987         BGRAPolygon.FillPolyAliased(surface, points, ApplyGlobalAlpha(currentState.fillColor), false, true, GetDrawMode)
     1105        BGRAPolygon.FillPolyAliased(surface, points, ApplyGlobalAlpha(currentState.fillColor), false, bfill, GetDrawMode)
    9881106    end
    9891107  end;
     
    9971115  contour : array of TPointF;
    9981116  texture: IBGRAScanner;
     1117  idxContour: Integer;
    9991118begin
    10001119  if (length(points) = 0) or (surface = nil) then exit;
     
    10021121  tempScan2 := nil;
    10031122  multi := TBGRAMultishapeFiller.Create;
    1004   multi.FillMode := fmWinding;
     1123  multi.FillMode := self.fillMode;
    10051124  if currentState.clipMaskReadOnly <> nil then
    10061125  begin
     
    10351154      else
    10361155        tempScan2 := TBGRASolidColorMaskScanner.Create(currentState.clipMaskReadOnly,Point(0,0),ApplyGlobalAlpha(currentState.strokeColor));
    1037       multi.AddPolygon(contour,tempScan);
     1156      idxContour := multi.AddPolygon(contour,tempScan);
    10381157    end else
    10391158    begin
     
    10421161        texture := nil;
    10431162      if texture = nil then
    1044         multi.AddPolygon(contour,ApplyGlobalAlpha(currentState.strokeColor))
     1163        idxContour := multi.AddPolygon(contour,ApplyGlobalAlpha(currentState.strokeColor))
    10451164      else
    1046         multi.AddPolygon(contour,texture);
     1165        idxContour := multi.AddPolygon(contour,texture);
    10471166    end;
     1167    multi.OverrideFillMode(idxContour, fmWinding);
    10481168    If hasShadow then DrawShadow(points,contour);
    10491169  end else
     
    10561176  tempScan2.free;
    10571177  multi.Free;
     1178end;
     1179
     1180procedure TBGRACanvas2D.FillTexts(AErase: boolean);
     1181var
     1182  i,j: Integer;
     1183  hy,hx,h: single;
     1184  bmp,bmpTransf,shadowBmp: TBGRACustomBitmap;
     1185  tempScan: TBGRACustomScanner;
     1186  m: TAffineMatrix;
     1187  s: TSize;
     1188  surfaceBounds, shadowBounds: TRect;
     1189  rf: TResampleFilter;
     1190  pad: TSize;
     1191  p: PBGRAPixel;
     1192begin
     1193  for i := 0 to High(FTextPaths) do
     1194  with FTextPaths[i] do
     1195  begin
     1196    hx := VectLen(FontMatrix[1,1],FontMatrix[2,1]);
     1197    hy := VectLen(FontMatrix[1,2],FontMatrix[2,2]);
     1198    h := max(hx,hy);
     1199    if self.antialiasing then h := round(h);
     1200    if h<=0 then continue;
     1201    m := FontMatrix*AffineMatrixScale(hx/sqr(h),hy/sqr(h));
     1202    if pixelCenteredCoordinates then m := AffineMatrixTranslation(0.5,0.5)*m;
     1203    bmp := BGRABitmapFactory.Create;
     1204    try
     1205      bmp.FontName := FontName;
     1206      bmp.FontStyle:= FontStyle;
     1207      bmp.FontHeight:= round(h);
     1208      if self.antialiasing then
     1209        bmp.FontQuality := fqFineAntialiasing
     1210      else
     1211        bmp.FontQuality:= fqSystem;
     1212
     1213      bmp.FontVerticalAnchor:= FontAnchor;
     1214      m := m*AffineMatrixTranslation(0,-bmp.FontVerticalAnchorOffset);
     1215      bmp.FontVerticalAnchor:= fvaTop;
     1216
     1217      s := bmp.TextSize(Text);
     1218      case FontAlign of
     1219        taCenter: m := m*AffineMatrixTranslation(-s.cx/2,0);
     1220        taRightJustify: m := m*AffineMatrixTranslation(-s.cx,0);
     1221      end;
     1222
     1223      pad := Size(round(h/3), round(h/3));
     1224      m := m*AffineMatrixTranslation(-pad.cx,-pad.cy);
     1225      surfaceBounds := surface.GetImageAffineBounds(m, Types.Rect(0,0,s.cx+pad.cx*2,s.cy+pad.cy*2));
     1226      if hasShadow then
     1227      begin
     1228        shadowBounds := surfaceBounds;
     1229        shadowBounds.Inflate(ceil(shadowBlur),ceil(shadowBlur));
     1230        shadowBounds.Offset(round(shadowOffsetX),round(shadowOffsetY));
     1231        shadowBounds.Intersect(surface.ClipRect);
     1232        if not IsRectEmpty(shadowBounds) then
     1233        begin
     1234          shadowBounds.Offset(-round(shadowOffsetX),-round(shadowOffsetY));
     1235          UnionRect(surfaceBounds, surfaceBounds, shadowBounds);
     1236        end;
     1237      end;
     1238      if not IsRectEmpty(surfaceBounds) then
     1239      begin
     1240        bmp.SetSize(s.cx+pad.cx*2,s.cy+pad.cy*2);
     1241        bmp.Fill(BGRABlack);
     1242        bmp.TextOut(pad.cx,pad.cy,Text,BGRAWhite);
     1243        if self.antialiasing then bmp.ConvertToLinearRGB else
     1244        begin
     1245          p := bmp.Data;
     1246          for j := bmp.NbPixels-1 downto 0 do
     1247          begin
     1248            if p^.green<128 then p^ := BGRABlack else p^ := BGRAWhite;
     1249            inc(p);
     1250          end;
     1251        end;
     1252
     1253        bmpTransf := BGRABitmapFactory.Create(surfaceBounds.Width,surfaceBounds.Height,BGRABlack);
     1254        try
     1255          m := AffineMatrixTranslation(-surfaceBounds.Left,-surfaceBounds.Top)*m;
     1256          if self.antialiasing then rf:= rfCosine else rf := rfBox;
     1257          bmpTransf.PutImageAffine(m, bmp, rf, GetDrawMode);
     1258          FreeAndNil(bmp);
     1259
     1260          if AErase then
     1261            surface.EraseMask(surfaceBounds.Left,surfaceBounds.Top, bmpTransf) else
     1262          begin
     1263            if hasShadow then
     1264            begin
     1265              shadowBmp := BGRABitmapFactory.Create(bmpTransf.Width,bmpTransf.Height);
     1266              shadowBmp.FillMask(0,0, bmpTransf, getShadowColor, GetDrawMode);
     1267              DrawShadowMask(surfaceBounds.Left+round(shadowOffsetX),surfaceBounds.Top+round(shadowOffsetY), shadowBmp, true);
     1268            end;
     1269
     1270            if currentState.clipMaskReadOnly <> nil then
     1271            begin
     1272              if currentState.fillTextureProvider <> nil then
     1273                tempScan := TBGRATextureMaskScanner.Create(currentState.clipMaskReadOnly,Point(0,0),currentState.fillTextureProvider.texture,currentState.globalAlpha)
     1274              else
     1275                tempScan := TBGRASolidColorMaskScanner.Create(currentState.clipMaskReadOnly,Point(0,0),ApplyGlobalAlpha(currentState.fillColor));
     1276              surface.FillMask(surfaceBounds.Left,surfaceBounds.Top, bmpTransf, tempScan, GetDrawMode);
     1277              tempScan.free;
     1278            end else
     1279            begin
     1280              if currentState.fillTextureProvider <> nil then
     1281              begin
     1282                if currentState.globalAlpha <> 255 then
     1283                begin
     1284                  tempScan := TBGRAOpacityScanner.Create(currentState.fillTextureProvider.texture, currentState.globalAlpha);
     1285                  surface.FillMask(surfaceBounds.Left,surfaceBounds.Top, bmpTransf, tempScan, GetDrawMode);
     1286                  tempScan.Free;
     1287                end else
     1288                  surface.FillMask(surfaceBounds.Left,surfaceBounds.Top, bmpTransf, currentState.fillTextureProvider.texture, GetDrawMode);
     1289              end
     1290              else
     1291                surface.FillMask(surfaceBounds.Left,surfaceBounds.Top, bmpTransf, ApplyGlobalAlpha(currentState.fillColor), GetDrawMode);
     1292            end;
     1293          end;
     1294        finally
     1295          bmpTransf.Free;
     1296        end;
     1297      end;
     1298    finally
     1299      bmp.Free;
     1300    end;
     1301  end;
    10581302end;
    10591303
     
    12181462end;
    12191463
    1220 procedure TBGRACanvas2D.DrawShadow(const points, points2: array of TPointF);
    1221 const invSqrt2 = 1/sqrt(2);
     1464procedure TBGRACanvas2D.DrawShadow(const points, points2: array of TPointF;
     1465  AFillMode: TFillMode = fmWinding);
    12221466var ofsPts,ofsPts2: array of TPointF;
    12231467    offset: TPointF;
    12241468    i: Integer;
    1225     tempBmp,blurred: TBGRACustomBitmap;
     1469    tempBmp: TBGRACustomBitmap;
    12261470    maxRect: TRect;
    12271471    foundRect: TRect;
     
    12791523
    12801524  tempBmp := surface.NewBitmap(foundRect.Right-foundRect.Left,foundRect.Bottom-foundRect.Top,BGRAPixelTransparent);
    1281   tempBmp.FillMode := fmWinding;
     1525  tempBmp.FillMode := AFillMode;
    12821526  tempBmp.FillPolyAntialias(ofsPts, getShadowColor);
    12831527  tempBmp.FillPolyAntialias(ofsPts2, getShadowColor);
     1528  DrawShadowMask(foundRect.Left,foundRect.Top, tempBmp, true);
     1529end;
     1530
     1531procedure TBGRACanvas2D.DrawShadowMask(X, Y: integer; AMask: TBGRACustomBitmap; AMaskOwned: boolean);
     1532const invSqrt2 = 1/sqrt(2);
     1533var
     1534  bmp: TBGRACustomBitmap;
     1535begin
     1536  bmp := AMask;
    12841537  if shadowBlur > 0 then
    12851538  begin
     
    12871540    begin
    12881541      if shadowBlur*invSqrt2 >= 0.5 then
    1289       begin
    1290         blurred := tempBmp.FilterBlurRadial(round(shadowBlur*invSqrt2),rbBox);
    1291         tempBmp.Free;
    1292         tempBmp := blurred;
    1293       end;
     1542        bmp := AMask.FilterBlurRadial(round(shadowBlur*invSqrt2),rbBox);
    12941543    end
    12951544    else
    12961545    begin
    12971546      if (shadowBlur < 5) and (abs(shadowBlur-round(shadowBlur)) > 1e-6) then
    1298         blurred := tempBmp.FilterBlurRadial(round(shadowBlur*10),rbPrecise)
     1547        bmp := AMask.FilterBlurRadial(round(shadowBlur*10),rbPrecise)
    12991548      else
    1300         blurred := tempBmp.FilterBlurRadial(round(shadowBlur),rbFast);
    1301       tempBmp.Free;
    1302       tempBmp := blurred;
     1549        bmp := AMask.FilterBlurRadial(round(shadowBlur),rbFast);
    13031550    end;
    13041551  end;
    13051552  if currentState.clipMaskReadOnly <> nil then
    1306     tempBmp.ApplyMask(currentState.clipMaskReadOnly);
    1307   surface.PutImage(foundRect.Left,foundRect.Top,tempBmp,GetDrawMode,currentState.globalAlpha);
    1308   tempBmp.Free;
     1553  begin
     1554    if (bmp = AMask) and not AMaskOwned then bmp := AMask.Duplicate;
     1555    bmp.ApplyMask(currentState.clipMaskReadOnly);
     1556  end;
     1557  surface.PutImage(X,Y,bmp,GetDrawMode,currentState.globalAlpha);
     1558  if bmp <> AMask then bmp.Free;
     1559  if AMaskOwned then AMask.Free;
    13091560end;
    13101561
     
    14361687  pixelCenteredCoordinates := false;
    14371688  antialiasing := true;
     1689  gradientGammaCorrection := false;
    14381690end;
    14391691
     
    16061858end;
    16071859
     1860function TBGRACanvas2D.GetFillMode: TFillMode;
     1861begin
     1862  result := currentState.fillMode;
     1863end;
     1864
     1865procedure TBGRACanvas2D.SetFillMode(mode: TFillMode);
     1866begin
     1867  currentState.fillMode := mode;
     1868end;     
     1869
    16081870procedure TBGRACanvas2D.fillStyle(color: TBGRAPixel);
    16091871begin
     
    16601922end;
    16611923
    1662 function TBGRACanvas2D.createLinearGradient(x0, y0, x1, y1: single
    1663   ): IBGRACanvasGradient2D;
    1664 begin
    1665   result := createLinearGradient(ApplyTransform(PointF(x0,y0)), ApplyTransform(PointF(x1,y1)));
    1666 end;
    1667 
    1668 function TBGRACanvas2D.createLinearGradient(p0, p1: TPointF
    1669   ): IBGRACanvasGradient2D;
    1670 begin
    1671   result := TBGRACanvasLinearGradient2D.Create(p0,p1);
     1924function TBGRACanvas2D.createLinearGradient(x0, y0, x1, y1: single): IBGRACanvasGradient2D;
     1925begin
     1926  result := createLinearGradient(PointF(x0,y0), PointF(x1,y1));
     1927end;
     1928
     1929function TBGRACanvas2D.createLinearGradient(p0, p1: TPointF): IBGRACanvasGradient2D;
     1930begin
     1931  result := TBGRACanvasLinearGradient2D.Create(p0,p1,
     1932            AffineMatrixTranslation(FCanvasOffset.x,FCanvasOffset.y)*currentState.matrix);
     1933  result.gammaCorrection := gradientGammaCorrection;
    16721934end;
    16731935
     
    16831945begin
    16841946  result := createLinearGradient(p0,p1);
     1947  result.setColors(Colors);
     1948end;
     1949
     1950function TBGRACanvas2D.createRadialGradient(x0, y0, r0, x1, y1, r1: single;
     1951  flipGradient: boolean): IBGRACanvasGradient2D;
     1952begin
     1953  result := createRadialGradient(PointF(x0,y0), r0, PointF(x1,y1), r1, flipGradient);
     1954end;
     1955
     1956function TBGRACanvas2D.createRadialGradient(p0: TPointF; r0: single;
     1957  p1: TPointF; r1: single; flipGradient: boolean): IBGRACanvasGradient2D;
     1958begin
     1959  result := TBGRACanvasRadialGradient2D.Create(p0,r0,p1,r1,
     1960            AffineMatrixTranslation(FCanvasOffset.x,FCanvasOffset.y)*currentState.matrix,
     1961            flipGradient);
     1962  result.gammaCorrection := gradientGammaCorrection;
     1963end;
     1964
     1965function TBGRACanvas2D.createRadialGradient(x0, y0, r0, x1, y1, r1: single;
     1966  Colors: TBGRACustomGradient; flipGradient: boolean): IBGRACanvasGradient2D;
     1967begin
     1968  result := createRadialGradient(x0,y0,r0,x1,y1,r1,flipGradient);
     1969  result.setColors(Colors);
     1970end;
     1971
     1972function TBGRACanvas2D.createRadialGradient(p0: TPointF; r0: single;
     1973  p1: TPointF; r1: single; Colors: TBGRACustomGradient; flipGradient: boolean): IBGRACanvasGradient2D;
     1974begin
     1975  result := createRadialGradient(p0,r0,p1,r1,flipGradient);
    16851976  result.setColors(Colors);
    16861977end;
     
    17712062  FLastCoord := EmptyPointF;
    17722063  FStartCoord := EmptyPointF;
     2064  FTextPaths := nil;
    17732065end;
    17742066
     
    18172109end;
    18182110
    1819 procedure TBGRACanvas2D.moveTo(const pt: TPointF);
     2111procedure TBGRACanvas2D.moveTo(constref pt: TPointF);
    18202112begin
    18212113  if (FPathPointCount <> 0) and not isEmptyPointF(FPathPoints[FPathPointCount-1]) then
     
    18262118end;
    18272119
    1828 procedure TBGRACanvas2D.lineTo(const pt: TPointF);
     2120procedure TBGRACanvas2D.lineTo(constref pt: TPointF);
    18292121begin
    18302122  AddPoint(ApplyTransform(pt));
     
    18522144end;
    18532145
    1854 procedure TBGRACanvas2D.quadraticCurveTo(const cp, pt: TPointF);
     2146procedure TBGRACanvas2D.quadraticCurveTo(constref cp, pt: TPointF);
    18552147begin
    18562148  quadraticCurveTo(cp.x,cp.y,pt.x,pt.y);
     
    18692161end;
    18702162
    1871 procedure TBGRACanvas2D.bezierCurveTo(const cp1, cp2, pt: TPointF);
     2163procedure TBGRACanvas2D.bezierCurveTo(constref cp1, cp2, pt: TPointF);
    18722164begin
    18732165  bezierCurveTo(cp1.x,cp1.y,cp2.x,cp2.y,pt.x,pt.y);
     
    20362328end;
    20372329
    2038 procedure TBGRACanvas2D.arc(const arcDef: TArcDef);
     2330procedure TBGRACanvas2D.arc(constref arcDef: TArcDef);
    20392331var previousMatrix: TAffineMatrix;
    20402332begin
     
    20842376var renderer : TBGRACustomFontRenderer;
    20852377  previousMatrix: TAffineMatrix;
     2378  fva: TFontVerticalAnchor;
    20862379begin
    20872380  renderer := fontRenderer;
     2381  if renderer = nil then exit;
    20882382  if renderer.FontEmHeight <= 0 then exit;
    2089   previousMatrix := currentState.matrix;
    2090 
    2091   scale(currentState.fontEmHeight/renderer.FontEmHeight);
    2092   if (currentState.textBaseline <> 'top') and
    2093     (currentState.textBaseline <> 'hanging') then
    2094   with renderer.GetFontPixelMetric do
    2095   begin
    2096     if currentState.textBaseline = 'bottom' then
    2097        translate(0,-Lineheight)
    2098     else if currentState.textBaseline = 'middle' then
    2099        translate(0,-Lineheight/2)
    2100     else if currentState.textBaseline = 'alphabetic' then
    2101        translate(0,-baseline);
    2102   end;
    2103 
    2104   if renderer <> nil then
    2105     renderer.CopyTextPathTo(self, x,y, AText, taLeftJustify);
    2106 
    2107   currentState.matrix := previousMatrix;
     2383
     2384  case currentState.textBaseline of
     2385    'bottom': fva := fvaBottom;
     2386    'middle': fva := fvaCenter;
     2387    'alphabetic': fva := fvaBaseline;
     2388    else {'top','hanging'}
     2389      fva := fvaTop;
     2390  end;
     2391
     2392  if renderer.HandlesTextPath then
     2393  begin
     2394    previousMatrix := currentState.matrix;
     2395    translate(x,y);
     2396    scale(currentState.fontEmHeight/renderer.FontEmHeight);
     2397    if fva <> fvaTop then
     2398    with renderer.GetFontPixelMetric do
     2399    case fva of
     2400      fvaBottom: translate(0,-Lineheight);
     2401      fvaCenter: translate(0,-Lineheight/2);
     2402      fvaBaseline: translate(0,-baseline);
     2403    end;
     2404    renderer.CopyTextPathTo(self, 0,0, AText, textAlignLCL);
     2405    currentState.matrix := previousMatrix;
     2406  end else
     2407  begin
     2408    setlength(FTextPaths, length(FTextPaths)+1);
     2409    FTextPaths[high(FTextPaths)].Text := AText;
     2410    FTextPaths[high(FTextPaths)].FontName := fontName;
     2411    FTextPaths[high(FTextPaths)].FontMatrix := currentState.matrix*AffineMatrixTranslation(x,y)*AffineMatrixScale(fontEmHeight,fontEmHeight);
     2412    FTextPaths[high(FTextPaths)].FontStyle := fontStyle;
     2413    FTextPaths[high(FTextPaths)].FontAlign := textAlignLCL;
     2414    FTextPaths[high(FTextPaths)].FontAnchor := fva;
     2415  end;
     2416
    21082417  FLastCoord := EmptyPointF;
    21092418  FStartCoord := EmptyPointF;
     
    21472456procedure TBGRACanvas2D.fill;
    21482457begin
    2149   if FPathPointCount = 0 then exit;
    2150   FillPoly(slice(FPathPoints,FPathPointCount));
     2458  if FPathPointCount > 0 then
     2459    FillPoly(slice(FPathPoints,FPathPointCount));
     2460  FillTexts(false);
    21512461end;
    21522462
    21532463procedure TBGRACanvas2D.stroke;
    21542464begin
    2155   if FPathPointCount = 0 then exit;
    2156   StrokePoly(slice(FPathPoints,FPathPointCount));
     2465  if FPathPointCount > 0 then
     2466    StrokePoly(slice(FPathPoints,FPathPointCount));
    21572467end;
    21582468
    21592469procedure TBGRACanvas2D.fillOverStroke;
    21602470begin
    2161   if FPathPointCount = 0 then exit;
    2162   FillStrokePoly(slice(FPathPoints,FPathPointCount),true);
     2471  if FPathPointCount > 0 then
     2472    FillStrokePoly(slice(FPathPoints,FPathPointCount),true);
     2473  FillTexts(false);
    21632474end;
    21642475
    21652476procedure TBGRACanvas2D.strokeOverFill;
    21662477begin
    2167   if FPathPointCount = 0 then exit;
    2168   FillStrokePoly(slice(FPathPoints,FPathPointCount),false);
     2478  FillTexts(false);
     2479  if FPathPointCount > 0 then
     2480    FillStrokePoly(slice(FPathPoints,FPathPointCount),false);
    21692481end;
    21702482
    21712483procedure TBGRACanvas2D.clearPath;
    21722484begin
    2173   if FPathPointCount = 0 then exit;
    2174   ClearPoly(slice(FPathPoints,FPathPointCount));
     2485  if FPathPointCount > 0 then
     2486    ClearPoly(slice(FPathPoints,FPathPointCount));
     2487  FillTexts(true);
    21752488end;
    21762489
     
    22192532  begin
    22202533    setlength(FPathPoints,FPathPointCount);
    2221     result := IsPointInPolygon(FPathPoints,pt+FCanvasOffset,True);
     2534    result := IsPointInPolygon(FPathPoints,pt+FCanvasOffset, fillMode = fmWinding);
    22222535  end;
    22232536end;
  • GraphicTest/Packages/bgrabitmap/bgracanvasgl.pas

    r494 r521  
    9494    function GetUniformVariable(AProgram: DWord; AName: string): DWord; virtual; abstract;
    9595    function GetAttribVariable(AProgram: DWord; AName: string): DWord; virtual; abstract;
    96     procedure SetUniformSingle(AVariable: DWord; const AValue; ACount: integer); virtual; abstract;
    97     procedure SetUniformInteger(AVariable: DWord; const AValue; ACount: integer); virtual; abstract;
     96    procedure SetUniformSingle(AVariable: DWord; const AValue; AElementCount, AComponentCount: integer); virtual; abstract;
     97    procedure SetUniformInteger(AVariable: DWord; const AValue; AElementCount, AComponentCount: integer); virtual; abstract;
    9898    procedure BindAttribute(AAttribute: TAttributeVariable); virtual; abstract;
    9999    procedure UnbindAttribute(AAttribute: TAttributeVariable); virtual; abstract;
     
    110110  TBGLCustomCanvas = class
    111111  private
     112    FActiveFrameBuffer: TBGLCustomFrameBuffer;
    112113    FHeight: integer;
    113114    FWidth: integer;
     
    115116    FClipRect: TRect;
    116117  protected
    117     procedure SwapRect(var r: TRect);
    118     procedure SwapRect(var x1,y1,x2,y2: single);
     118    procedure SwapRect(var r: TRect); overload;
     119    procedure SwapRect(var x1,y1,x2,y2: single); overload;
    119120    procedure InternalArc(cx,cy,rx,ry: single; const StartPoint,EndPoint: TPointF; ABorderColor,AOuterFillColor,ACenterFillColor: TBGRAPixel; AOptions: TArcOptions; ADrawChord: boolean = false); overload;
    120121    procedure InternalArc(cx,cy,rx,ry: single; StartAngleRad,EndAngleRad: Single; ABorderColor,AOuterFillColor,ACenterFillColor: TBGRAPixel; AOptions: TArcOptions; ADrawChord: boolean = false); overload;
    121122    procedure InternalArcInRect(r: TRect; StartAngleRad,EndAngleRad: Single; ABorderColor,AOuterFillColor,ACenterFillColor: TBGRAPixel; AOptions: TArcOptions; ADrawChord: boolean = false); overload;
    122123    function ComputeEllipseC(r: TRect; AHasBorder: boolean; out cx,cy,rx,ry: single): boolean;
     124    function GetHeight: integer; virtual;
     125    function GetWidth: integer; virtual;
    123126    procedure SetWidth(AValue: integer); virtual;
    124127    procedure SetHeight(AValue: integer); virtual;
     
    135138    function GetFaceCulling: TFaceCulling; virtual; abstract;
    136139    procedure SetFaceCulling(AValue: TFaceCulling); virtual; abstract;
     140    procedure SetActiveFrameBuffer(AValue: TBGLCustomFrameBuffer); virtual;
    137141
    138142    function GetLighting: TBGLCustomLighting; virtual;
     
    142146    procedure InternalStartPolygon(const pt: TPointF); virtual; abstract;
    143147    procedure InternalStartTriangleFan(const pt: TPointF); virtual; abstract;
    144     procedure InternalContinueShape(const pt: TPointF); virtual; abstract;
    145 
    146     procedure InternalContinueShape(const {%H-}pt: TPoint3D); virtual; overload;
    147     procedure InternalContinueShape(const {%H-}pt: TPoint3D_128); virtual; overload;
    148     procedure InternalContinueShape(const {%H-}pt, {%H-}normal: TPoint3D_128); virtual; overload;
     148    procedure InternalContinueShape(const pt: TPointF); overload; virtual; abstract;
     149
     150    procedure InternalContinueShape(const {%H-}pt: TPoint3D); overload; virtual;
     151    procedure InternalContinueShape(const {%H-}pt: TPoint3D_128); overload; virtual;
     152    procedure InternalContinueShape(const {%H-}pt, {%H-}normal: TPoint3D_128); overload; virtual;
    149153
    150154    procedure InternalEndShape; virtual; abstract;
     
    163167    procedure Fill(AColor: TBGRAPixel); virtual; abstract;
    164168
    165     procedure PutPixels(const APoints: array of TPointF; AColor: TBGRAPixel); virtual; overload;
    166     procedure PutPixels(const APoints: array of TPointF; const AColors: array of TBGRAPixel); virtual; overload;
    167 
    168     procedure Line(x1,y1,x2,y2: single; AColor: TBGRAPixel; ADrawLastPoint: boolean = true);
    169     procedure Line(p1,p2: TPointF; AColor: TBGRAPixel; ADrawLastPoint: boolean = true);
     169    procedure PutPixels(const APoints: array of TPointF; AColor: TBGRAPixel); overload; virtual;
     170    procedure PutPixels(const APoints: array of TPointF; const AColors: array of TBGRAPixel); overload; virtual;
     171
     172    procedure Line(x1,y1,x2,y2: single; AColor: TBGRAPixel; ADrawLastPoint: boolean = true); overload;
     173    procedure Line(p1,p2: TPointF; AColor: TBGRAPixel; ADrawLastPoint: boolean = true); overload;
    170174    procedure Polylines(const APoints: array of TPointF; AColor: TBGRAPixel; ADrawLastPoints: boolean = true); virtual;
    171175
     
    173177    procedure FillPolyConvex(const APoints: array of TPointF; AColor: TBGRAPixel; APixelCenteredCoordinates: boolean = true);
    174178
    175     procedure FillTriangleLinearColor(pt1,pt2,pt3: TPointF; c1,c2,c3: TBGRAPixel; APixelCenteredCoordinates: boolean = true);
    176     procedure FillTriangles(const APoints: array of TPointF; AColor: TBGRAPixel; APixelCenteredCoordinates: boolean = true); virtual;
    177     procedure FillTrianglesLinearColor(const APoints: array of TPointF; const AColors: array of TBGRAPixel; APixelCenteredCoordinates: boolean = true); virtual; overload;
    178     procedure FillTrianglesLinearColor(const APoints: array of TPoint3D; const AColors: array of TBGRAPixel); virtual; overload;
    179     procedure FillTrianglesLinearColor(const APoints: array of TPoint3D_128; const AColors: array of TBGRAPixel); virtual; overload;
    180     procedure FillTrianglesLinearColor(const APoints, ANormals: array of TPoint3D_128; const AColors: array of TBGRAPixel); virtual; overload;
    181     procedure FillTrianglesFan(const APoints: array of TPointF; ACenterColor, ABorderColor: TBGRAPixel; APixelCenteredCoordinates: boolean = true); virtual;
    182 
    183     procedure FillTriangleLinearColor(pt1,pt2,pt3: TPointF; c1,c2,c3: TColorF; APixelCenteredCoordinates: boolean = true);
    184     procedure FillTriangles(const APoints: array of TPointF; AColor: TColorF; APixelCenteredCoordinates: boolean = true); virtual;
    185     procedure FillTrianglesLinearColor(const APoints: array of TPointF; const AColors: array of TColorF; APixelCenteredCoordinates: boolean = true); virtual; overload;
    186     procedure FillTrianglesLinearColor(const APoints: array of TPoint3D; const AColors: array of TColorF); virtual; overload;
    187     procedure FillTrianglesLinearColor(const APoints: array of TPoint3D_128; const AColors: array of TColorF); virtual; overload;
    188     procedure FillTrianglesLinearColor(const APoints, ANormals: array of TPoint3D_128; const AColors: array of TColorF); virtual; overload;
    189     procedure FillTrianglesFan(const APoints: array of TPointF; ACenterColor, ABorderColor: TColorF; APixelCenteredCoordinates: boolean = true); virtual;
    190 
    191     procedure FillQuadLinearColor(pt1,pt2,pt3,pt4: TPointF; c1,c2,c3,c4: TBGRAPixel; APixelCenteredCoordinates: boolean = true);
    192     procedure FillQuads(const APoints: array of TPointF; AColor: TBGRAPixel; APixelCenteredCoordinates: boolean = true); virtual;
    193     procedure FillQuadsLinearColor(const APoints: array of TPointF; const AColors: array of TBGRAPixel; APixelCenteredCoordinates: boolean = true); virtual; overload;
    194     procedure FillQuadsLinearColor(const APoints: array of TPoint3D; const AColors: array of TBGRAPixel); virtual; overload;
    195     procedure FillQuadsLinearColor(const APoints: array of TPoint3D_128; const AColors: array of TBGRAPixel); virtual; overload;
    196     procedure FillQuadsLinearColor(const APoints, ANormals: array of TPoint3D_128; const AColors: array of TBGRAPixel); virtual; overload;
    197 
    198     procedure FillQuadLinearColor(pt1,pt2,pt3,pt4: TPointF; c1,c2,c3,c4: TColorF; APixelCenteredCoordinates: boolean = true);
    199     procedure FillQuads(const APoints: array of TPointF; AColor: TColorF; APixelCenteredCoordinates: boolean = true); virtual;
    200     procedure FillQuadsLinearColor(const APoints: array of TPointF; const AColors: array of TColorF; APixelCenteredCoordinates: boolean = true); virtual; overload;
    201     procedure FillQuadsLinearColor(const APoints: array of TPoint3D; const AColors: array of TColorF); virtual; overload;
    202     procedure FillQuadsLinearColor(const APoints: array of TPoint3D_128; const AColors: array of TColorF); virtual; overload;
    203     procedure FillQuadsLinearColor(const APoints, ANormals: array of TPoint3D_128; const AColors: array of TColorF); virtual; overload;
     179    procedure FillTriangleLinearColor(pt1,pt2,pt3: TPointF; c1,c2,c3: TBGRAPixel; APixelCenteredCoordinates: boolean = true); overload;
     180    procedure FillTriangles(const APoints: array of TPointF; AColor: TBGRAPixel; APixelCenteredCoordinates: boolean = true); overload; virtual;
     181    procedure FillTrianglesLinearColor(const APoints: array of TPointF; const AColors: array of TBGRAPixel; APixelCenteredCoordinates: boolean = true); overload; virtual;
     182    procedure FillTrianglesLinearColor(const APoints: array of TPoint3D; const AColors: array of TBGRAPixel); overload; virtual;
     183    procedure FillTrianglesLinearColor(const APoints: array of TPoint3D_128; const AColors: array of TBGRAPixel); overload; virtual;
     184    procedure FillTrianglesLinearColor(const APoints, ANormals: array of TPoint3D_128; const AColors: array of TBGRAPixel); overload; virtual;
     185    procedure FillTrianglesFan(const APoints: array of TPointF; ACenterColor, ABorderColor: TBGRAPixel; APixelCenteredCoordinates: boolean = true); overload; virtual;
     186
     187    procedure FillTriangleLinearColor(pt1,pt2,pt3: TPointF; c1,c2,c3: TColorF; APixelCenteredCoordinates: boolean = true); overload;
     188    procedure FillTriangles(const APoints: array of TPointF; AColor: TColorF; APixelCenteredCoordinates: boolean = true); overload; virtual;
     189    procedure FillTrianglesLinearColor(const APoints: array of TPointF; const AColors: array of TColorF; APixelCenteredCoordinates: boolean = true); overload; virtual;
     190    procedure FillTrianglesLinearColor(const APoints: array of TPoint3D; const AColors: array of TColorF); overload; virtual;
     191    procedure FillTrianglesLinearColor(const APoints: array of TPoint3D_128; const AColors: array of TColorF); overload; virtual;
     192    procedure FillTrianglesLinearColor(const APoints, ANormals: array of TPoint3D_128; const AColors: array of TColorF); overload; virtual;
     193    procedure FillTrianglesFan(const APoints: array of TPointF; ACenterColor, ABorderColor: TColorF; APixelCenteredCoordinates: boolean = true); overload; virtual;
     194
     195    procedure FillQuadLinearColor(pt1,pt2,pt3,pt4: TPointF; c1,c2,c3,c4: TBGRAPixel; APixelCenteredCoordinates: boolean = true); overload;
     196    procedure FillQuads(const APoints: array of TPointF; AColor: TBGRAPixel; APixelCenteredCoordinates: boolean = true); overload; virtual;
     197    procedure FillQuadsLinearColor(const APoints: array of TPointF; const AColors: array of TBGRAPixel; APixelCenteredCoordinates: boolean = true); overload; virtual;
     198    procedure FillQuadsLinearColor(const APoints: array of TPoint3D; const AColors: array of TBGRAPixel); overload; virtual;
     199    procedure FillQuadsLinearColor(const APoints: array of TPoint3D_128; const AColors: array of TBGRAPixel); overload; virtual;
     200    procedure FillQuadsLinearColor(const APoints, ANormals: array of TPoint3D_128; const AColors: array of TBGRAPixel); overload; virtual;
     201
     202    procedure FillQuadLinearColor(pt1,pt2,pt3,pt4: TPointF; c1,c2,c3,c4: TColorF; APixelCenteredCoordinates: boolean = true); overload;
     203    procedure FillQuads(const APoints: array of TPointF; AColor: TColorF; APixelCenteredCoordinates: boolean = true); overload; virtual;
     204    procedure FillQuadsLinearColor(const APoints: array of TPointF; const AColors: array of TColorF; APixelCenteredCoordinates: boolean = true); overload; virtual;
     205    procedure FillQuadsLinearColor(const APoints: array of TPoint3D; const AColors: array of TColorF); overload; virtual;
     206    procedure FillQuadsLinearColor(const APoints: array of TPoint3D_128; const AColors: array of TColorF); overload; virtual;
     207    procedure FillQuadsLinearColor(const APoints, ANormals: array of TPoint3D_128; const AColors: array of TColorF); overload; virtual;
    204208
    205209    procedure DrawPath(APath: TBGLPath; c: TBGRAPixel);
    206210    procedure FillPathConvex(APath: TBGLPath; c: TBGRAPixel; APixelCenteredCoordinates: boolean = true);
    207211
    208     procedure FillRectLinearColor(r: TRect; ATopLeftColor, ATopRightColor, ABottomRightColor, ABottomLeftColor: TBGRAPixel); virtual; overload;
     212    procedure FillRectLinearColor(r: TRect; ATopLeftColor, ATopRightColor, ABottomRightColor, ABottomLeftColor: TBGRAPixel); overload; virtual;
    209213    procedure FillRectLinearColor(x1,y1,x2,y2: single;
    210214         ATopLeftColor, ATopRightColor, ABottomRightColor, ABottomLeftColor: TBGRAPixel;
    211          APixelCenteredCoordinates: boolean = true); virtual; overload;
     215         APixelCenteredCoordinates: boolean = true); overload; virtual;
    212216
    213217    procedure Ellipse(cx,cy,rx,ry: single; AColor: TBGRAPixel); overload;
     
    247251    procedure FillRect(r: TRect; AColor: TBGRAPixel); overload;
    248252    procedure FillRect(r: TRectF; AColor: TBGRAPixel; APixelCenteredCoordinates: boolean = false); overload;
    249     procedure FillRect(r: TRect; AScanner: IBGRAScanner); virtual; overload;
     253    procedure FillRect(r: TRect; AScanner: IBGRAScanner); overload; virtual;
    250254    procedure RoundRect(x1,y1,x2,y2,rx,ry: single; ABorderColor: TBGRAPixel; options: TRoundRectangleOptions = []); overload;
    251255    procedure RoundRect(x1,y1,x2,y2,rx,ry: single; ABorderColor,AFillColor: TBGRAPixel; options: TRoundRectangleOptions = []); overload;
     
    275279    procedure ResetTransform; virtual;
    276280
    277     procedure UseOrthoProjection; virtual; overload;
    278     procedure UseOrthoProjection(AMinX,AMinY,AMaxX,AMaxY: single); virtual; overload;
     281    procedure UseOrthoProjection; overload; virtual;
     282    procedure UseOrthoProjection(AMinX,AMinY,AMaxX,AMaxY: single); overload; virtual;
    279283    procedure StartZBuffer; virtual;
    280284    procedure EndZBuffer; virtual;
    281285    procedure WaitForGPU({%H-}AOption: TWaitForGPUOption); virtual;
    282286
     287    function GetImage({%H-}x,{%H-}y,{%H-}w,{%H-}h: integer): TBGRACustomBitmap; virtual;
     288    function CreateFrameBuffer({%H-}AWidth,{%H-}AHeight: integer): TBGLCustomFrameBuffer; virtual;
     289
    283290    procedure NoClip;
    284     property Width: integer read FWidth write SetWidth;
    285     property Height: integer read FHeight write SetHeight;
     291    property ActiveFrameBuffer: TBGLCustomFrameBuffer read FActiveFrameBuffer write SetActiveFrameBuffer;
     292    property Width: integer read GetWidth write SetWidth;
     293    property Height: integer read GetHeight write SetHeight;
    286294    property ClipRect: TRect read GetClipRect write SetClipRect;
    287295    property Matrix: TAffineMatrix read GetMatrix write SetMatrix;
     
    346354var index: integer;
    347355begin
     356  if ShaderList = nil then ShaderList := TStringList.Create;
    348357  index := ShaderList.IndexOf(AName);
    349358  if index = -1 then
     
    356365var index: integer;
    357366begin
     367  if ShaderList = nil then ShaderList := TStringList.Create;
    358368  index := ShaderList.IndexOf(AName);
    359369  if AValue = nil then
     
    459469  end;
    460470  result := true;
     471end;
     472
     473function TBGLCustomCanvas.GetHeight: integer;
     474begin
     475  if FActiveFrameBuffer = nil then
     476    result := FHeight
     477  else
     478    result := FActiveFrameBuffer.Height;
     479end;
     480
     481function TBGLCustomCanvas.GetWidth: integer;
     482begin
     483  if FActiveFrameBuffer = nil then
     484    result := FWidth
     485  else
     486    result := FActiveFrameBuffer.Width;
    461487end;
    462488
     
    11891215end;
    11901216
     1217procedure TBGLCustomCanvas.SetActiveFrameBuffer(AValue: TBGLCustomFrameBuffer);
     1218begin
     1219  if FActiveFrameBuffer=AValue then Exit;
     1220  if FActiveFrameBuffer <> nil then
     1221    FActiveFrameBuffer.SetCanvas(nil);
     1222  FActiveFrameBuffer:=AValue;
     1223  if FActiveFrameBuffer <> nil then
     1224    FActiveFrameBuffer.SetCanvas(self);
     1225end;
     1226
    11911227procedure TBGLCustomCanvas.SwapRect(var r: TRect);
    11921228var
     
    17141750  ATexture: IBGLTexture; AAlpha: byte);
    17151751begin
     1752  {$PUSH}{$OPTIMIZATION OFF}
    17161753  ATexture.DrawAffine(Origin, HAxis, VAxis, AAlpha);
     1754  {$POP}
    17171755end;
    17181756
     
    17201758  ATexture: IBGLTexture; AColor: TBGRAPixel);
    17211759begin
     1760  {$PUSH}{$OPTIMIZATION OFF}
    17221761  ATexture.DrawAffine(Origin, HAxis, VAxis, AColor);
     1762  {$POP}
    17231763end;
    17241764
     
    17851825end;
    17861826
     1827function TBGLCustomCanvas.GetImage(x, y, w, h: integer): TBGRACustomBitmap;
     1828begin
     1829  result := nil;
     1830end;
     1831
     1832function TBGLCustomCanvas.CreateFrameBuffer(AWidth, AHeight: integer): TBGLCustomFrameBuffer;
     1833begin
     1834  result := nil;
     1835  raise exception.Create('Not implemented');
     1836end;
     1837
    17871838end.
    17881839
  • GraphicTest/Packages/bgrabitmap/bgracolorquantization.pas

    r494 r521  
    4141    FSeparateAlphaChannel: boolean;
    4242    procedure Init(ABox: TBGRAColorBox);
    43     procedure NormalizeArrayOfColors(AColors: ArrayOfTBGRAPixel; ARedBounds, AGreenBounds, ABlueBounds, AAlphaBounds: TDimensionMinMax; AUniform: boolean);
    44     procedure NormalizeArrayOfColors(AColors: ArrayOfTBGRAPixel; AColorBounds, AAlphaBounds: TDimensionMinMax);
     43    procedure NormalizeArrayOfColors(AColors: ArrayOfTBGRAPixel; ARedBounds, AGreenBounds, ABlueBounds, AAlphaBounds: TDimensionMinMax; AUniform: boolean); overload;
     44    procedure NormalizeArrayOfColors(AColors: ArrayOfTBGRAPixel; AColorBounds, AAlphaBounds: TDimensionMinMax); overload;
    4545  protected
    4646    function GetPalette: TBGRACustomApproxPalette; override;
     
    5656    destructor Destroy; override;
    5757    procedure ApplyDitheringInplace(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; ABounds: TRect); override;
    58     function GetDitheredBitmap(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; ABounds: TRect): TBGRACustomBitmap; override;
     58    function GetDitheredBitmap(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; ABounds: TRect): TBGRACustomBitmap; overload; override;
    5959    function GetDitheredBitmapIndexedData(ABitDepth: integer; AByteOrder: TRawImageByteOrder; AAlgorithm: TDitheringAlgorithm;
    60       ABitmap: TBGRACustomBitmap; out AScanlineSize: PtrInt): Pointer; override;
     60      ABitmap: TBGRACustomBitmap; out AScanlineSize: PtrInt): Pointer; overload; override;
    6161    procedure SaveBitmapToStream(AAlgorithm: TDitheringAlgorithm;
    6262      ABitmap: TBGRACustomBitmap; AStream: TStream; AFormat: TBGRAImageFormat); override;
     
    228228implementation
    229229
    230 uses BGRADithering, FPimage, FPWriteBMP, BGRAWritePNG;
     230uses BGRADithering, FPimage, FPWriteBMP, BGRAWritePNG, math;
    231231
    232232const MedianMinPercentage = 0.2;
     
    11311131      begin
    11321132        FLeafColorComputed := true;
    1133         FCenterColor.alpha:= FLeaf.FBounds[cdAlpha].GetCenter shr AlphaShift;
    1134         FCenterColor.red:= GammaCompressionTab[FLeaf.FBounds[cdRed].GetCenter shr RedShift];
    1135         FCenterColor.green:= GammaCompressionTab[FLeaf.FBounds[cdGreen].GetCenter shr GreenShift];
    1136         FCenterColor.blue:= GammaCompressionTab[FLeaf.FBounds[cdBlue].GetCenter];
     1133        FCenterColor.alpha:= min(FLeaf.FBounds[cdAlpha].GetCenter shr AlphaShift, 255);
     1134        FCenterColor.red:= GammaCompressionTab[min(FLeaf.FBounds[cdRed].GetCenter shr RedShift, 65535)];
     1135        FCenterColor.green:= GammaCompressionTab[min(FLeaf.FBounds[cdGreen].GetCenter shr GreenShift, 65535)];
     1136        FCenterColor.blue:= GammaCompressionTab[min(FLeaf.FBounds[cdBlue].GetCenter, 65535)];
    11371137        FAverageColor := FLeaf.AverageColorOrMainColor;
    11381138        extremumColor := FAverageColor;
  • GraphicTest/Packages/bgrabitmap/bgracompressablebitmap.pas

    r494 r521  
    4747   public
    4848     CompressionLevel: Tcompressionlevel;
    49      constructor Create;
    50      constructor Create(Source: TBGRABitmap);
     49     constructor Create; overload;
     50     constructor Create(Source: TBGRABitmap); overload;
    5151     function GetBitmap: TBGRABitmap;
    52      
     52
    5353     //call Compress as many times as necessary
    5454     //when it returns false, it means that
     
    6969implementation
    7070
     71uses BGRAUTF8;
     72
    7173// size of each chunk treated by Compress function
    7274const maxPartSize = 524288;
     
    153155
    154156    comp := Tcompressionstream.Create(CompressionLevel,FCompressedDataArray[high(FCompressedDataArray)],true);
    155     comp.write(partSize,sizeof(partSize));
     157    LEWriteLongint(comp, partSize);
    156158    comp.CopyFrom(FUncompressedData,partSize);
    157159    comp.Free;
     
    163165end;
    164166
    165 {$hints off}
    166 function WinReadLongint(Stream: TStream): longint;
    167 begin
    168   stream.Read(Result, sizeof(Result));
    169   Result := LEtoN(Result);
    170 end;
    171 {$hints on}
    172 
    173 procedure WinWriteLongint(Stream: TStream; AValue: LongInt);
    174 begin
    175   AValue := NtoLE(AValue);
    176   stream.Write(AValue, sizeof(AValue));
    177 end;
    178 
    179167procedure TBGRACompressableBitmap.WriteToStream(AStream: TStream);
    180168var i:integer;
     
    182170  repeat
    183171  until not Compress;
    184   WinWriteLongint(AStream,FWidth);
    185   WinWriteLongint(AStream,FHeight);
    186   WinWriteLongint(AStream,length(FCaption));
     172  LEWriteLongint(AStream,FWidth);
     173  LEWriteLongint(AStream,FHeight);
     174  LEWriteLongint(AStream,length(FCaption));
    187175  AStream.Write(FCaption[1],length(FCaption));
    188176  if (FWidth=0) or (FHeight = 0) then exit;
    189177
    190   WinWriteLongint(AStream,FBounds.Left);
    191   WinWriteLongint(AStream,FBounds.Top);
    192   WinWriteLongint(AStream,FBounds.Right);
    193   WinWriteLongint(AStream,FBounds.Bottom);
    194   WinWriteLongint(AStream,ord(FLineOrder));
    195 
    196   WinWriteLongint(AStream,length(FCompressedDataArray));
     178  LEWriteLongint(AStream,FBounds.Left);
     179  LEWriteLongint(AStream,FBounds.Top);
     180  LEWriteLongint(AStream,FBounds.Right);
     181  LEWriteLongint(AStream,FBounds.Bottom);
     182  LEWriteLongint(AStream,ord(FLineOrder));
     183
     184  LEWriteLongint(AStream,length(FCompressedDataArray));
    197185  for i := 0 to high(FCompressedDataArray) do
    198186  begin
    199     WinWriteLongint(AStream,FCompressedDataArray[i].Size);
     187    LEWriteLongint(AStream,FCompressedDataArray[i].Size);
    200188    FCompressedDataArray[i].Position := 0;
    201189    AStream.CopyFrom(FCompressedDataArray[i],FCompressedDataArray[i].Size);
     
    207195begin
    208196  FreeData;
    209   FWidth := WinReadLongint(AStream);
    210   FHeight := WinReadLongint(AStream);
    211   setlength(FCaption,WinReadLongint(AStream));
     197  FWidth := LEReadLongint(AStream);
     198  FHeight := LEReadLongint(AStream);
     199  setlength(FCaption,LEReadLongint(AStream));
    212200  AStream.Read(FCaption[1],length(FCaption));
    213201  if (FWidth=0) or (FHeight = 0) then
     
    217205  end;
    218206
    219   FBounds.Left := WinReadLongint(AStream);
    220   FBounds.Top := WinReadLongint(AStream);
    221   FBounds.Right := WinReadLongint(AStream);
    222   FBounds.Bottom := WinReadLongint(AStream);
    223   FLineOrder := TRawImageLineOrder(WinReadLongint(AStream));
    224 
    225   setlength(FCompressedDataArray,WinReadLongint(AStream));
     207  FBounds.Left := LEReadLongint(AStream);
     208  FBounds.Top := LEReadLongint(AStream);
     209  FBounds.Right := LEReadLongint(AStream);
     210  FBounds.Bottom := LEReadLongint(AStream);
     211  FLineOrder := TRawImageLineOrder(LEReadLongint(AStream));
     212
     213  setlength(FCompressedDataArray,LEReadLongint(AStream));
    226214  for i := 0 to high(FCompressedDataArray) do
    227215  begin
    228     size := WinReadLongint(AStream);
     216    size := LEReadLongint(AStream);
    229217    FCompressedDataArray[i] := TMemoryStream.Create;
    230218    FCompressedDataArray[i].CopyFrom(AStream,size);
     
    246234    FCompressedDataArray[i].Position := 0;
    247235    decomp := Tdecompressionstream.Create(FCompressedDataArray[i],true);
    248     {$hints off}
    249     decomp.read(partSize,sizeof(partSize));
    250     {$hints on}
     236    partSize := LEReadLongint(decomp);
    251237    FUncompressedData.CopyFrom(decomp,partSize);
    252238    decomp.Free;
  • GraphicTest/Packages/bgrabitmap/bgracustombitmap.inc

    r494 r521  
    3737    {** Returns the corresponding OpenGL texture. The value is ''nil'' if no texture is associated. **}
    3838    function GetTextureGL: IUnknown;
    39     function GetImageBoundsWithin(const ARect: TRect; Channel: TChannel = cAlpha; ANothingValue: Byte = 0): TRect;
    40     function GetImageBoundsWithin(const ARect: TRect; Channels: TChannels; ANothingValue: Byte = 0): TRect;
     39    function GetImageBoundsWithin(const ARect: TRect; Channel: TChannel = cAlpha; ANothingValue: Byte = 0): TRect; overload;
     40    function GetImageBoundsWithin(const ARect: TRect; Channels: TChannels; ANothingValue: Byte = 0): TRect; overload;
    4141    function ProvidesScanline(ARect: TRect): boolean;
    4242    function GetScanlineAt(X,Y: integer): PBGRAPixel;
     
    6666    function IsScanPutPixelsDefined: boolean; virtual;
    6767    function GetTextureGL: IUnknown; virtual;
    68     function GetImageBoundsWithin(const ARect: TRect; Channel: TChannel = cAlpha; ANothingValue: Byte = 0): TRect; virtual;
    69     function GetImageBoundsWithin(const ARect: TRect; Channels: TChannels; ANothingValue: Byte = 0): TRect; virtual;
     68    function GetImageBoundsWithin(const ARect: TRect; Channel: TChannel = cAlpha; ANothingValue: Byte = 0): TRect; overload; virtual;
     69    function GetImageBoundsWithin(const ARect: TRect; Channels: TChannels; ANothingValue: Byte = 0): TRect; overload; virtual;
    7070    function ProvidesScanline({%H-}ARect: TRect): boolean; virtual;
    7171    function GetScanlineAt({%H-}X,{%H-}Y: integer): PBGRAPixel; virtual;
     
    9292    procedure SetFontAntialias(const AValue: Boolean);
    9393  protected
    94      { accessors to properies }
     94    FXorMask: TBGRACustomBitmap;
     95
     96    { accessors to properies }
    9597     function GetArrowEndRepeat: integer; virtual; abstract;
    9698     function GetArrowStartRepeat: integer; virtual; abstract;
     
    114116     function GetNbPixels: integer; virtual; abstract;
    115117     function CheckEmpty: boolean; virtual; abstract;
     118     function CheckIsZero: boolean; virtual; abstract;
    116119     function GetHasTransparentPixels: boolean; virtual; abstract;
     120     function GetHasSemiTransparentPixels: boolean; virtual; abstract;
    117121     function GetAverageColor: TColor; virtual; abstract;
    118122     function GetAveragePixel: TBGRAPixel; virtual; abstract;
     
    133137     function GetFontFullHeight: integer; virtual; abstract;
    134138     procedure SetFontFullHeight(AHeight: integer); virtual; abstract;
     139     function GetFontVerticalAnchorOffset: single; virtual; abstract;
    135140     function GetPenJoinStyle: TPenJoinStyle; virtual; abstract;
    136141     procedure SetPenJoinStyle(const AValue: TPenJoinStyle); virtual; abstract;
     
    153158
    154159     function GetTextureGL: IUnknown; virtual;
     160     function GetFontRightToLeftFor(AText: string): boolean;
    155161
    156162  public
     
    175181     ScanOffset: TPoint;
    176182
     183     {** Cursor position for mouse pointer }
     184     HotSpot: TPoint;
     185
     186     { ** Free reference to xor mask }
     187     procedure DiscardXorMask; virtual; abstract;
     188
     189     { ** Allocate xor mask }
     190     procedure NeedXorMask; virtual; abstract;
     191
     192     {** Xor mask to be applied when image is drawn }
     193     property XorMask: TBGRACustomBitmap read FXorMask;
     194
    177195     {** Width of the image in pixels }
    178196     property Width: integer Read GetWidth;
     
    208226     {** Returns True if the bitmap only contains transparent pixels or has a size of zero }
    209227     property Empty: boolean Read CheckEmpty;
     228     property IsZero: boolean Read CheckIsZero;
    210229
    211230     {** Returns True if there are transparent or semitransparent pixels,
    212231         and so if the image would be stored with an alpha channel }
    213232     property HasTransparentPixels: boolean Read GetHasTransparentPixels;
     233     property HasSemiTransparentPixels: boolean Read GetHasSemiTransparentPixels;
    214234
    215235     {** Average color of the image }
     
    289309     FontVerticalAnchor: TFontVerticalAnchor;
    290310
     311     {** Specifies the base direction of the text (cf Unicode). By default, it is
     312         automatically determined by the first strongly oriented character.
     313         You can specify another base direction here however it is not taken
     314         into account by the LCL on Linux. }
     315     FontBidiMode: TFontBidiMode;
     316
    291317     {** Specifies the height of the font in pixels without taking into account
    292318         additional line spacing. A negative value means that it is the
     
    300326     {** Simplified property to specify the quality (see ''FontQuality'') }
    301327     property FontAntialias: Boolean read GetFontAntialias write SetFontAntialias;
     328
     329     property FontVerticalAnchorOffset: single read GetFontVerticalAnchorOffset;
     330
    302331     {** Returns measurement for the current font in pixels }
    303332     property FontPixelMetric: TFontPixelMetric read GetFontPixelMetric;
     
    317346
    318347  public
    319      constructor Create; virtual; abstract; overload;
    320      constructor Create(AFPImage: TFPCustomImage); virtual; abstract; overload;
    321      constructor Create(ABitmap: TBitmap; AUseTransparent: boolean = true); virtual; abstract; overload;
    322      constructor Create(AWidth, AHeight: integer; Color: TColor); virtual; abstract; overload;
    323      constructor Create(AWidth, AHeight: integer; Color: TBGRAPixel); virtual; abstract; overload;
    324      constructor Create(AFilename: string); virtual; abstract; overload;
    325      constructor Create(AFilename: string; AIsUtf8Filename: boolean); virtual; abstract; overload;
    326      constructor Create(AFilename: string; AIsUtf8Filename: boolean; AOptions: TBGRALoadingOptions); virtual; abstract; overload;
    327      constructor Create(AStream: TStream); virtual; abstract; overload;
    328 
    329      function NewBitmap(AWidth, AHeight: integer): TBGRACustomBitmap; virtual; abstract; overload;
    330      function NewBitmap(AWidth, AHeight: integer; Color: TBGRAPixel): TBGRACustomBitmap; virtual; abstract; overload;
    331      function NewBitmap(Filename: string): TBGRACustomBitmap; virtual; abstract; overload;
    332      function NewBitmap(Filename: string; AIsUtf8: boolean): TBGRACustomBitmap; virtual; abstract; overload;
    333      function NewBitmap(Filename: string; AIsUtf8: boolean; AOptions: TBGRALoadingOptions): TBGRACustomBitmap; virtual; abstract; overload;
    334      function NewBitmap(AFPImage: TFPCustomImage): TBGRACustomBitmap; virtual; abstract; overload;
     348     constructor Create; overload; virtual; abstract;
     349     constructor Create(AFPImage: TFPCustomImage); overload; virtual; abstract;
     350     constructor Create(ABitmap: TBitmap; AUseTransparent: boolean = true); overload; virtual; abstract;
     351     constructor Create(AWidth, AHeight: integer; Color: TColor); overload; virtual; abstract;
     352     constructor Create(AWidth, AHeight: integer; Color: TBGRAPixel); overload; virtual; abstract;
     353     constructor Create(AFilename: string); overload; virtual; abstract;
     354     constructor Create(AFilename: string; AIsUtf8Filename: boolean); overload; virtual; abstract;
     355     constructor Create(AFilename: string; AIsUtf8Filename: boolean; AOptions: TBGRALoadingOptions); overload; virtual; abstract;
     356     constructor Create(AStream: TStream); overload; virtual; abstract;
     357
     358     function NewBitmap(AWidth, AHeight: integer): TBGRACustomBitmap; overload; virtual; abstract;
     359     function NewBitmap(AWidth, AHeight: integer; Color: TBGRAPixel): TBGRACustomBitmap; overload; virtual; abstract;
     360     function NewBitmap(Filename: string): TBGRACustomBitmap; overload; virtual; abstract;
     361     function NewBitmap(Filename: string; AIsUtf8: boolean): TBGRACustomBitmap; overload; virtual; abstract;
     362     function NewBitmap(Filename: string; AIsUtf8: boolean; AOptions: TBGRALoadingOptions): TBGRACustomBitmap; overload; virtual; abstract;
     363     function NewBitmap(AFPImage: TFPCustomImage): TBGRACustomBitmap; overload; virtual; abstract;
    335364
    336365     //there are UTF8 functions that are different from standard function as those
     
    338367  {==== Load and save files ====}
    339368     {** Load image from a file. ''filename'' is an ANSI string }
    340      procedure LoadFromFile(const filename: string); virtual;
    341      procedure LoadFromFile(const filename: string; AOptions: TBGRALoadingOptions); virtual;
     369     procedure LoadFromFile(const filename: string); overload; virtual;
     370     procedure LoadFromFile(const filename: string; AOptions: TBGRALoadingOptions); overload; virtual;
    342371     {** Load image from a file with the specified image reader. ''filename'' is an ANSI string }
    343      procedure LoadFromFile(const filename:String; Handler:TFPCustomImageReader); virtual;
    344      procedure LoadFromFile(const filename:String; Handler:TFPCustomImageReader; AOptions: TBGRALoadingOptions); virtual;
     372     procedure LoadFromFile(const filename:String; Handler:TFPCustomImageReader); overload; virtual;
     373     procedure LoadFromFile(const filename:String; Handler:TFPCustomImageReader; AOptions: TBGRALoadingOptions); overload; virtual;
    345374     {** Load image from a file. ''filename'' is an UTF8 string }
    346      procedure LoadFromFileUTF8(const filenameUTF8: string; AOptions: TBGRALoadingOptions = []); virtual;
     375     procedure LoadFromFileUTF8(const filenameUTF8: string; AOptions: TBGRALoadingOptions = []); overload; virtual;
    347376     {** Load image from a file with the specified image reader. ''filename'' is an UTF8 string }
    348      procedure LoadFromFileUTF8(const filenameUTF8: string; AHandler: TFPCustomImageReader; AOptions: TBGRALoadingOptions = []); virtual;
     377     procedure LoadFromFileUTF8(const filenameUTF8: string; AHandler: TFPCustomImageReader; AOptions: TBGRALoadingOptions = []); overload; virtual;
    349378     {** Load image from a stream. Format is detected automatically }
    350      procedure LoadFromStream(Str: TStream); virtual; overload;
    351      procedure LoadFromStream(Str: TStream; AOptions: TBGRALoadingOptions); virtual; overload;
     379     procedure LoadFromStream(Str: TStream);overload; virtual;
     380     procedure LoadFromStream(Str: TStream; AOptions: TBGRALoadingOptions);overload; virtual;
    352381     {** Load image from a stream. The specified image reader is used }
    353      procedure LoadFromStream(Str: TStream; Handler: TFPCustomImageReader); virtual; overload;
    354      procedure LoadFromStream(Str: TStream; Handler: TFPCustomImageReader; AOptions: TBGRALoadingOptions); virtual; overload;
     382     procedure LoadFromStream(Str: TStream; Handler: TFPCustomImageReader);overload; virtual;
     383     procedure LoadFromStream(Str: TStream; Handler: TFPCustomImageReader; AOptions: TBGRALoadingOptions);overload; virtual;
     384     {** Load image from an embedded Lazarus resource. Format is detected automatically }
     385     procedure LoadFromResource(AFilename: string); overload; virtual;
     386     procedure LoadFromResource(AFilename: string; AOptions: TBGRALoadingOptions); overload; virtual; abstract;
     387     {** Load image from an embedded Lazarus resource. The specified image reader is used }
     388     procedure LoadFromResource(AFilename: string; Handler: TFPCustomImageReader); overload; virtual;
     389     procedure LoadFromResource(AFilename: string; Handler: TFPCustomImageReader; AOptions: TBGRALoadingOptions); overload; virtual;
    355390
    356391     {** Save image to a file. The format is guessed from the file extension. ''filename'' is an ANSI string }
    357      procedure SaveToFile(const filename: string); virtual; overload;
     392     procedure SaveToFile(const filename: string);overload; virtual;
    358393     {** Save image to a file with the specified image writer. ''filename'' is an ANSI string }
    359      procedure SaveToFile(const filename: string; Handler:TFPCustomImageWriter); virtual; overload;
     394     procedure SaveToFile(const filename: string; Handler:TFPCustomImageWriter);overload; virtual;
    360395     {** Save image to a file. The format is guessed from the file extension. ''filename'' is an ANSI string }
    361      procedure SaveToFileUTF8(const filenameUTF8: string); virtual; overload;
     396     procedure SaveToFileUTF8(const filenameUTF8: string);overload; virtual;
    362397     {** Save image to a file with the specified image writer. ''filename'' is an UTF8 string }
    363      procedure SaveToFileUTF8(const filenameUTF8: string; Handler:TFPCustomImageWriter); virtual; overload;
     398     procedure SaveToFileUTF8(const filenameUTF8: string; Handler:TFPCustomImageWriter);overload; virtual;
    364399
    365400     {** Save image to a stream with the specified image writer }{inherited
     
    374409
    375410     {** Gets the content of the specified device context }
    376      procedure LoadFromDevice(DC: System.THandle); virtual; abstract; overload;
     411     procedure LoadFromDevice(DC: HDC); overload; virtual; abstract;
    377412     {** Gets the content from the specified rectangular area of a device context }
    378      procedure LoadFromDevice(DC: System.THandle; ARect: TRect); virtual; abstract; overload;
     413     procedure LoadFromDevice(DC: HDC; ARect: TRect); overload; virtual; abstract;
    379414     {** Fills the content with a screenshot of the primary monitor }
    380415     procedure TakeScreenshotOfPrimaryMonitor; virtual; abstract;
     
    385420
    386421     {Pixel functions}
    387      procedure SetPixel(x, y: int32or64; c: TColor); virtual; abstract; overload;
    388      procedure XorPixel(x, y: int32or64; c: TBGRAPixel); virtual; abstract; overload;
    389      procedure SetPixel(x, y: int32or64; c: TBGRAPixel); virtual; abstract; overload;
    390      procedure DrawPixel(x, y: int32or64; c: TBGRAPixel); virtual; abstract; overload;
     422     procedure SetPixel(x, y: int32or64; c: TColor); overload; virtual; abstract;
     423     procedure XorPixel(x, y: int32or64; c: TBGRAPixel); overload; virtual; abstract;
     424     procedure SetPixel(x, y: int32or64; c: TBGRAPixel); overload; virtual; abstract;
     425     procedure DrawPixel(x, y: int32or64; c: TBGRAPixel); overload; virtual; abstract;
    391426     procedure DrawPixel(x, y: int32or64; c: TBGRAPixel; ADrawMode: TDrawMode); overload;
    392      procedure DrawPixel(x, y: int32or64; ec: TExpandedPixel); virtual; abstract; overload;
     427     procedure DrawPixel(x, y: int32or64; ec: TExpandedPixel); overload; virtual; abstract;
    393428     procedure FastBlendPixel(x, y: int32or64; c: TBGRAPixel); virtual; abstract;
    394429     procedure ErasePixel(x, y: int32or64; alpha: byte); virtual; abstract;
    395430     procedure AlphaPixel(x, y: int32or64; alpha: byte); virtual; abstract;
    396      function GetPixel(x, y: int32or64): TBGRAPixel; virtual; abstract; overload;
     431     function GetPixel(x, y: int32or64): TBGRAPixel; overload; virtual; abstract;
    397432     function GetPixel256(x, y, fracX256,fracY256: int32or64; AResampleFilter: TResampleFilter = rfLinear; smoothBorder: boolean = true): TBGRAPixel; virtual; abstract;
    398      function GetPixel(x, y: single; AResampleFilter: TResampleFilter = rfLinear; smoothBorder: boolean = true): TBGRAPixel; virtual; abstract; overload;
    399      function GetPixelCycle(x, y: int32or64): TBGRAPixel; virtual; overload;
    400      function GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; virtual; abstract; overload;
    401      function GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter; repeatX: boolean; repeatY: boolean): TBGRAPixel; virtual; abstract; overload;
    402      function GetPixelCycle256(x, y, fracX256,fracY256: int32or64; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; virtual; abstract; overload;
    403      function GetPixelCycle256(x, y, fracX256,fracY256: int32or64; AResampleFilter: TResampleFilter; repeatX: boolean; repeatY: boolean): TBGRAPixel; virtual; abstract; overload;
     433     function GetPixel(x, y: single; AResampleFilter: TResampleFilter = rfLinear; smoothBorder: boolean = true): TBGRAPixel; overload; virtual; abstract;
     434     function GetPixelCycle(x, y: int32or64): TBGRAPixel;overload; virtual;
     435     function GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; overload; virtual; abstract;
     436     function GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter; repeatX: boolean; repeatY: boolean): TBGRAPixel; overload; virtual; abstract;
     437     function GetPixelCycle256(x, y, fracX256,fracY256: int32or64; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; overload; virtual; abstract;
     438     function GetPixelCycle256(x, y, fracX256,fracY256: int32or64; AResampleFilter: TResampleFilter; repeatX: boolean; repeatY: boolean): TBGRAPixel; overload; virtual; abstract;
    404439
    405440     {Line primitives}
    406441     procedure SetHorizLine(x, y, x2: int32or64; c: TBGRAPixel); virtual; abstract;
    407442     procedure XorHorizLine(x, y, x2: int32or64; c: TBGRAPixel); virtual; abstract;
    408      procedure DrawHorizLine(x, y, x2: int32or64; c: TBGRAPixel); virtual; abstract; overload;
    409      procedure DrawHorizLine(x, y, x2: int32or64; ec: TExpandedPixel); virtual; abstract; overload;
     443     procedure DrawHorizLine(x, y, x2: int32or64; c: TBGRAPixel); overload; virtual; abstract;
     444     procedure DrawHorizLine(x, y, x2: int32or64; ec: TExpandedPixel); overload; virtual; abstract;
    410445     procedure DrawHorizLine(x, y, x2: int32or64; texture: IBGRAScanner); overload;
    411446     procedure FastBlendHorizLine(x, y, x2: int32or64; c: TBGRAPixel); virtual; abstract;
    412447     procedure HorizLine(x,y,x2: Int32or64; c: TBGRAPixel; ADrawMode: TDrawMode); overload;
    413      procedure HorizLine(x,y,x2: Int32or64; texture: IBGRAScanner; ADrawMode: TDrawMode); virtual; abstract; overload;
     448     procedure HorizLine(x,y,x2: Int32or64; texture: IBGRAScanner; ADrawMode: TDrawMode); overload; virtual; abstract;
    414449     procedure DrawHorizLineDiff(x, y, x2: int32or64; c, compare: TBGRAPixel; maxDiff: byte); virtual; abstract;
    415450     procedure AlphaHorizLine(x, y, x2: int32or64; alpha: byte); virtual; abstract;
     
    423458
    424459     {Shapes}
    425      procedure DrawPath(APath: IBGRAPath; AStrokeColor: TBGRAPixel; AWidth: single; AFillColor: TBGRAPixel); virtual; abstract;
    426      procedure DrawPath(APath: IBGRAPath; AStrokeTexture: IBGRAScanner; AWidth: single; AFillColor: TBGRAPixel); virtual; abstract;
    427      procedure DrawPath(APath: IBGRAPath; AStrokeColor: TBGRAPixel; AWidth: single; AFillTexture: IBGRAScanner); virtual; abstract;
    428      procedure DrawPath(APath: IBGRAPath; AStrokeTexture: IBGRAScanner; AWidth: single; AFillTexture: IBGRAScanner); virtual; abstract;
    429      procedure DrawPath(APath: IBGRAPath; AStrokeColor: TBGRAPixel; AWidth: single); virtual; abstract;
    430      procedure DrawPath(APath: IBGRAPath; AStrokeTexture: IBGRAScanner; AWidth: single); virtual; abstract;
    431 
    432      procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeColor: TBGRAPixel; AWidth: single; AFillColor: TBGRAPixel); virtual; abstract;
    433      procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeTexture: IBGRAScanner; AWidth: single; AFillColor: TBGRAPixel); virtual; abstract;
    434      procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeColor: TBGRAPixel; AWidth: single; AFillTexture: IBGRAScanner); virtual; abstract;
    435      procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeTexture: IBGRAScanner; AWidth: single; AFillTexture: IBGRAScanner); virtual; abstract;
    436      procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeColor: TBGRAPixel; AWidth: single); virtual; abstract;
    437      procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeTexture: IBGRAScanner; AWidth: single); virtual; abstract;
     460     procedure DrawPath(APath: IBGRAPath; AStrokeColor: TBGRAPixel; AWidth: single; AFillColor: TBGRAPixel); overload; virtual; abstract;
     461     procedure DrawPath(APath: IBGRAPath; AStrokeTexture: IBGRAScanner; AWidth: single; AFillColor: TBGRAPixel); overload; virtual; abstract;
     462     procedure DrawPath(APath: IBGRAPath; AStrokeColor: TBGRAPixel; AWidth: single; AFillTexture: IBGRAScanner); overload; virtual; abstract;
     463     procedure DrawPath(APath: IBGRAPath; AStrokeTexture: IBGRAScanner; AWidth: single; AFillTexture: IBGRAScanner); overload; virtual; abstract;
     464     procedure DrawPath(APath: IBGRAPath; AStrokeColor: TBGRAPixel; AWidth: single); overload; virtual; abstract;
     465     procedure DrawPath(APath: IBGRAPath; AStrokeTexture: IBGRAScanner; AWidth: single); overload; virtual; abstract;
     466
     467     procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeColor: TBGRAPixel; AWidth: single; AFillColor: TBGRAPixel); overload; virtual; abstract;
     468     procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeTexture: IBGRAScanner; AWidth: single; AFillColor: TBGRAPixel); overload; virtual; abstract;
     469     procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeColor: TBGRAPixel; AWidth: single; AFillTexture: IBGRAScanner); overload; virtual; abstract;
     470     procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeTexture: IBGRAScanner; AWidth: single; AFillTexture: IBGRAScanner); overload; virtual; abstract;
     471     procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeColor: TBGRAPixel; AWidth: single); overload; virtual; abstract;
     472     procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeTexture: IBGRAScanner; AWidth: single); overload; virtual; abstract;
    438473
    439474     procedure ArrowStartAsNone; virtual; abstract;
     
    448483
    449484     procedure DrawLine(x1, y1, x2, y2: integer; c: TBGRAPixel; DrawLastPixel: boolean; ADrawMode: TDrawMode= dmDrawWithTransparency); virtual; abstract;
    450      procedure DrawLineAntialias(x1, y1, x2, y2: integer; c: TBGRAPixel; DrawLastPixel: boolean); virtual; abstract; overload;
    451      procedure DrawLineAntialias(x1, y1, x2, y2: integer; c1, c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean); virtual; abstract; overload;
    452      procedure DrawLineAntialias(x1, y1, x2, y2: integer; c1, c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean; var DashPos: integer); virtual; abstract; overload;
    453      procedure DrawLineAntialias(x1, y1, x2, y2: single; c: TBGRAPixel; w: single); virtual; abstract; overload;
    454      procedure DrawLineAntialias(x1, y1, x2, y2: single; texture: IBGRAScanner; w: single); virtual; abstract; overload;
    455      procedure DrawLineAntialias(x1, y1, x2, y2: single; c: TBGRAPixel; w: single; ClosedCap: boolean); virtual; abstract; overload;
    456      procedure DrawLineAntialias(x1, y1, x2, y2: single; texture: IBGRAScanner; w: single; ClosedCap: boolean); virtual; abstract; overload;
     485     procedure DrawLineAntialias(x1, y1, x2, y2: integer; c: TBGRAPixel; DrawLastPixel: boolean); overload; virtual; abstract;
     486     procedure DrawLineAntialias(x1, y1, x2, y2: integer; c1, c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean); overload; virtual; abstract;
     487     procedure DrawLineAntialias(x1, y1, x2, y2: integer; c1, c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean; var DashPos: integer); overload; virtual; abstract;
     488     procedure DrawLineAntialias(x1, y1, x2, y2: single; c: TBGRAPixel; w: single); overload; virtual; abstract;
     489     procedure DrawLineAntialias(x1, y1, x2, y2: single; texture: IBGRAScanner; w: single); overload; virtual; abstract;
     490     procedure DrawLineAntialias(x1, y1, x2, y2: single; c: TBGRAPixel; w: single; ClosedCap: boolean); overload; virtual; abstract;
     491     procedure DrawLineAntialias(x1, y1, x2, y2: single; texture: IBGRAScanner; w: single; ClosedCap: boolean); overload; virtual; abstract;
    457492
    458493     procedure DrawPolyLine(const points: array of TPoint; c: TBGRAPixel; DrawLastPixel: boolean; ADrawMode: TDrawMode=dmDrawWithTransparency);
    459      procedure DrawPolyLineAntialias(const points: array of TPoint; c: TBGRAPixel; DrawLastPixel: boolean); virtual; overload;
    460      procedure DrawPolyLineAntialias(const points: array of TPoint; c1, c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean); virtual; overload;
    461      procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single); virtual; abstract; overload;
    462      procedure DrawPolyLineAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single); virtual; abstract; overload;
    463      procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single; ClosedCap: boolean); virtual; abstract; overload;
    464      procedure DrawPolyLineAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single; ClosedCap: boolean); virtual; abstract; overload;
    465      procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single; fillcolor: TBGRAPixel); virtual; abstract; overload;
    466      procedure DrawPolyLineAntialiasAutocycle(const points: array of TPointF; c: TBGRAPixel; w: single); virtual; abstract; overload;
    467      procedure DrawPolyLineAntialiasAutocycle(const points: array of TPointF; texture: IBGRAScanner; w: single); virtual; abstract; overload;
     494     procedure DrawPolyLineAntialias(const points: array of TPoint; c: TBGRAPixel; DrawLastPixel: boolean);overload; virtual;
     495     procedure DrawPolyLineAntialias(const points: array of TPoint; c1, c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean);overload; virtual;
     496     procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single); overload; virtual; abstract;
     497     procedure DrawPolyLineAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single); overload; virtual; abstract;
     498     procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single; ClosedCap: boolean); overload; virtual; abstract;
     499     procedure DrawPolyLineAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single; ClosedCap: boolean); overload; virtual; abstract;
     500     procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single; fillcolor: TBGRAPixel); overload; virtual; abstract;
     501     procedure DrawPolyLineAntialiasAutocycle(const points: array of TPointF; c: TBGRAPixel; w: single); overload; virtual; abstract;
     502     procedure DrawPolyLineAntialiasAutocycle(const points: array of TPointF; texture: IBGRAScanner; w: single); overload; virtual; abstract;
    468503     procedure DrawPolygon(const points: array of TPoint; c: TBGRAPixel; ADrawMode: TDrawMode=dmDrawWithTransparency);
    469504     procedure DrawPolygonAntialias(const points: array of TPoint; c: TBGRAPixel); overload;
    470      procedure DrawPolygonAntialias(const points: array of TPointF; c: TBGRAPixel; w: single); virtual; abstract; overload;
    471      procedure DrawPolygonAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single); virtual; abstract; overload;
    472      procedure DrawPolygonAntialias(const points: array of TPointF; c: TBGRAPixel; w: single; fillcolor: TBGRAPixel); virtual; abstract; overload;
     505     procedure DrawPolygonAntialias(const points: array of TPoint; c1, c2: TBGRAPixel; dashLen: integer); overload;
     506     procedure DrawPolygonAntialias(const points: array of TPointF; c: TBGRAPixel; w: single); overload; virtual; abstract;
     507     procedure DrawPolygonAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single); overload; virtual; abstract;
     508     procedure DrawPolygonAntialias(const points: array of TPointF; c: TBGRAPixel; w: single; fillcolor: TBGRAPixel); overload; virtual; abstract;
    473509
    474510     procedure EraseLine(x1, y1, x2, y2: integer; alpha: byte; DrawLastPixel: boolean); virtual; abstract;
    475      procedure EraseLineAntialias(x1, y1, x2, y2: integer; alpha: byte; DrawLastPixel: boolean); virtual; abstract; overload;
    476      procedure EraseLineAntialias(x1, y1, x2, y2: single; alpha: byte; w: single); virtual; abstract; overload;
    477      procedure EraseLineAntialias(x1, y1, x2, y2: single; alpha: byte; w: single; Closed: boolean); virtual; abstract; overload;
     511     procedure EraseLineAntialias(x1, y1, x2, y2: integer; alpha: byte; DrawLastPixel: boolean); overload; virtual; abstract;
     512     procedure EraseLineAntialias(x1, y1, x2, y2: single; alpha: byte; w: single); overload; virtual; abstract;
     513     procedure EraseLineAntialias(x1, y1, x2, y2: single; alpha: byte; w: single; Closed: boolean); overload; virtual; abstract;
    478514     procedure ErasePolyLine(const points: array of TPoint; alpha: byte; DrawLastPixel: boolean);
    479515     procedure ErasePolyLineAntialias(const points: array of TPoint; alpha: byte; DrawLastPixel: boolean); overload;
    480      procedure ErasePolyLineAntialias(const points: array of TPointF; alpha: byte; w: single); virtual; abstract; overload;
     516     procedure ErasePolyLineAntialias(const points: array of TPointF; alpha: byte; w: single); overload; virtual; abstract;
    481517     procedure ErasePolygonOutline(const points: array of TPoint; alpha: byte);
    482518     procedure ErasePolygonOutlineAntialias(const points: array of TPoint; alpha: byte);
    483519
    484      procedure FillPath(APath: IBGRAPath; c: TBGRAPixel); virtual; abstract;
    485      procedure FillPath(APath: IBGRAPath; texture: IBGRAScanner); virtual; abstract;
    486      procedure ErasePath(APath: IBGRAPath; alpha: byte); virtual; abstract;
    487 
    488      procedure FillPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AFillColor: TBGRAPixel); virtual; abstract;
    489      procedure FillPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AFillTexture: IBGRAScanner); virtual; abstract;
    490      procedure ErasePath(APath: IBGRAPath; AMatrix: TAffineMatrix; alpha: byte); virtual; abstract;
    491 
    492      procedure FillTriangleLinearColor(pt1,pt2,pt3: TPointF; c1,c2,c3: TBGRAPixel); virtual; abstract; overload;
    493      procedure FillTriangleLinearColorAntialias(pt1,pt2,pt3: TPointF; c1,c2,c3: TBGRAPixel); virtual; abstract; overload;
    494      procedure FillTriangleLinearMapping(pt1,pt2,pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF; TextureInterpolation: Boolean= True); virtual; abstract; overload;
    495      procedure FillTriangleLinearMappingLightness(pt1,pt2,pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF; light1,light2,light3: word; TextureInterpolation: Boolean= True); virtual; abstract; overload;
    496      procedure FillTriangleLinearMappingAntialias(pt1,pt2,pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF); virtual; abstract; overload;
    497 
    498      procedure FillQuadLinearColor(pt1,pt2,pt3,pt4: TPointF; c1,c2,c3,c4: TBGRAPixel); virtual; abstract; overload;
    499      procedure FillQuadLinearColorAntialias(pt1,pt2,pt3,pt4: TPointF; c1,c2,c3,c4: TBGRAPixel); virtual; abstract; overload;
    500      procedure FillQuadLinearMapping(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; TextureInterpolation: Boolean= True; ACulling: TFaceCulling = fcNone);  virtual; abstract; overload;
    501      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;
    502      procedure FillQuadLinearMappingAntialias(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; ACulling: TFaceCulling = fcNone); virtual; abstract; overload;
    503      procedure FillQuadPerspectiveMapping(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; ADrawMode: TDrawMode = dmDrawWithTransparency); virtual; abstract; overload;
    504      procedure FillQuadPerspectiveMapping(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; ACleanBorders: TRect; ADrawMode: TDrawMode = dmDrawWithTransparency); virtual; abstract; overload;
    505      procedure FillQuadPerspectiveMappingAntialias(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF); virtual; abstract; overload;
    506      procedure FillQuadPerspectiveMappingAntialias(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; ACleanBorders: TRect); virtual; abstract; overload;
     520     procedure FillPath(APath: IBGRAPath; c: TBGRAPixel); overload; virtual; abstract;
     521     procedure FillPath(APath: IBGRAPath; texture: IBGRAScanner); overload; virtual; abstract;
     522     procedure ErasePath(APath: IBGRAPath; alpha: byte); overload; virtual; abstract;
     523
     524     procedure FillPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AFillColor: TBGRAPixel); overload; virtual; abstract;
     525     procedure FillPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AFillTexture: IBGRAScanner); overload; virtual; abstract;
     526     procedure ErasePath(APath: IBGRAPath; AMatrix: TAffineMatrix; alpha: byte); overload; virtual; abstract;
     527
     528     procedure FillTriangleLinearColor(pt1,pt2,pt3: TPointF; c1,c2,c3: TBGRAPixel); overload; virtual; abstract;
     529     procedure FillTriangleLinearColorAntialias(pt1,pt2,pt3: TPointF; c1,c2,c3: TBGRAPixel); overload; virtual; abstract;
     530     procedure FillTriangleLinearMapping(pt1,pt2,pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF; TextureInterpolation: Boolean= True); overload; virtual; abstract;
     531     procedure FillTriangleLinearMappingLightness(pt1,pt2,pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF; light1,light2,light3: word; TextureInterpolation: Boolean= True); overload; virtual; abstract;
     532     procedure FillTriangleLinearMappingAntialias(pt1,pt2,pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF); overload; virtual; abstract;
     533
     534     procedure FillQuadLinearColor(pt1,pt2,pt3,pt4: TPointF; c1,c2,c3,c4: TBGRAPixel); overload; virtual; abstract;
     535     procedure FillQuadLinearColorAntialias(pt1,pt2,pt3,pt4: TPointF; c1,c2,c3,c4: TBGRAPixel); overload; virtual; abstract;
     536     procedure FillQuadLinearMapping(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; TextureInterpolation: Boolean= True; ACulling: TFaceCulling = fcNone); overload; virtual; abstract;
     537     procedure FillQuadLinearMappingLightness(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; light1,light2,light3,light4: word; TextureInterpolation: Boolean= True); overload; virtual; abstract;
     538     procedure FillQuadLinearMappingAntialias(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; ACulling: TFaceCulling = fcNone); overload; virtual; abstract;
     539     procedure FillQuadPerspectiveMapping(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; ADrawMode: TDrawMode = dmDrawWithTransparency); overload; virtual; abstract;
     540     procedure FillQuadPerspectiveMapping(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; ACleanBorders: TRect; ADrawMode: TDrawMode = dmDrawWithTransparency); overload; virtual; abstract;
     541     procedure FillQuadPerspectiveMappingAntialias(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF); overload; virtual; abstract;
     542     procedure FillQuadPerspectiveMappingAntialias(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; ACleanBorders: TRect); overload; virtual; abstract;
    507543     procedure FillQuadAffineMapping(Orig,HAxis,VAxis: TPointF; AImage: TBGRACustomBitmap; APixelCenteredCoordinates: boolean = true; ADrawMode: TDrawMode = dmDrawWithTransparency; AOpacity: byte = 255); virtual; abstract;
    508544     procedure FillQuadAffineMappingAntialias(Orig,HAxis,VAxis: TPointF; AImage: TBGRACustomBitmap; APixelCenteredCoordinates: boolean = true; AOpacity: byte = 255); virtual; abstract;
    509545
    510      procedure FillPolyLinearColor(const points: array of TPointF; AColors: array of TBGRAPixel);  virtual; abstract; overload;
    511      procedure FillPolyLinearMapping(const points: array of TPointF; texture: IBGRAScanner; texCoords: array of TPointF; TextureInterpolation: Boolean); virtual; abstract; overload;
    512      procedure FillPolyLinearMappingLightness(const points: array of TPointF; texture: IBGRAScanner; texCoords: array of TPointF; lightnesses: array of word; TextureInterpolation: Boolean); virtual; abstract; overload;
    513      procedure FillPolyPerspectiveMapping(const points: array of TPointF; const pointsZ: array of single; texture: IBGRAScanner; texCoords: array of TPointF; TextureInterpolation: Boolean; zbuffer: psingle = nil); virtual; abstract; overload;
    514      procedure FillPolyPerspectiveMappingLightness(const points: array of TPointF; const pointsZ: array of single; texture: IBGRAScanner; texCoords: array of TPointF; lightnesses: array of word; TextureInterpolation: Boolean; zbuffer: psingle = nil); virtual; abstract; overload;
    515 
    516      procedure FillPoly(const points: array of TPointF; c: TBGRAPixel; drawmode: TDrawMode); virtual; abstract;
    517      procedure FillPoly(const points: array of TPointF; texture: IBGRAScanner; drawmode: TDrawMode); virtual; abstract;
    518      procedure FillPolyAntialias(const points: array of TPointF; c: TBGRAPixel); virtual; abstract;
    519      procedure FillPolyAntialias(const points: array of TPointF; texture: IBGRAScanner); virtual; abstract;
    520      procedure ErasePoly(const points: array of TPointF; alpha: byte); virtual; abstract;
    521      procedure ErasePolyAntialias(const points: array of TPointF; alpha: byte); virtual; abstract;
    522 
    523      procedure FillShape(shape: TBGRACustomFillInfo; c: TBGRAPixel; drawmode: TDrawMode); virtual; abstract;
    524      procedure FillShape(shape: TBGRACustomFillInfo; texture: IBGRAScanner; drawmode: TDrawMode); virtual; abstract;
    525      procedure FillShapeAntialias(shape: TBGRACustomFillInfo; c: TBGRAPixel); virtual; abstract;
    526      procedure FillShapeAntialias(shape: TBGRACustomFillInfo; texture: IBGRAScanner); virtual; abstract;
    527      procedure EraseShape(shape: TBGRACustomFillInfo; alpha: byte); virtual; abstract;
     546     procedure FillPolyLinearColor(const points: array of TPointF; AColors: array of TBGRAPixel);  overload; virtual; abstract;
     547     procedure FillPolyLinearMapping(const points: array of TPointF; texture: IBGRAScanner; texCoords: array of TPointF; TextureInterpolation: Boolean); overload; virtual; abstract;
     548     procedure FillPolyLinearMappingLightness(const points: array of TPointF; texture: IBGRAScanner; texCoords: array of TPointF; lightnesses: array of word; TextureInterpolation: Boolean); overload; virtual; abstract;
     549     procedure FillPolyPerspectiveMapping(const points: array of TPointF; const pointsZ: array of single; texture: IBGRAScanner; texCoords: array of TPointF; TextureInterpolation: Boolean; zbuffer: psingle = nil); overload; virtual; abstract;
     550     procedure FillPolyPerspectiveMappingLightness(const points: array of TPointF; const pointsZ: array of single; texture: IBGRAScanner; texCoords: array of TPointF; lightnesses: array of word; TextureInterpolation: Boolean; zbuffer: psingle = nil); overload; virtual; abstract;
     551
     552     procedure FillPoly(const points: array of TPointF; c: TBGRAPixel; drawmode: TDrawMode; APixelCenteredCoordinates: boolean = true); overload; virtual; abstract;
     553     procedure FillPoly(const points: array of TPointF; texture: IBGRAScanner; drawmode: TDrawMode; APixelCenteredCoordinates: boolean = true); overload; virtual; abstract;
     554     procedure FillPolyAntialias(const points: array of TPointF; c: TBGRAPixel; APixelCenteredCoordinates: boolean = true); overload; virtual; abstract;
     555     procedure FillPolyAntialias(const points: array of TPointF; texture: IBGRAScanner; APixelCenteredCoordinates: boolean = true); overload; virtual; abstract;
     556     procedure ErasePoly(const points: array of TPointF; alpha: byte; APixelCenteredCoordinates: boolean = true); virtual; abstract;
     557     procedure ErasePolyAntialias(const points: array of TPointF; alpha: byte; APixelCenteredCoordinates: boolean = true); virtual; abstract;
     558
     559     procedure FillShape(shape: TBGRACustomFillInfo; c: TBGRAPixel; drawmode: TDrawMode); overload; virtual; abstract;
     560     procedure FillShape(shape: TBGRACustomFillInfo; texture: IBGRAScanner; drawmode: TDrawMode); overload; virtual; abstract;
     561     procedure FillShapeAntialias(shape: TBGRACustomFillInfo; c: TBGRAPixel); overload; virtual; abstract;
     562     procedure FillShapeAntialias(shape: TBGRACustomFillInfo; texture: IBGRAScanner); overload; virtual; abstract;
     563     procedure EraseShape(shape: TBGRACustomFillInfo; alpha: byte); overload; virtual; abstract;
    528564     procedure EraseShapeAntialias(shape: TBGRACustomFillInfo; alpha: byte); virtual; abstract;
    529565
    530      procedure EllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel; w: single); virtual; abstract;
    531      procedure EllipseAntialias(x, y, rx, ry: single; texture: IBGRAScanner; w: single); virtual; abstract;
    532      procedure EllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel; w: single; back: TBGRAPixel); virtual; abstract;
    533      procedure FillEllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel); virtual; abstract;
    534      procedure FillEllipseAntialias(x, y, rx, ry: single; texture: IBGRAScanner); virtual; abstract;
    535      procedure FillEllipseLinearColorAntialias(x, y, rx, ry: single; outercolor, innercolor: TBGRAPixel); virtual; abstract;
    536      procedure EraseEllipseAntialias(x, y, rx, ry: single; alpha: byte); virtual; abstract;
     566     procedure Ellipse(x, y, rx, ry: single; c: TBGRAPixel; w: single; ADrawMode: TDrawMode); overload; virtual; abstract;
     567     procedure Ellipse(AOrigin, AXAxis, AYAxis: TPointF; c: TBGRAPixel; w: single; ADrawMode: TDrawMode); overload; virtual; abstract;
     568     procedure EllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel; w: single); overload; virtual; abstract;
     569     procedure EllipseAntialias(AOrigin, AXAxis, AYAxis: TPointF; c: TBGRAPixel; w: single); overload; virtual; abstract;
     570     procedure EllipseAntialias(x, y, rx, ry: single; texture: IBGRAScanner; w: single); overload; virtual; abstract;
     571     procedure EllipseAntialias(AOrigin, AXAxis, AYAxis: TPointF; texture: IBGRAScanner; w: single); overload; virtual; abstract;
     572     procedure EllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel; w: single; back: TBGRAPixel); overload; virtual; abstract;
     573     procedure EllipseAntialias(AOrigin, AXAxis, AYAxis: TPointF; c: TBGRAPixel; w: single; back: TBGRAPixel); overload; virtual; abstract;
     574     procedure FillEllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel); overload; virtual; abstract;
     575     procedure FillEllipseAntialias(AOrigin, AXAxis, AYAxis: TPointF; c: TBGRAPixel); overload; virtual; abstract;
     576     procedure FillEllipseAntialias(x, y, rx, ry: single; texture: IBGRAScanner); overload; virtual; abstract;
     577     procedure FillEllipseAntialias(AOrigin, AXAxis, AYAxis: TPointF; texture: IBGRAScanner); overload; virtual; abstract;
     578     procedure FillEllipseLinearColorAntialias(x, y, rx, ry: single; outercolor, innercolor: TBGRAPixel); overload; virtual; abstract;
     579     procedure FillEllipseLinearColorAntialias(AOrigin, AXAxis, AYAxis: TPointF; outercolor, innercolor: TBGRAPixel); overload; virtual; abstract;
     580     procedure EraseEllipseAntialias(x, y, rx, ry: single; alpha: byte); overload; virtual; abstract;
     581     procedure EraseEllipseAntialias(AOrigin, AXAxis, AYAxis: TPointF; alpha: byte); overload; virtual; abstract;
    537582
    538583     procedure Arc(cx,cy,rx,ry: single; const StartPoint,EndPoint: TPointF; AColor: TBGRAPixel; w: single; ADrawChord: boolean; AFillColor: TBGRAPixel); overload;
     
    554599     procedure FillPieInRect(const ARect: TRect; StartAngleRad,EndAngleRad: Single; texture: IBGRAScanner); overload;
    555600
    556      procedure Rectangle(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); virtual; abstract; overload;
    557      procedure Rectangle(x, y, x2, y2: integer; BorderColor, FillColor: TBGRAPixel; mode: TDrawMode); virtual; abstract; overload;
    558      procedure Rectangle(x, y, x2, y2: integer; c: TColor); virtual; overload;
    559      procedure Rectangle(r: TRect; c: TBGRAPixel; mode: TDrawMode); virtual; overload;
    560      procedure Rectangle(r: TRect; BorderColor, FillColor: TBGRAPixel; mode: TDrawMode); virtual;overload;
    561      procedure Rectangle(r: TRect; c: TColor); virtual; overload;
    562      procedure RectangleAntialias(x, y, x2, y2: single; c: TBGRAPixel; w: single); virtual; overload;
    563      procedure RectangleAntialias(x, y, x2, y2: single; c: TBGRAPixel; w: single; back: TBGRAPixel); virtual; abstract; overload;
    564      procedure RectangleAntialias(x, y, x2, y2: single; texture: IBGRAScanner; w: single); virtual; abstract; overload;
     601     procedure Rectangle(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); overload; virtual; abstract;
     602     procedure Rectangle(x, y, x2, y2: integer; BorderColor, FillColor: TBGRAPixel; mode: TDrawMode); overload; virtual; abstract;
     603     procedure Rectangle(x, y, x2, y2: integer; c: TColor); overload; virtual;
     604     procedure Rectangle(r: TRect; c: TBGRAPixel; mode: TDrawMode); overload; virtual;
     605     procedure Rectangle(r: TRect; BorderColor, FillColor: TBGRAPixel; mode: TDrawMode); overload; virtual;
     606     procedure Rectangle(r: TRect; c: TColor); overload; virtual;
     607     procedure RectangleAntialias(x, y, x2, y2: single; c: TBGRAPixel; w: single); overload; virtual;
     608     procedure RectangleAntialias(x, y, x2, y2: single; c: TBGRAPixel; w: single; back: TBGRAPixel); overload; virtual; abstract;
     609     procedure RectangleAntialias(x, y, x2, y2: single; texture: IBGRAScanner; w: single); overload; virtual; abstract;
    565610     procedure RectangleWithin(x1,y1,x2,y2: single; ABorderColor: TBGRAPixel; w: single; AFillColor: TBGRAPixel; APixelCenteredCoordinates: boolean = true); overload;
    566611     procedure RectangleWithin(r: TRect; ABorderColor: TBGRAPixel; w: single; AFillColor: TBGRAPixel); overload;
    567612
    568      procedure RoundRect(X1, Y1, X2, Y2: integer; DX, DY: integer; BorderColor, FillColor: TBGRAPixel; ADrawMode: TDrawMode = dmDrawWithTransparency); virtual; abstract; overload;
    569      procedure RoundRect(X1, Y1, X2, Y2: integer; DX, DY: integer; BorderColor: TBGRAPixel; ADrawMode: TDrawMode = dmDrawWithTransparency); virtual; abstract; overload;
    570      procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; c: TBGRAPixel; w: single; options: TRoundRectangleOptions = []); virtual; abstract;
    571      procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; pencolor: TBGRAPixel; w: single; fillcolor: TBGRAPixel; options: TRoundRectangleOptions = []); virtual; abstract;
    572      procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; penTexture: IBGRAScanner; w: single; fillTexture: IBGRAScanner; options: TRoundRectangleOptions = []); virtual; abstract;
    573      procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; texture: IBGRAScanner; w: single; options: TRoundRectangleOptions = []); virtual; abstract;
    574      procedure FillRoundRect(X1, Y1, X2, Y2: integer; DX, DY: integer; FillColor: TBGRAPixel; ADrawMode: TDrawMode = dmDrawWithTransparency); virtual;
    575      procedure FillRoundRectAntialias(x,y,x2,y2,rx,ry: single; c: TBGRAPixel; options: TRoundRectangleOptions = []; pixelCenteredCoordinates: boolean = true); virtual; abstract;
    576      procedure FillRoundRectAntialias(x,y,x2,y2,rx,ry: single; texture: IBGRAScanner; options: TRoundRectangleOptions = []; pixelCenteredCoordinates: boolean = true); virtual; abstract;
     613     procedure RoundRect(X1, Y1, X2, Y2: integer; DX, DY: integer; BorderColor, FillColor: TBGRAPixel; ADrawMode: TDrawMode = dmDrawWithTransparency); overload; virtual; abstract;
     614     procedure RoundRect(X1, Y1, X2, Y2: integer; DX, DY: integer; BorderColor: TBGRAPixel; ADrawMode: TDrawMode = dmDrawWithTransparency); overload; virtual; abstract;
     615     procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; c: TBGRAPixel; w: single; options: TRoundRectangleOptions = []); overload; virtual; abstract;
     616     procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; pencolor: TBGRAPixel; w: single; fillcolor: TBGRAPixel; options: TRoundRectangleOptions = []); overload; virtual; abstract;
     617     procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; penTexture: IBGRAScanner; w: single; fillTexture: IBGRAScanner; options: TRoundRectangleOptions = []); overload; virtual; abstract;
     618     procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; texture: IBGRAScanner; w: single; options: TRoundRectangleOptions = []); overload; virtual; abstract;
     619     procedure FillRoundRect(X1, Y1, X2, Y2: integer; DX, DY: integer; FillColor: TBGRAPixel; ADrawMode: TDrawMode = dmDrawWithTransparency); overload; virtual;
     620     procedure FillRoundRect(X1, Y1, X2, Y2: integer; DX, DY: integer; FillTexture: IBGRAScanner; ADrawMode: TDrawMode = dmDrawWithTransparency); overload; virtual; abstract;
     621     procedure FillRoundRectAntialias(x,y,x2,y2,rx,ry: single; c: TBGRAPixel; options: TRoundRectangleOptions = []; pixelCenteredCoordinates: boolean = true); overload; virtual; abstract;
     622     procedure FillRoundRectAntialias(x,y,x2,y2,rx,ry: single; texture: IBGRAScanner; options: TRoundRectangleOptions = []; pixelCenteredCoordinates: boolean = true); overload; virtual; abstract;
    577623     procedure EraseRoundRectAntialias(x,y,x2,y2,rx,ry: single; alpha: byte; options: TRoundRectangleOptions = []; pixelCenteredCoordinates: boolean = true); virtual; abstract;
    578624
    579      procedure EllipseInRect(r: TRect; BorderColor: TBGRAPixel; ADrawMode: TDrawMode = dmDrawWithTransparency); virtual; overload;
    580      procedure EllipseInRect(r: TRect; BorderColor,FillColor: TBGRAPixel; ADrawMode: TDrawMode = dmDrawWithTransparency); virtual; overload;
    581      procedure FillEllipseInRect(r: TRect; FillColor: TBGRAPixel; ADrawMode: TDrawMode = dmDrawWithTransparency); virtual;
    582 
    583      procedure FillRect(r: TRect; c: TColor); virtual; overload;
    584      procedure FillRect(r: TRect; c: TBGRAPixel; mode: TDrawMode); virtual; overload;
    585      procedure FillRect(r: TRect; texture: IBGRAScanner; mode: TDrawMode); virtual; overload;
    586      procedure FillRect(r: TRect; texture: IBGRAScanner; mode: TDrawMode; AScanOffset: TPoint); virtual; overload;
    587      procedure FillRect(r: TRect; texture: IBGRAScanner; mode: TDrawMode; ditheringAlgorithm: TDitheringAlgorithm); virtual; overload;
    588      procedure FillRect(r: TRect; texture: IBGRAScanner; mode: TDrawMode; AScanOffset: TPoint; ditheringAlgorithm: TDitheringAlgorithm); virtual; overload;
    589      procedure FillRect(x, y, x2, y2: integer; c: TColor); virtual; overload;
    590      procedure FillRect(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); virtual; abstract; overload;
    591      procedure FillRect(x, y, x2, y2: integer; texture: IBGRAScanner; mode: TDrawMode); virtual; overload;
    592      procedure FillRect(x, y, x2, y2: integer; texture: IBGRAScanner; mode: TDrawMode; AScanOffset: TPoint); virtual; abstract; overload;
    593      procedure FillRect(x, y, x2, y2: integer; texture: IBGRAScanner; mode: TDrawMode; ditheringAlgorithm: TDitheringAlgorithm); virtual; overload;
    594      procedure FillRect(x, y, x2, y2: integer; texture: IBGRAScanner; mode: TDrawMode; AScanOffset: TPoint; ditheringAlgorithm: TDitheringAlgorithm); virtual; abstract; overload;
    595      procedure FillRectAntialias(x, y, x2, y2: single; c: TBGRAPixel; pixelCenteredCoordinates: boolean = true); virtual; abstract;
    596      procedure FillRectAntialias(x, y, x2, y2: single; texture: IBGRAScanner; pixelCenteredCoordinates: boolean = true); virtual; abstract;
     625     procedure EllipseInRect(r: TRect; BorderColor: TBGRAPixel; ADrawMode: TDrawMode = dmDrawWithTransparency); overload; virtual;
     626     procedure EllipseInRect(r: TRect; BorderColor,FillColor: TBGRAPixel; ADrawMode: TDrawMode = dmDrawWithTransparency); overload; virtual;
     627     procedure FillEllipseInRect(r: TRect; FillColor: TBGRAPixel; ADrawMode: TDrawMode = dmDrawWithTransparency); overload; virtual;
     628     procedure FillEllipseInRect(r: TRect; FillTexture: IBGRAScanner; ADrawMode: TDrawMode = dmDrawWithTransparency); overload; virtual;
     629
     630     procedure FillRect(r: TRect; c: TColor); overload; virtual;
     631     procedure FillRect(r: TRect; c: TBGRAPixel; mode: TDrawMode); overload; virtual;
     632     procedure FillRect(r: TRect; texture: IBGRAScanner; mode: TDrawMode); overload; virtual;
     633     procedure FillRect(r: TRect; texture: IBGRAScanner; mode: TDrawMode; AScanOffset: TPoint); overload; virtual;
     634     procedure FillRect(r: TRect; texture: IBGRAScanner; mode: TDrawMode; ditheringAlgorithm: TDitheringAlgorithm); overload; virtual;
     635     procedure FillRect(r: TRect; texture: IBGRAScanner; mode: TDrawMode; AScanOffset: TPoint; ditheringAlgorithm: TDitheringAlgorithm); overload; virtual;
     636     procedure FillRect(x, y, x2, y2: integer; c: TColor); overload; virtual;
     637     procedure FillRect(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); overload; virtual; abstract;
     638     procedure FillRect(x, y, x2, y2: integer; texture: IBGRAScanner; mode: TDrawMode); overload; virtual;
     639     procedure FillRect(x, y, x2, y2: integer; texture: IBGRAScanner; mode: TDrawMode; AScanOffset: TPoint); overload; virtual; abstract;
     640     procedure FillRect(x, y, x2, y2: integer; texture: IBGRAScanner; mode: TDrawMode; ditheringAlgorithm: TDitheringAlgorithm); overload; virtual;
     641     procedure FillRect(x, y, x2, y2: integer; texture: IBGRAScanner; mode: TDrawMode; AScanOffset: TPoint; ditheringAlgorithm: TDitheringAlgorithm); overload; virtual; abstract;
     642     procedure FillRectAntialias(x, y, x2, y2: single; c: TBGRAPixel; pixelCenteredCoordinates: boolean = true); overload; virtual; abstract;
     643     procedure FillRectAntialias(x, y, x2, y2: single; texture: IBGRAScanner; pixelCenteredCoordinates: boolean = true); overload; virtual; abstract;
     644     procedure FillRectAntialias(ARect: TRectF; c: TBGRAPixel; pixelCenteredCoordinates: boolean = true); overload;
     645     procedure FillRectAntialias(ARect: TRectF; texture: IBGRAScanner; pixelCenteredCoordinates: boolean = true); overload;
    597646     procedure EraseRectAntialias(x, y, x2, y2: single; alpha: byte; pixelCenteredCoordinates: boolean = true); virtual; abstract;
    598647     procedure AlphaFillRect(x, y, x2, y2: integer; alpha: byte); virtual; abstract;
    599648
    600      procedure TextOut(x, y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment); virtual; abstract; overload;
    601      procedure TextOut(x, y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment); virtual; abstract; overload;
    602      procedure TextOutCurved(ACursor: TBGRACustomPathCursor; sUTF8: string; AColor: TBGRAPixel; AAlign: TAlignment; ALetterSpacing: single); virtual; abstract; overload;
    603      procedure TextOutCurved(ACursor: TBGRACustomPathCursor; sUTF8: string; ATexture: IBGRAScanner; AAlign: TAlignment; ALetterSpacing: single); virtual; abstract; overload;
    604      procedure TextOutCurved(APath: IBGRAPath; sUTF8: string; AColor: TBGRAPixel; AAlign: TAlignment; ALetterSpacing: single); virtual; overload;
    605      procedure TextOutCurved(APath: IBGRAPath; sUTF8: string; ATexture: IBGRAScanner; AAlign: TAlignment; ALetterSpacing: single); virtual; overload;
    606      procedure TextOutAngle(x, y: single; orientationTenthDegCCW: integer; sUTF8: string; c: TBGRAPixel; align: TAlignment); virtual; abstract;
    607      procedure TextOutAngle(x, y: single; orientationTenthDegCCW: integer; sUTF8: string; texture: IBGRAScanner; align: TAlignment); virtual; abstract;
    608      procedure TextRect(ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; c: TBGRAPixel); virtual; abstract; overload;
    609      procedure TextRect(ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; texture: IBGRAScanner); virtual; abstract; overload;
    610      function TextSize(sUTF8: string): TSize; virtual; abstract;
     649     procedure TextOut(x, y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment; ARightToLeft: boolean); overload; virtual; abstract;
     650     procedure TextOut(x, y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment; ARightToLeft: boolean); overload; virtual; abstract;
     651     procedure TextOutCurved(ACursor: TBGRACustomPathCursor; sUTF8: string; AColor: TBGRAPixel; AAlign: TAlignment; ALetterSpacing: single); overload; virtual; abstract;
     652     procedure TextOutCurved(ACursor: TBGRACustomPathCursor; sUTF8: string; ATexture: IBGRAScanner; AAlign: TAlignment; ALetterSpacing: single); overload; virtual; abstract;
     653     procedure TextOutCurved(APath: IBGRAPath; sUTF8: string; AColor: TBGRAPixel; AAlign: TAlignment; ALetterSpacing: single); overload; virtual;
     654     procedure TextOutCurved(APath: IBGRAPath; sUTF8: string; ATexture: IBGRAScanner; AAlign: TAlignment; ALetterSpacing: single); overload; virtual;
     655     procedure TextOutAngle(x, y: single; orientationTenthDegCCW: integer; sUTF8: string; c: TBGRAPixel; align: TAlignment); overload; virtual; abstract;
     656     procedure TextOutAngle(x, y: single; orientationTenthDegCCW: integer; sUTF8: string; texture: IBGRAScanner; align: TAlignment); overload; virtual; abstract;
     657     procedure TextRect(ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; c: TBGRAPixel); overload; virtual; abstract;
     658     procedure TextRect(ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; texture: IBGRAScanner); overload; virtual; abstract;
     659     procedure TextMultiline(x,y: single; sUTF8: string; c: TBGRAPixel; AAlign: TBidiTextAlignment = btaLeftJustify; AVertAlign: TTextLayout = tlTop; AParagraphSpacing: single = 0); overload;
     660     procedure TextMultiline(x,y: single; sUTF8: string; ATexture: IBGRAScanner; AAlign: TBidiTextAlignment = btaLeftJustify; AVertAlign: TTextLayout = tlTop; AParagraphSpacing: single = 0); overload;
     661     procedure TextMultiline(ALeft,ATop,AWidth: single; sUTF8: string; c: TBGRAPixel; AAlign: TBidiTextAlignment = btaNatural; AVertAlign: TTextLayout = tlTop; AParagraphSpacing: single = 0); overload; virtual; abstract;
     662     procedure TextMultiline(ALeft,ATop,AWidth: single; sUTF8: string; ATexture: IBGRAScanner; AAlign: TBidiTextAlignment = btaNatural; AVertAlign: TTextLayout = tlTop; AParagraphSpacing: single = 0); overload; virtual; abstract;
     663     function TextSize(sUTF8: string): TSize; overload; virtual; abstract;
     664     function TextAffineBox(sUTF8: string): TAffineBox; virtual; abstract;
     665     function TextSize(sUTF8: string; AMaxWidth: integer): TSize; overload; virtual; abstract;
     666     function TextSize(sUTF8: string; AMaxWidth: integer; ARightToLeft: boolean): TSize; overload; virtual; abstract;
     667     function TextFitInfo(sUTF8: string; AMaxWidth: integer): integer; virtual; abstract;
    611668
    612669     { Draw the UTF8 encoded string, (x,y) being the top-left corner. The color c or texture is used to fill the text.
    613670       The value of FontOrientation is taken into account, so that the text may be rotated. }
    614      procedure TextOut(x, y: single; sUTF8: string; c: TBGRAPixel); virtual; overload;
    615      procedure TextOut(x, y: single; sUTF8: string; c: TColor); virtual; overload;
    616      procedure TextOut(x, y: single; sUTF8: string; texture: IBGRAScanner); virtual; overload;
     671     procedure TextOut(x, y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment); overload; virtual;
     672     procedure TextOut(x, y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment); overload; virtual;
     673     procedure TextOut(x, y: single; sUTF8: string; c: TBGRAPixel); overload; virtual;
     674     procedure TextOut(x, y: single; sUTF8: string; c: TBGRAPixel; ARightToLeft: boolean); overload; virtual;
     675     procedure TextOut(x, y: single; sUTF8: string; c: TColor); overload; virtual;
     676     procedure TextOut(x, y: single; sUTF8: string; c: TColor; ARightToLeft: boolean); overload; virtual;
     677     procedure TextOut(x, y: single; sUTF8: string; texture: IBGRAScanner); overload; virtual;
     678     procedure TextOut(x, y: single; sUTF8: string; texture: IBGRAScanner; ARightToLeft: boolean); overload; virtual;
    617679
    618680     { Draw the UTF8 encoded string in the rectangle ARect. Text is wrapped if necessary.
    619681       The position depends on the specified horizontal alignment halign and vertical alignement valign.
    620682       The color c or texture is used to fill the text. No rotation is applied. }
    621      procedure TextRect(ARect: TRect; sUTF8: string; halign: TAlignment; valign: TTextLayout; c: TBGRAPixel); virtual; overload;
    622      procedure TextRect(ARect: TRect; sUTF8: string; halign: TAlignment; valign: TTextLayout; texture: IBGRAScanner); virtual; overload;
     683     procedure TextRect(ARect: TRect; sUTF8: string; halign: TAlignment; valign: TTextLayout; c: TBGRAPixel); overload; virtual;
     684     procedure TextRect(ARect: TRect; sUTF8: string; halign: TAlignment; valign: TTextLayout; texture: IBGRAScanner); overload; virtual;
    623685
    624686     {Spline}
    625687     function ComputeClosedSpline(const APoints: array of TPointF; AStyle: TSplineStyle): ArrayOfTPointF; virtual; abstract;
    626688     function ComputeOpenedSpline(const APoints: array of TPointF; AStyle: TSplineStyle): ArrayOfTPointF; virtual; abstract;
    627      function ComputeBezierCurve(const curve: TCubicBezierCurve): ArrayOfTPointF; virtual; abstract;
    628      function ComputeBezierCurve(const curve: TQuadraticBezierCurve): ArrayOfTPointF; virtual; abstract;
    629      function ComputeBezierSpline(const spline: array of TCubicBezierCurve): ArrayOfTPointF; virtual; abstract;
    630      function ComputeBezierSpline(const spline: array of TQuadraticBezierCurve): ArrayOfTPointF; virtual; abstract;
    631 
    632      function ComputeWidePolyline(const points: array of TPointF; w: single): ArrayOfTPointF; virtual; abstract;
    633      function ComputeWidePolyline(const points: array of TPointF; w: single; ClosedCap: boolean): ArrayOfTPointF; virtual; abstract;
     689     function ComputeBezierCurve(const curve: TCubicBezierCurve): ArrayOfTPointF; overload; virtual; abstract;
     690     function ComputeBezierCurve(const curve: TQuadraticBezierCurve): ArrayOfTPointF; overload; virtual; abstract;
     691     function ComputeBezierSpline(const spline: array of TCubicBezierCurve): ArrayOfTPointF; overload; virtual; abstract;
     692     function ComputeBezierSpline(const spline: array of TQuadraticBezierCurve): ArrayOfTPointF; overload; virtual; abstract;
     693
     694     function ComputeWidePolyline(const points: array of TPointF; w: single): ArrayOfTPointF; overload; virtual; abstract;
     695     function ComputeWidePolyline(const points: array of TPointF; w: single; ClosedCap: boolean): ArrayOfTPointF; overload; virtual; abstract;
    634696     function ComputeWidePolygon(const points: array of TPointF; w: single): ArrayOfTPointF; virtual; abstract;
    635697
    636      function ComputeEllipse(x,y,rx,ry: single): ArrayOfTPointF; deprecated;
    637      function ComputeEllipse(x,y,rx,ry,w: single): ArrayOfTPointF; deprecated;
    638      function ComputeEllipseContour(x,y,rx,ry: single; quality: single = 1): ArrayOfTPointF; virtual; abstract;
    639      function ComputeEllipseBorder(x,y,rx,ry,w: single; quality: single = 1): ArrayOfTPointF; virtual; abstract;
     698     function ComputeEllipse(x,y,rx,ry: single): ArrayOfTPointF; overload; deprecated;
     699     function ComputeEllipse(x,y,rx,ry,w: single): ArrayOfTPointF; overload; deprecated;
     700     function ComputeEllipseContour(x,y,rx,ry: single; quality: single = 1): ArrayOfTPointF; overload; virtual; abstract;
     701     function ComputeEllipseContour(AOrigin, AXAxis, AYAxis: TPointF; quality: single = 1): ArrayOfTPointF; overload; virtual; abstract;
     702     function ComputeEllipseBorder(x,y,rx,ry,w: single; quality: single = 1): ArrayOfTPointF; overload; virtual; abstract;
     703     function ComputeEllipseBorder(AOrigin, AXAxis, AYAxis: TPointF; w: single; quality: single = 1): ArrayOfTPointF; overload; virtual; abstract;
    640704     function ComputeArc65536(x,y,rx,ry: single; start65536,end65536: word; quality: single = 1): ArrayOfTPointF; virtual; abstract;
    641705     function ComputeArcRad(x,y,rx,ry: single; startRad,endRad: single; quality: single = 1): ArrayOfTPointF; virtual; abstract;
    642      function ComputeRoundRect(x1,y1,x2,y2,rx,ry: single; quality: single = 1): ArrayOfTPointF; virtual; abstract;
    643      function ComputeRoundRect(x1,y1,x2,y2,rx,ry: single; options: TRoundRectangleOptions; quality: single = 1): ArrayOfTPointF; virtual; abstract;
     706     function ComputeRoundRect(x1,y1,x2,y2,rx,ry: single; quality: single = 1): ArrayOfTPointF; overload; virtual; abstract;
     707     function ComputeRoundRect(x1,y1,x2,y2,rx,ry: single; options: TRoundRectangleOptions; quality: single = 1): ArrayOfTPointF; overload; virtual; abstract;
    644708     function ComputePie65536(x,y,rx,ry: single; start65536,end65536: word; quality: single = 1): ArrayOfTPointF; virtual; abstract;
    645709     function ComputePieRad(x,y,rx,ry: single; startRad,endRad: single; quality: single = 1): ArrayOfTPointF; virtual; abstract;
     
    648712     procedure FillTransparent; virtual;
    649713     procedure NoClip; virtual; abstract;
    650      procedure ApplyGlobalOpacity(alpha: byte); virtual; abstract; overload;
    651      procedure ApplyGlobalOpacity(ARect: TRect; alpha: byte); virtual; abstract; overload;
    652      procedure Fill(c: TColor); virtual; overload;
    653      procedure Fill(c: TBGRAPixel); virtual; overload;
    654      procedure Fill(texture: IBGRAScanner; mode: TDrawMode); virtual; abstract; overload;
    655      procedure Fill(texture: IBGRAScanner); virtual; abstract; overload;
    656      procedure Fill(c: TBGRAPixel; start, Count: integer); virtual; abstract; overload;
     714     procedure ApplyGlobalOpacity(alpha: byte); overload; virtual; abstract;
     715     procedure ApplyGlobalOpacity(ARect: TRect; alpha: byte); overload; virtual; abstract;
     716     procedure Fill(c: TColor); overload; virtual;
     717     procedure Fill(c: TBGRAPixel); overload; virtual;
     718     procedure Fill(texture: IBGRAScanner; mode: TDrawMode); overload; virtual; abstract;
     719     procedure Fill(texture: IBGRAScanner); overload; virtual; abstract;
     720     procedure Fill(c: TBGRAPixel; start, Count: integer); overload; virtual; abstract;
    657721     procedure DrawPixels(c: TBGRAPixel; start, Count: integer); virtual; abstract;
    658      procedure AlphaFill(alpha: byte); virtual; overload;
    659      procedure AlphaFill(alpha: byte; start, Count: integer); virtual; abstract; overload;
    660      procedure FillMask(x,y: integer; AMask: TBGRACustomBitmap; color: TBGRAPixel); virtual; overload;
    661      procedure FillMask(x,y: integer; AMask: TBGRACustomBitmap; texture: IBGRAScanner); virtual; overload;
    662      procedure FillMask(x,y: integer; AMask: TBGRACustomBitmap; color: TBGRAPixel; ADrawMode: TDrawMode); virtual; abstract; overload;
    663      procedure FillMask(x,y: integer; AMask: TBGRACustomBitmap; texture: IBGRAScanner; ADrawMode: TDrawMode; AOpacity: byte = 255); virtual; abstract; overload;
    664      procedure FillClearTypeMask(x,y: integer; xThird: integer; AMask: TBGRACustomBitmap; color: TBGRAPixel; ARGBOrder: boolean = true); virtual; abstract; overload;
    665      procedure FillClearTypeMask(x,y: integer; xThird: integer; AMask: TBGRACustomBitmap; texture: IBGRAScanner; ARGBOrder: boolean = true); virtual; abstract; overload;
    666      procedure ReplaceColor(before, after: TColor); virtual; abstract; overload;
    667      procedure ReplaceColor(before, after: TBGRAPixel); virtual; abstract; overload;
    668      procedure ReplaceColor(ARect: TRect; before, after: TColor); virtual; abstract; overload;
    669      procedure ReplaceColor(ARect: TRect; before, after: TBGRAPixel); virtual; abstract; overload;
    670      procedure ReplaceTransparent(after: TBGRAPixel); virtual; abstract; overload;
    671      procedure ReplaceTransparent(ABounds: TRect; after: TBGRAPixel); virtual; abstract; overload;
     722     procedure AlphaFill(alpha: byte); overload; virtual;
     723     procedure AlphaFill(alpha: byte; start, Count: integer); overload; virtual; abstract;
     724     procedure FillMask(x,y: integer; AMask: TBGRACustomBitmap; color: TBGRAPixel); overload; virtual;
     725     procedure FillMask(x,y: integer; AMask: TBGRACustomBitmap; texture: IBGRAScanner); overload; virtual;
     726     procedure FillMask(x,y: integer; AMask: TBGRACustomBitmap; color: TBGRAPixel; ADrawMode: TDrawMode); overload; virtual; abstract;
     727     procedure FillMask(x,y: integer; AMask: TBGRACustomBitmap; texture: IBGRAScanner; ADrawMode: TDrawMode; AOpacity: byte = 255); overload; virtual; abstract;
     728     procedure EraseMask(x,y: integer; AMask: TBGRACustomBitmap; alpha: byte=255); virtual; abstract;
     729     procedure FillClearTypeMask(x,y: integer; xThird: integer; AMask: TBGRACustomBitmap; color: TBGRAPixel; ARGBOrder: boolean = true); overload; virtual; abstract;
     730     procedure FillClearTypeMask(x,y: integer; xThird: integer; AMask: TBGRACustomBitmap; texture: IBGRAScanner; ARGBOrder: boolean = true); overload; virtual; abstract;
     731     procedure ReplaceColor(before, after: TColor); overload; virtual; abstract;
     732     procedure ReplaceColor(before, after: TBGRAPixel); overload; virtual; abstract;
     733     procedure ReplaceColor(ARect: TRect; before, after: TColor); overload; virtual; abstract;
     734     procedure ReplaceColor(ARect: TRect; before, after: TBGRAPixel); overload; virtual; abstract;
     735     procedure ReplaceTransparent(after: TBGRAPixel); overload; virtual; abstract;
     736     procedure ReplaceTransparent(ABounds: TRect; after: TBGRAPixel); overload; virtual; abstract;
    672737     procedure FloodFill(X, Y: integer; Color: TBGRAPixel;
    673738       mode: TFloodfillMode; Tolerance: byte = 0); virtual;
     
    677742       gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode;
    678743       gammaColorCorrection: boolean = True; Sinus: Boolean=False;
    679        ditherAlgo: TDitheringAlgorithm = daNearestNeighbor); virtual; abstract; overload;
     744       ditherAlgo: TDitheringAlgorithm = daNearestNeighbor); overload; virtual; abstract;
    680745     procedure GradientFill(x, y, x2, y2: integer; gradient: TBGRACustomGradient;
    681746       gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode;
    682747       Sinus: Boolean=False;
    683        ditherAlgo: TDitheringAlgorithm = daNearestNeighbor); virtual; abstract; overload;
     748       ditherAlgo: TDitheringAlgorithm = daNearestNeighbor); overload; virtual; abstract;
    684749     function CreateBrushTexture(ABrushStyle: TBrushStyle; APatternColor, ABackgroundColor: TBGRAPixel;
    685750                AWidth: integer = 8; AHeight: integer = 8; APenWidth: single = 1): TBGRACustomBitmap; virtual; abstract;
     
    688753     procedure DataDrawTransparent(ACanvas: TCanvas; Rect: TRect;
    689754       AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); virtual; abstract;
    690      procedure DataDrawOpaque(ACanvas: TCanvas; Rect: TRect; AData: Pointer;
     755     procedure DataDrawOpaque(ACanvas: TCanvas; ARect: TRect; AData: Pointer;
    691756       ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); virtual; abstract;
    692757     procedure GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer); virtual; abstract;
    693      procedure Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean = True); virtual; abstract;
    694      procedure Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean = True); virtual; abstract;
     758     procedure Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean = True); overload; virtual; abstract;
     759     procedure Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean = True); overload; virtual; abstract;
    695760     procedure DrawPart(ARect: TRect; ACanvas: TCanvas; x, y: integer; Opaque: boolean); virtual;
    696761     function GetPart(ARect: TRect): TBGRACustomBitmap; virtual; abstract;
     
    700765
    701766     {BGRA bitmap functions}
    702      procedure CrossFade(ARect: TRect; Source1, Source2: IBGRAScanner; AFadePosition: byte; mode: TDrawMode = dmDrawWithTransparency); virtual; abstract;
    703      procedure CrossFade(ARect: TRect; Source1, Source2: IBGRAScanner; AFadeMask: IBGRAScanner; mode: TDrawMode = dmDrawWithTransparency); virtual; abstract;
    704      procedure PutImage(x, y: integer; Source: TBGRACustomBitmap; mode: TDrawMode; AOpacity: byte = 255); virtual; abstract;
     767     procedure CrossFade(ARect: TRect; Source1, Source2: IBGRAScanner; AFadePosition: byte; mode: TDrawMode = dmDrawWithTransparency); overload; virtual; abstract;
     768     procedure CrossFade(ARect: TRect; Source1, Source2: IBGRAScanner; AFadeMask: IBGRAScanner; mode: TDrawMode = dmDrawWithTransparency); overload; virtual; abstract;
     769     procedure PutImage(x, y: integer; Source: TBGRACustomBitmap; mode: TDrawMode; AOpacity: byte = 255); overload; virtual; abstract;
     770     procedure PutImage(x, y: integer; Source: TBitmap; mode: TDrawMode; AOpacity: byte = 255); overload;
    705771     procedure StretchPutImage(ARect: TRect; Source: TBGRACustomBitmap; mode: TDrawMode; AOpacity: byte = 255); virtual; abstract;
     772     procedure StretchPutImageProportionally(ARect: TRect; AHorizAlign: TAlignment; AVertAlign: TTextLayout; Source: TBGRACustomBitmap; mode: TDrawMode; AOpacity: byte = 255);
    706773     procedure PutImageSubpixel(x, y: single; Source: TBGRACustomBitmap; AOpacity: byte = 255);
    707774     procedure PutImagePart(x,y: integer; Source: TBGRACustomBitmap; SourceRect: TRect; mode: TDrawMode; AOpacity: byte = 255);
     
    712779     procedure PutImageAffine(AMatrix: TAffineMatrix; Source: TBGRACustomBitmap; AOpacity: Byte=255; ACorrectBlur: Boolean = false); overload;
    713780     procedure PutImageAffine(AMatrix: TAffineMatrix; Source: TBGRACustomBitmap; AResampleFilter: TResampleFilter; AOpacity: Byte=255); overload;
    714      procedure PutImageAffine(AMatrix: TAffineMatrix; Source: TBGRACustomBitmap; AOutputBounds: TRect; AResampleFilter: TResampleFilter; AMode: TDrawMode; AOpacity: Byte=255); virtual; abstract; overload;
     781     procedure PutImageAffine(AMatrix: TAffineMatrix; Source: TBGRACustomBitmap; AResampleFilter: TResampleFilter; AMode: TDrawMode; AOpacity: Byte=255); overload;
     782     procedure PutImageAffine(AMatrix: TAffineMatrix; Source: TBGRACustomBitmap; AOutputBounds: TRect; AResampleFilter: TResampleFilter; AMode: TDrawMode; AOpacity: Byte=255); overload; virtual; abstract;
    715783     procedure PutImageAffine(AMatrix: TAffineMatrix; Source: TBGRACustomBitmap; AOutputBounds: TRect; AOpacity: Byte=255; ACorrectBlur: Boolean = false); overload;
    716784     function GetImageAffineBounds(Origin,HAxis,VAxis: TPointF; Source: TBGRACustomBitmap): TRect; overload;
    717785     function GetImageAffineBounds(Origin,HAxis,VAxis: TPointF; ASourceWidth, ASourceHeight: integer; const ASourceBounds: TRect; AClipOutput: boolean = true): TRect; overload;
    718786     function GetImageAffineBounds(AMatrix: TAffineMatrix; Source: TBGRACustomBitmap): TRect; overload;
    719      function GetImageAffineBounds(AMatrix: TAffineMatrix; ASourceBounds: TRect; AClipOutput: boolean = true): TRect; virtual; abstract; overload;
    720      function IsAffineRoughlyTranslation(AMatrix: TAffineMatrix; ASourceBounds: TRect): boolean; virtual; abstract;
     787     function GetImageAffineBounds(AMatrix: TAffineMatrix; ASourceBounds: TRect; AClipOutput: boolean = true): TRect; overload; virtual; abstract;
     788     class function IsAffineRoughlyTranslation(AMatrix: TAffineMatrix; ASourceBounds: TRect): boolean; virtual; abstract;
    721789     procedure PutImageAngle(x,y: single; Source: TBGRACustomBitmap; angle: single; AOutputBounds: TRect; imageCenterX: single = 0; imageCenterY: single = 0; AOpacity: Byte=255; ARestoreOffsetAfterRotation: boolean = false; ACorrectBlur: Boolean = false); overload;
    722790     procedure PutImageAngle(x,y: single; Source: TBGRACustomBitmap; angle: single; imageCenterX: single = 0; imageCenterY: single = 0; AOpacity: Byte=255; ARestoreOffsetAfterRotation: boolean = false; ACorrectBlur: Boolean = false); overload;
     
    729797     procedure BlendImageOver(x, y: integer; Source: TBGRACustomBitmap; operation: TBlendOperation; AOpacity: byte = 255;
    730798         ALinearBlend: boolean = false); virtual; abstract;
    731      function Duplicate(DuplicateProperties: Boolean = False): TBGRACustomBitmap; virtual; abstract;
    732      function Equals(comp: TBGRACustomBitmap): boolean; virtual; abstract;
    733      function Equals(comp: TBGRAPixel): boolean; virtual; abstract;
     799     function Duplicate(DuplicateProperties: Boolean = False; DuplicateXorMask: Boolean = False): TBGRACustomBitmap; virtual; abstract;
     800     function Equals(comp: TBGRACustomBitmap): boolean; overload; virtual; abstract;
     801     function Equals(comp: TBGRAPixel): boolean; overload; virtual; abstract;
    734802     function Resample(newWidth, newHeight: integer;
    735803       mode: TResampleMode = rmFineResample): TBGRACustomBitmap; virtual; abstract;
    736      procedure VerticalFlip; virtual; overload;
    737      procedure VerticalFlip(ARect: TRect); virtual; abstract; overload;
    738      procedure HorizontalFlip; virtual; overload;
    739      procedure HorizontalFlip(ARect: TRect); virtual; abstract; overload;
     804     procedure VerticalFlip; overload; virtual;
     805     procedure VerticalFlip(ARect: TRect); overload; virtual; abstract;
     806     procedure HorizontalFlip; overload; virtual;
     807     procedure HorizontalFlip(ARect: TRect); overload; virtual; abstract;
    740808     function RotateCW: TBGRACustomBitmap; virtual; abstract;
    741809     function RotateCCW: TBGRACustomBitmap; virtual; abstract;
     
    744812     procedure LinearNegative; virtual; abstract;
    745813     procedure LinearNegativeRect(ABounds: TRect); virtual; abstract;
    746      procedure InplaceGrayscale(AGammaCorrection: boolean = true); virtual; abstract;
    747      procedure InplaceGrayscale(ABounds: TRect; AGammaCorrection: boolean = true); virtual; abstract;
    748      procedure InplaceNormalize(AEachChannel: boolean = True); virtual; abstract;
    749      procedure InplaceNormalize(ABounds: TRect; AEachChannel: boolean = True); virtual; abstract;
     814     procedure InplaceGrayscale(AGammaCorrection: boolean = true); overload; virtual; abstract;
     815     procedure InplaceGrayscale(ABounds: TRect; AGammaCorrection: boolean = true); overload; virtual; abstract;
     816     procedure InplaceNormalize(AEachChannel: boolean = True); overload; virtual; abstract;
     817     procedure InplaceNormalize(ABounds: TRect; AEachChannel: boolean = True); overload; virtual; abstract;
    750818     procedure ConvertToLinearRGB; virtual; abstract;
    751819     procedure ConvertFromLinearRGB; virtual; abstract;
    752      procedure SwapRedBlue; virtual; abstract; overload;
    753      procedure SwapRedBlue(ARect: TRect); virtual; abstract; overload;
     820     procedure DrawCheckers(ARect: TRect; AColorEven,AColorOdd: TBGRAPixel); virtual; abstract;
     821     procedure SwapRedBlue; overload; virtual; abstract;
     822     procedure SwapRedBlue(ARect: TRect); overload; virtual; abstract;
    754823     procedure GrayscaleToAlpha; virtual; abstract;
    755824     procedure AlphaToGrayscale; virtual; abstract;
    756825     procedure ApplyMask(mask: TBGRACustomBitmap); overload;
    757826     procedure ApplyMask(mask: TBGRACustomBitmap; ARect: TRect); overload;
    758      procedure ApplyMask(mask: TBGRACustomBitmap; ARect: TRect; AMaskRectTopLeft: TPoint); virtual; abstract; overload;
    759      function GetImageBounds(Channel: TChannel = cAlpha; ANothingValue: Byte = 0): TRect; virtual;
    760      function GetImageBounds(Channels: TChannels; ANothingValue: Byte = 0): TRect; virtual;
    761      function GetImageBoundsWithin(const ARect: TRect; Channel: TChannel = cAlpha; ANothingValue: Byte = 0): TRect; virtual;
    762      function GetImageBoundsWithin(const ARect: TRect; Channels: TChannels; ANothingValue: Byte = 0): TRect; virtual;
     827     procedure ApplyMask(mask: TBGRACustomBitmap; ARect: TRect; AMaskRectTopLeft: TPoint); overload; virtual; abstract;
     828     function GetMaskFromAlpha: TBGRACustomBitmap; virtual; abstract;
     829     function GetImageBounds(Channel: TChannel = cAlpha; ANothingValue: Byte = 0): TRect; overload; virtual;
     830     function GetImageBounds(Channels: TChannels; ANothingValue: Byte = 0): TRect; overload; virtual;
     831     function GetImageBoundsWithin(const ARect: TRect; Channel: TChannel = cAlpha; ANothingValue: Byte = 0): TRect; overload; virtual;
     832     function GetImageBoundsWithin(const ARect: TRect; Channels: TChannels; ANothingValue: Byte = 0): TRect; overload; virtual;
    763833     function GetDifferenceBounds(ABitmap: TBGRACustomBitmap): TRect; virtual; abstract;
    764834     function MakeBitmapCopy(BackgroundColor: TColor): TBitmap; virtual; abstract;
     
    768838     function FilterMedian(Option: TMedianOption): TBGRACustomBitmap; virtual; abstract;
    769839     function FilterSmooth: TBGRACustomBitmap; virtual; abstract;
    770      function FilterSharpen(Amount: single = 1): TBGRACustomBitmap; virtual; abstract;
    771      function FilterSharpen(ABounds: TRect; Amount: single = 1): TBGRACustomBitmap; virtual; abstract;
     840     function FilterSharpen(Amount: single = 1): TBGRACustomBitmap; overload; virtual; abstract;
     841     function FilterSharpen(ABounds: TRect; Amount: single = 1): TBGRACustomBitmap; overload; virtual; abstract;
    772842     function FilterContour: TBGRACustomBitmap; virtual; abstract;
    773843     function FilterPixelate(pixelSize: integer; useResample: boolean; filter: TResampleFilter = rfLinear): TBGRACustomBitmap; virtual; abstract;
    774      function FilterBlurRadial(radius: single; blurType: TRadialBlurType): TBGRACustomBitmap; virtual; abstract; overload;
    775      function FilterBlurRadial(ABounds: TRect; radius: single; blurType: TRadialBlurType): TBGRACustomBitmap; virtual; abstract; overload;
    776      function FilterBlurRadial(radiusX, radiusY: single; blurType: TRadialBlurType): TBGRACustomBitmap; virtual; abstract; overload;
    777      function FilterBlurRadial(ABounds: TRect; radiusX, radiusY: single; blurType: TRadialBlurType): TBGRACustomBitmap; virtual; abstract; overload;
    778      function FilterBlurMotion(distance: single; angle: single; oriented: boolean): TBGRACustomBitmap; virtual; abstract;
    779      function FilterBlurMotion(ABounds: TRect; distance: single; angle: single;
    780        oriented: boolean): TBGRACustomBitmap; virtual; abstract; function FilterCustomBlur(mask: TBGRACustomBitmap): TBGRACustomBitmap; virtual; abstract;
    781      function FilterCustomBlur(ABounds: TRect; mask: TBGRACustomBitmap): TBGRACustomBitmap; virtual; abstract;
    782      function FilterEmboss(angle: single; AStrength: integer= 64; AOptions: TEmbossOptions = []): TBGRACustomBitmap; virtual; abstract;
    783      function FilterEmboss(angle: single; ABounds: TRect; AStrength: integer= 64; AOptions: TEmbossOptions = []): TBGRACustomBitmap; virtual; abstract;
    784      function FilterEmbossHighlight(FillSelection: boolean): TBGRACustomBitmap; virtual; abstract;
    785      function FilterEmbossHighlight(FillSelection: boolean; BorderColor: TBGRAPixel): TBGRACustomBitmap; virtual; abstract;
    786      function FilterEmbossHighlight(FillSelection: boolean; BorderColor: TBGRAPixel; var Offset: TPoint): TBGRACustomBitmap; virtual; abstract;
    787      function FilterGrayscale: TBGRACustomBitmap; virtual; abstract;
    788      function FilterGrayscale(ABounds: TRect): TBGRACustomBitmap; virtual; abstract;
    789      function FilterNormalize(eachChannel: boolean = True): TBGRACustomBitmap; virtual; abstract;
    790      function FilterNormalize(ABounds: TRect; eachChannel: boolean = True): TBGRACustomBitmap; virtual; abstract;
     844     function FilterBlurRadial(radius: single; blurType: TRadialBlurType): TBGRACustomBitmap; overload; virtual; abstract;
     845     function FilterBlurRadial(ABounds: TRect; radius: single; blurType: TRadialBlurType): TBGRACustomBitmap; overload; virtual; abstract;
     846     function FilterBlurRadial(radiusX, radiusY: single; blurType: TRadialBlurType): TBGRACustomBitmap; overload; virtual; abstract;
     847     function FilterBlurRadial(ABounds: TRect; radiusX, radiusY: single; blurType: TRadialBlurType): TBGRACustomBitmap; overload; virtual; abstract;
     848     function FilterBlurMotion(distance: single; angle: single; oriented: boolean): TBGRACustomBitmap; overload; virtual; abstract;
     849     function FilterBlurMotion(ABounds: TRect; distance: single; angle: single; oriented: boolean): TBGRACustomBitmap; overload; virtual; abstract;
     850     function FilterCustomBlur(mask: TBGRACustomBitmap): TBGRACustomBitmap; overload; virtual; abstract;
     851     function FilterCustomBlur(ABounds: TRect; mask: TBGRACustomBitmap): TBGRACustomBitmap; overload; virtual; abstract;
     852     function FilterEmboss(angle: single; AStrength: integer= 64; AOptions: TEmbossOptions = []): TBGRACustomBitmap; overload; virtual; abstract;
     853     function FilterEmboss(angle: single; ABounds: TRect; AStrength: integer= 64; AOptions: TEmbossOptions = []): TBGRACustomBitmap; overload; virtual; abstract;
     854     function FilterEmbossHighlight(FillSelection: boolean): TBGRACustomBitmap; overload; virtual; abstract;
     855     function FilterEmbossHighlight(FillSelection: boolean; BorderColor: TBGRAPixel): TBGRACustomBitmap; overload; virtual; abstract;
     856     function FilterEmbossHighlight(FillSelection: boolean; BorderColor: TBGRAPixel; var Offset: TPoint): TBGRACustomBitmap; overload; virtual; abstract;
     857     function FilterGrayscale: TBGRACustomBitmap; overload; virtual; abstract;
     858     function FilterGrayscale(ABounds: TRect): TBGRACustomBitmap; overload; virtual; abstract;
     859     function FilterNormalize(eachChannel: boolean = True): TBGRACustomBitmap; overload; virtual; abstract;
     860     function FilterNormalize(ABounds: TRect; eachChannel: boolean = True): TBGRACustomBitmap; overload; virtual; abstract;
    791861     function FilterRotate(origin: TPointF; angle: single; correctBlur: boolean = false): TBGRACustomBitmap; virtual; abstract;
    792862     function FilterAffine(AMatrix: TAffineMatrix; correctBlur: boolean = false): TBGRACustomBitmap; virtual; abstract;
    793863     function FilterSphere: TBGRACustomBitmap; virtual; abstract;
    794      function FilterTwirl(ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap; virtual; abstract;
    795      function FilterTwirl(ABounds: TRect; ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap; virtual; abstract;
     864     function FilterTwirl(ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap; overload; virtual; abstract;
     865     function FilterTwirl(ABounds: TRect; ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap; overload; virtual; abstract;
    796866     function FilterCylinder: TBGRACustomBitmap; virtual; abstract;
    797867     function FilterPlane: TBGRACustomBitmap; virtual; abstract;
     
    10551125end;
    10561126
     1127function TBGRACustomBitmap.GetFontRightToLeftFor(AText: string): boolean;
     1128begin
     1129  case FontBidiMode of
     1130    fbmAuto: result := IsRightToLeftUTF8(AText);
     1131    fbmRightToLeft: result := true;
     1132  else
     1133    {fbmLeftToRight}
     1134    result := false;
     1135  end;
     1136end;
     1137
    10571138procedure TBGRACustomBitmap.InternalArc(cx, cy, rx, ry: single;
    10581139  const StartPoint, EndPoint: TPointF; ABorderColor: TBGRAPixel; w: single; AFillColor: TBGRAPixel; AOptions: TArcOptions;
     
    12971378end;
    12981379
     1380procedure TBGRACustomBitmap.LoadFromResource(AFilename: string);
     1381begin
     1382  LoadFromResource(AFilename, [loKeepTransparentRGB]);
     1383end;
     1384
     1385procedure TBGRACustomBitmap.LoadFromResource(AFilename: string;
     1386  Handler: TFPCustomImageReader);
     1387begin
     1388  LoadFromResource(AFilename, Handler, [loKeepTransparentRGB]);
     1389end;
     1390
     1391procedure TBGRACustomBitmap.LoadFromResource(AFilename: string;
     1392  Handler: TFPCustomImageReader; AOptions: TBGRALoadingOptions);
     1393var
     1394  stream: TStream;
     1395begin
     1396  stream := BGRAResource.GetResourceStream(AFilename);
     1397  try
     1398    LoadFromStream(stream,Handler,AOptions);
     1399  finally
     1400    stream.Free;
     1401  end;
     1402end;
     1403
    12991404{ Look for a pixel considering the bitmap is repeated in both directions }
    13001405function TBGRACustomBitmap.GetPixelCycle(x, y: int32or64): TBGRAPixel;
     
    13381443procedure TBGRACustomBitmap.DrawPolyLine(const points: array of TPoint;
    13391444  c: TBGRAPixel; DrawLastPixel: boolean; ADrawMode: TDrawMode);
    1340 var i: integer;
    1341 begin
    1342    if length(points) = 1 then
    1343    begin
    1344      if DrawLastPixel then DrawPixel(points[0].x,points[0].y,c,ADrawMode);
    1345    end
    1346    else
    1347      for i := 0 to high(points)-1 do
    1348        DrawLine(points[i].x,points[i].Y,points[i+1].x,points[i+1].y,c,DrawLastPixel and (i=high(points)-1),ADrawMode);
     1445var i,start: integer;
     1446begin
     1447  start := 0;
     1448  for i := 0 to high(points) do
     1449  if IsEmptyPoint(points[i]) then start := i+1 else
     1450  begin
     1451    if (i = high(points)) or IsEmptyPoint(points[i+1]) then
     1452    begin
     1453      if (i = start) and DrawLastPixel then DrawPixel(points[i].x,points[i].y,c,ADrawMode);
     1454    end else
     1455      DrawLine(points[i].x,points[i].Y,points[i+1].x,points[i+1].y, c,
     1456        DrawLastPixel and ((i=high(points)-1) or IsEmptyPoint(points[i+2])), ADrawMode);
     1457  end;
    13491458end;
    13501459
     
    13521461procedure TBGRACustomBitmap.DrawPolyLineAntialias(const points: array of TPoint;
    13531462  c: TBGRAPixel; DrawLastPixel: boolean);
    1354 var i: integer;
    1355 begin
    1356    if length(points) = 1 then
    1357    begin
    1358      if DrawLastPixel then DrawLineAntialias(points[0].x,points[0].y,points[0].x,points[0].y,c,true);
    1359    end
    1360    else
    1361      for i := 0 to high(points)-1 do
    1362        DrawLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y,c,DrawLastPixel and (i=high(points)-1));
     1463var i,start: integer;
     1464begin
     1465  start := 0;
     1466  for i := 0 to high(points) do
     1467  if IsEmptyPoint(points[i]) then start := i+1 else
     1468  begin
     1469    if (i = high(points)) or IsEmptyPoint(points[i+1]) then
     1470    begin
     1471      if (i = start) and DrawLastPixel then DrawLineAntialias(points[i].x,points[i].y,points[i].x,points[i].y,c,true);
     1472    end else
     1473      DrawLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y, c,
     1474        DrawLastPixel and ((i=high(points)-1) or IsEmptyPoint(points[i+2])));
     1475  end;
    13631476end;
    13641477
    13651478procedure TBGRACustomBitmap.DrawPolyLineAntialias(const points: array of TPoint; c1,
    13661479  c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean);
    1367 var i: integer;
    1368   DashPos: integer;
    1369 begin
    1370    DashPos := 0;
    1371    if length(points) = 1 then
    1372    begin
    1373      if DrawLastPixel then DrawPixel(points[0].x,points[0].y,c1);
    1374    end
    1375    else
    1376      for i := 0 to high(points)-1 do
    1377        DrawLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y,c1,c2,dashLen,DrawLastPixel and (i=high(points)-1),DashPos);
     1480var i,start,dashPos: integer;
     1481begin
     1482  start := 0;
     1483  dashPos := 0;
     1484  for i := 0 to high(points) do
     1485  if IsEmptyPoint(points[i]) then
     1486  begin
     1487    start := i+1;
     1488    dashPos := 0;
     1489  end else
     1490  begin
     1491    if (i = high(points)) or IsEmptyPoint(points[i+1]) then
     1492    begin
     1493      if (i = start) and DrawLastPixel then DrawPixel(points[i].x,points[i].y, c1);
     1494    end else
     1495      DrawLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y, c1,c2, dashLen,
     1496        DrawLastPixel and ((i=high(points)-1) or IsEmptyPoint(points[i+2])), dashPos);
     1497  end;
    13781498end;
    13791499
    13801500procedure TBGRACustomBitmap.DrawPolygon(const points: array of TPoint;
    13811501  c: TBGRAPixel; ADrawMode: TDrawMode);
    1382 var i: integer;
    1383 begin
    1384    if length(points) = 1 then
    1385    begin
    1386      DrawPixel(points[0].x,points[0].y,c,ADrawMode);
    1387    end
    1388    else
    1389    begin
    1390      for i := 0 to high(points)-1 do
    1391        DrawLine(points[i].x,points[i].Y,points[i+1].x,points[i+1].y,c,false,ADrawMode);
    1392      DrawLine(points[high(points)].x,points[high(points)].Y,points[0].x,points[0].y,c,false,ADrawMode);
    1393    end;
     1502var i,start: integer;
     1503begin
     1504  start := 0;
     1505  for i := 0 to high(points) do
     1506  if IsEmptyPoint(points[i]) then start := i+1 else
     1507  begin
     1508    if (i = high(points)) or IsEmptyPoint(points[i+1]) then
     1509    begin
     1510      if i = start then DrawPixel(points[i].x,points[i].y,c,ADrawMode)
     1511      else if (i > start) then
     1512        DrawLine(points[i].x,points[i].Y,points[start].x,points[start].y, c, false, ADrawMode);
     1513    end else
     1514      DrawLine(points[i].x,points[i].Y,points[i+1].x,points[i+1].y, c, false, ADrawMode);
     1515  end;
    13941516end;
    13951517
    13961518procedure TBGRACustomBitmap.DrawPolygonAntialias(const points: array of TPoint;
    13971519  c: TBGRAPixel);
    1398 var i: integer;
    1399 begin
    1400    if length(points) = 1 then
    1401    begin
    1402      DrawLineAntialias(points[0].x,points[0].y,points[0].x,points[0].y,c,true);
    1403    end
    1404    else
    1405    begin
    1406      for i := 0 to high(points)-1 do
    1407        DrawLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y,c,false);
    1408      DrawLineAntialias(points[high(points)].x,points[high(points)].Y,points[0].x,points[0].y,c,false);
    1409    end;
     1520var i,start: integer;
     1521begin
     1522  start := 0;
     1523  for i := 0 to high(points) do
     1524  if IsEmptyPoint(points[i]) then start := i+1 else
     1525  begin
     1526    if (i = high(points)) or IsEmptyPoint(points[i+1]) then
     1527    begin
     1528      if i = start then DrawLineAntialias(points[i].x,points[i].y,points[i].x,points[i].y, c, true)
     1529      else if (i > start) then
     1530        DrawLineAntialias(points[i].x,points[i].Y,points[start].x,points[start].y, c, false);
     1531    end else
     1532      DrawLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y, c, false);
     1533  end;
     1534end;
     1535
     1536procedure TBGRACustomBitmap.DrawPolygonAntialias(const points: array of TPoint;
     1537  c1, c2: TBGRAPixel; dashLen: integer);
     1538var i,start,dashPos: integer;
     1539begin
     1540  start := 0;
     1541  dashPos:= 0;
     1542  for i := 0 to high(points) do
     1543  if IsEmptyPoint(points[i]) then
     1544  begin
     1545    start := i+1;
     1546    dashPos:= 0;
     1547  end else
     1548  begin
     1549    if (i = high(points)) or IsEmptyPoint(points[i+1]) then
     1550    begin
     1551      if i = start then DrawLineAntialias(points[i].x,points[i].y,points[i].x,points[i].y, c1, true)
     1552      else if (i > start) then
     1553        DrawLineAntialias(points[i].x,points[i].Y,points[start].x,points[start].y, c1,c2,dashLen, false, dashPos);
     1554    end else
     1555      DrawLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y, c1,c2,dashLen, false, dashPos);
     1556  end;
    14101557end;
    14111558
    14121559procedure TBGRACustomBitmap.ErasePolyLine(const points: array of TPoint; alpha: byte;
    14131560  DrawLastPixel: boolean);
    1414 var i: integer;
    1415 begin
    1416    if length(points) = 1 then
    1417    begin
    1418      if DrawLastPixel then ErasePixel(points[0].x,points[0].y,alpha);
    1419    end
    1420    else
    1421      for i := 0 to high(points)-1 do
    1422        EraseLine(points[i].x,points[i].Y,points[i+1].x,points[i+1].y,alpha,DrawLastPixel and (i=high(points)-1));
     1561var i,start: integer;
     1562begin
     1563  start := 0;
     1564  for i := 0 to high(points) do
     1565  if IsEmptyPoint(points[i]) then start := i+1 else
     1566  begin
     1567    if (i = high(points)) or IsEmptyPoint(points[i+1]) then
     1568    begin
     1569      if (i = start) and DrawLastPixel then ErasePixel(points[i].x,points[i].y,alpha);
     1570    end else
     1571      EraseLine(points[i].x,points[i].Y,points[i+1].x,points[i+1].y, alpha,
     1572        DrawLastPixel and ((i=high(points)-1) or IsEmptyPoint(points[i+2])));
     1573  end;
    14231574end;
    14241575
    14251576procedure TBGRACustomBitmap.ErasePolyLineAntialias(
    14261577  const points: array of TPoint; alpha: byte; DrawLastPixel: boolean);
    1427 var i: integer;
    1428 begin
    1429    if length(points) = 1 then
    1430    begin
    1431      if DrawLastPixel then ErasePixel(points[0].x,points[0].y,alpha);
    1432    end
    1433    else
    1434      for i := 0 to high(points)-1 do
    1435        EraseLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y,alpha,DrawLastPixel and (i=high(points)-1));
     1578var i,start: integer;
     1579begin
     1580  start := 0;
     1581  for i := 0 to high(points) do
     1582  if IsEmptyPoint(points[i]) then start := i+1 else
     1583  begin
     1584    if (i = high(points)) or IsEmptyPoint(points[i+1]) then
     1585    begin
     1586      if (i = start) and DrawLastPixel then ErasePixel(points[i].x,points[i].y, alpha);
     1587    end else
     1588      EraseLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y, alpha,
     1589        DrawLastPixel and ((i=high(points)-1) or IsEmptyPoint(points[i+2])));
     1590  end;
    14361591end;
    14371592
    14381593procedure TBGRACustomBitmap.ErasePolygonOutline(const points: array of TPoint;
    14391594  alpha: byte);
    1440 var i: integer;
    1441 begin
    1442    if length(points) = 1 then
    1443    begin
    1444      ErasePixel(points[0].x,points[0].y,alpha);
    1445    end
    1446    else
    1447    begin
    1448      for i := 0 to high(points)-1 do
    1449        EraseLine(points[i].x,points[i].Y,points[i+1].x,points[i+1].y,alpha,false);
    1450      EraseLine(points[high(points)].x,points[high(points)].Y,points[0].x,points[0].y,alpha,false);
    1451    end;
     1595var i,start: integer;
     1596begin
     1597  start := 0;
     1598  for i := 0 to high(points) do
     1599  if IsEmptyPoint(points[i]) then start := i+1 else
     1600  begin
     1601    if (i = high(points)) or IsEmptyPoint(points[i+1]) then
     1602    begin
     1603      if i = start then ErasePixel(points[i].x,points[i].y, alpha)
     1604      else if (i > start) then
     1605        EraseLine(points[i].x,points[i].Y,points[start].x,points[start].y, alpha, false);
     1606    end else
     1607      EraseLine(points[i].x,points[i].Y,points[i+1].x,points[i+1].y, alpha, false);
     1608  end;
    14521609end;
    14531610
    14541611procedure TBGRACustomBitmap.ErasePolygonOutlineAntialias(
    14551612  const points: array of TPoint; alpha: byte);
    1456 var i: integer;
    1457 begin
    1458    if length(points) = 1 then
    1459    begin
    1460      ErasePixel(points[0].x,points[0].y,alpha);
    1461    end
    1462    else
    1463    begin
    1464      for i := 0 to high(points)-1 do
    1465        EraseLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y,alpha,false);
    1466      EraseLineAntialias(points[high(points)].x,points[high(points)].Y,points[0].x,points[0].y,alpha,false);
    1467    end;
     1613var i,start: integer;
     1614begin
     1615  start := 0;
     1616  for i := 0 to high(points) do
     1617  if IsEmptyPoint(points[i]) then start := i+1 else
     1618  begin
     1619    if (i = high(points)) or IsEmptyPoint(points[i+1]) then
     1620    begin
     1621      if i = start then ErasePixel(points[i].x,points[i].y, alpha)
     1622      else if (i > start) then
     1623        EraseLineAntialias(points[i].x,points[i].Y,points[start].x,points[start].y, alpha, false);
     1624    end else
     1625      EraseLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y, alpha, false);
     1626  end;
    14681627end;
    14691628
     
    16391798end;
    16401799
     1800procedure TBGRACustomBitmap.FillEllipseInRect(r: TRect;
     1801  FillTexture: IBGRAScanner; ADrawMode: TDrawMode);
     1802begin
     1803  FillRoundRect(r.left,r.top,r.right,r.bottom,abs(r.right-r.left),abs(r.bottom-r.top),FillTexture,ADrawMode);
     1804end;
     1805
    16411806procedure TBGRACustomBitmap.FillRect(r: TRect; c: TColor);
    16421807begin
     
    16891854begin
    16901855  FillRect(x,y,x2,y2,texture,mode,Point(0,0),ditheringAlgorithm);
     1856end;
     1857
     1858procedure TBGRACustomBitmap.FillRectAntialias(ARect: TRectF; c: TBGRAPixel;
     1859  pixelCenteredCoordinates: boolean);
     1860begin
     1861  FillRectAntialias(ARect.Left,ARect.Top,ARect.Right,ARect.Bottom, c, pixelCenteredCoordinates);
     1862end;
     1863
     1864procedure TBGRACustomBitmap.FillRectAntialias(ARect: TRectF;
     1865  texture: IBGRAScanner; pixelCenteredCoordinates: boolean);
     1866begin
     1867  FillRectAntialias(ARect.Left,ARect.Top,ARect.Right,ARect.Bottom, texture, pixelCenteredCoordinates);
    16911868end;
    16921869
     
    17191896end;
    17201897
     1898procedure TBGRACustomBitmap.TextMultiline(x, y: single; sUTF8: string;
     1899  c: TBGRAPixel; AAlign: TBidiTextAlignment; AVertAlign: TTextLayout; AParagraphSpacing: single);
     1900begin
     1901  TextMultiline(x, y, EmptySingle, sUTF8, c, AAlign, AVertAlign, AParagraphSpacing);
     1902end;
     1903
     1904procedure TBGRACustomBitmap.TextMultiline(x, y: single; sUTF8: string;
     1905  ATexture: IBGRAScanner; AAlign: TBidiTextAlignment; AVertAlign: TTextLayout; AParagraphSpacing: single);
     1906begin
     1907  TextMultiline(x, y, EmptySingle, sUTF8, ATexture, AAlign, AVertAlign, AParagraphSpacing);
     1908end;
     1909
     1910procedure TBGRACustomBitmap.TextOut(x, y: single; sUTF8: string; c: TBGRAPixel;
     1911  align: TAlignment);
     1912begin
     1913  TextOut(x,y,sUTF8,c,align, GetFontRightToLeftFor(sUTF8));
     1914end;
     1915
     1916procedure TBGRACustomBitmap.TextOut(x, y: single; sUTF8: string;
     1917  texture: IBGRAScanner; align: TAlignment);
     1918begin
     1919  TextOut(x,y,sUTF8,texture,align, GetFontRightToLeftFor(sUTF8));
     1920end;
     1921
    17211922{ Draw the UTF8 encoded string, (x,y) being the top-left corner. The color c is used to fill the text.
    17221923  The value of FontOrientation is taken into account, so that the text may be rotated. }
     
    17261927end;
    17271928
     1929procedure TBGRACustomBitmap.TextOut(x, y: single; sUTF8: string; c: TBGRAPixel;
     1930  ARightToLeft: boolean);
     1931begin
     1932  TextOut(x, y, sUTF8, c, taLeftJustify, ARightToLeft);
     1933end;
     1934
    17281935{ Draw the UTF8 encoded string, (x,y) being the top-left corner. The color c is used to fill the text.
    17291936  The value of FontOrientation is taken into account, so that the text may be rotated. }
     
    17311938begin
    17321939  TextOut(x, y, sUTF8, ColorToBGRA(c));
     1940end;
     1941
     1942procedure TBGRACustomBitmap.TextOut(x, y: single; sUTF8: string; c: TColor;
     1943  ARightToLeft: boolean);
     1944begin
     1945  TextOut(x, y, sUTF8, ColorToBGRA(c), ARightToLeft);
    17331946end;
    17341947
     
    17391952begin
    17401953  TextOut(x, y, sUTF8, texture, taLeftJustify);
     1954end;
     1955
     1956procedure TBGRACustomBitmap.TextOut(x, y: single; sUTF8: string;
     1957  texture: IBGRAScanner; ARightToLeft: boolean);
     1958begin
     1959  TextOut(x, y, sUTF8, texture, taLeftJustify, ARightToLeft);
    17411960end;
    17421961
     
    17571976  style.ShowPrefix := false;
    17581977  style.Clipping := false;
     1978  style.RightToLeft := GetFontRightToLeftFor(sUTF8);
     1979  if FontBidiMode = fbmAuto then sUTF8 := AddParagraphBidiUTF8(sUTF8, style.RightToLeft);
    17591980  TextRect(ARect,ARect.Left,ARect.Top,sUTF8,style,c);
    17601981end;
     
    17761997  style.ShowPrefix := false;
    17771998  style.Clipping := false;
     1999  style.RightToLeft := GetFontRightToLeftFor(sUTF8);
     2000  if FontBidiMode = fbmAuto then sUTF8 := AddParagraphBidiUTF8(sUTF8, style.RightToLeft);
    17782001  TextRect(ARect,ARect.Left,ARect.Top,sUTF8,style,texture);
    17792002end;
     
    18352058  partial: TBGRACustomBitmap;
    18362059begin
    1837   partial := GetPart(ARect);
    1838   if partial <> nil then
    1839   begin
    1840     partial.Draw(ACanvas, x, y, Opaque);
    1841     partial.Free;
    1842   end;
     2060  if (ARect.Left = 0) and (ARect.Top = 0) and (ARect.Right = Width) and (ARect.Bottom = Height) then
     2061    Draw(ACanvas, x,y, Opaque)
     2062  else
     2063  begin
     2064    partial := GetPart(ARect);
     2065    if partial <> nil then
     2066    begin
     2067      partial.Draw(ACanvas, x, y, Opaque);
     2068      partial.Free;
     2069    end;
     2070  end;
     2071end;
     2072
     2073procedure TBGRACustomBitmap.PutImage(x, y: integer; Source: TBitmap;
     2074  mode: TDrawMode; AOpacity: byte);
     2075var bgra: TBGRACustomBitmap;
     2076begin
     2077  bgra := BGRABitmapFactory.create(Source);
     2078  PutImage(x,y, bgra, mode, AOpacity);
     2079  bgra.free;
     2080end;
     2081
     2082procedure TBGRACustomBitmap.StretchPutImageProportionally(ARect: TRect;
     2083  AHorizAlign: TAlignment; AVertAlign: TTextLayout; Source: TBGRACustomBitmap;
     2084  mode: TDrawMode; AOpacity: byte);
     2085var
     2086  ratio: single;
     2087  imgRect: TRect;
     2088begin
     2089  if (Source.Width = 0) or (Source.Height = 0) then exit;
     2090  if (ARect.Width <= 0) or (ARect.Height <= 0) then exit;
     2091
     2092  ratio := min(ARect.Width/Source.Width, ARect.Height/Source.Height);
     2093  imgRect := RectWithSize(ARect.Left,ARect.Top, round(Source.Width*ratio), round(Source.Height*ratio));
     2094  case AHorizAlign of
     2095    taCenter: OffsetRect(imgRect, (ARect.Width-imgRect.Width) div 2, 0);
     2096    taRightJustify: OffsetRect(imgRect, ARect.Width-imgRect.Width, 0);
     2097  end;
     2098  case AVertAlign of
     2099    tlCenter: OffsetRect(imgRect, 0,(ARect.Height-imgRect.Height) div 2);
     2100    tlBottom: OffsetRect(imgRect, 0,ARect.Height-imgRect.Height);
     2101  end;
     2102  StretchPutImage(imgRect, Source, mode, AOpacity);
    18432103end;
    18442104
     
    19022162  Source: TBGRACustomBitmap; AOutputBounds: TRect;
    19032163  AResampleFilter: TResampleFilter; AMode: TDrawMode; AOpacity: Byte);
    1904 var m: TAffineMatrix;
     2164var m: TAffineMatrix; w,h: integer;
    19052165begin
    19062166  if (Source = nil) or (Source.Width = 0) or (Source.Height = 0) or (AOpacity = 0) then exit;
    1907   m[1,1] := (HAxis.x-Origin.x)/(Source.Width-1); m[1,2] := (VAxis.x-Origin.x)/(Source.Height-1); m[1,3] := Origin.x;
    1908   m[2,1] := (HAxis.y-Origin.y)/(Source.Width-1); m[2,2] := (VAxis.y-Origin.y)/(Source.Height-1); m[2,3] := Origin.y;
     2167  if Source.Width < 2 then w := 2 else w := Source.Width; //avoid actual size of zero
     2168  if Source.Height < 2 then h := 2 else h := Source.Height;
     2169  m[1,1] := (HAxis.x-Origin.x)/(w-1); m[1,2] := (VAxis.x-Origin.x)/(h-1); m[1,3] := Origin.x;
     2170  m[2,1] := (HAxis.y-Origin.y)/(w-1); m[2,2] := (VAxis.y-Origin.y)/(h-1); m[2,3] := Origin.y;
    19092171  PutImageAffine(m,Source,AOutputBounds,AResampleFilter,AMode,AOpacity);
    19102172end;
     
    19322194  Source: TBGRACustomBitmap; AResampleFilter: TResampleFilter; AOpacity: Byte);
    19332195begin
     2196  PutImageAffine(AMatrix, Source, AResampleFilter, dmDrawWithTransparency, AOpacity);
     2197end;
     2198
     2199procedure TBGRACustomBitmap.PutImageAffine(AMatrix: TAffineMatrix;
     2200  Source: TBGRACustomBitmap; AResampleFilter: TResampleFilter;
     2201  AMode: TDrawMode; AOpacity: Byte);
     2202begin
    19342203  if (Source = nil) or (Source.Width = 0) or (Source.Height = 0) or (AOpacity = 0) then exit;
    1935   PutImageAffine(AMatrix, Source, GetImageAffineBounds(AMatrix,Source),AResampleFilter,dmDrawWithTransparency,AOpacity);
     2204  PutImageAffine(AMatrix, Source, GetImageAffineBounds(AMatrix,Source),
     2205                 AResampleFilter,AMode,AOpacity);
    19362206end;
    19372207
     
    19642234  else
    19652235  begin
     2236    if ASourceWidth < 2 then ASourceWidth := 2;   //avoid division by zero by supposing a pixel size of 2
     2237    if ASourceHeight < 2 then ASourceHeight := 2; //i.e. an actual size of 1 (cf pixel centered coordinates)
    19662238    m[1,1] := (HAxis.x-Origin.x)/(ASourceWidth-1); m[1,2] := (VAxis.x-Origin.x)/(ASourceHeight-1); m[1,3] := Origin.x;
    19672239    m[2,1] := (HAxis.y-Origin.y)/(ASourceWidth-1); m[2,2] := (VAxis.y-Origin.y)/(ASourceHeight-1); m[2,3] := Origin.y;
     
    20472319  sina := -sin(-angle*Pi/180);
    20482320  Origin := Coord(0,0);
    2049   HAxis := Coord(w,0);
    2050   VAxis := Coord(0,h);
     2321  if w < 2 then w := 2; //when pixel size is 1, actual size is zero, so avoid that
     2322  if h < 2 then h := 2;
     2323  HAxis := Coord(w-1,0);
     2324  VAxis := Coord(0,h-1);
    20512325end;
    20522326
  • GraphicTest/Packages/bgrabitmap/bgracustomtextfx.pas

    r494 r521  
    3333    FOffset: TPoint;
    3434    function DrawMaskMulticolored(ADest: TBGRACustomBitmap; AMask: TBGRACustomBitmap; X,Y: Integer; const AColors: array of TBGRAPixel): TRect;
    35     function DrawMask(ADest: TBGRACustomBitmap; AMask: TBGRACustomBitmap; X,Y: Integer; AColor: TBGRAPixel): TRect;
    36     function DrawMask(ADest: TBGRACustomBitmap; AMask: TBGRACustomBitmap; X,Y: Integer; ATexture: IBGRAScanner): TRect;
     35    function DrawMask(ADest: TBGRACustomBitmap; AMask: TBGRACustomBitmap; X,Y: Integer; AColor: TBGRAPixel): TRect; overload;
     36    function DrawMask(ADest: TBGRACustomBitmap; AMask: TBGRACustomBitmap; X,Y: Integer; ATexture: IBGRAScanner): TRect; overload;
    3737    function InternalDrawShaded(ADest: TBGRACustomBitmap; X,Y: integer; Shader: TCustomPhongShading; Altitude: integer; AColor: TBGRAPixel; ATexture: IBGRAScanner; ARounded: Boolean): TRect;
    3838  public
     
    4141    procedure ApplyVerticalCylinder;
    4242    procedure ApplyHorizontalCylinder;
    43     function Draw(ADest: TBGRACustomBitmap; X,Y: integer; AColor: TBGRAPixel): TRect;
    44     function Draw(ADest: TBGRACustomBitmap; X,Y: integer; ATexture: IBGRAScanner): TRect;
    45     function Draw(ADest: TBGRACustomBitmap; X, Y: integer; AColor: TBGRAPixel; AAlign: TAlignment): TRect;
    46     function Draw(ADest: TBGRACustomBitmap; X, Y: integer; ATexture: IBGRAScanner; AAlign: TAlignment): TRect;
    47 
    48     function DrawShaded(ADest: TBGRACustomBitmap; X,Y: integer; Shader: TCustomPhongShading; Altitude: integer; AColor: TBGRAPixel; ARounded: Boolean = true): TRect;
    49     function DrawShaded(ADest: TBGRACustomBitmap; X,Y: integer; Shader: TCustomPhongShading; Altitude: integer; ATexture: IBGRAScanner; ARounded: Boolean = true): TRect;
    50     function DrawShaded(ADest: TBGRACustomBitmap; X, Y: integer; Shader: TCustomPhongShading; Altitude: integer; AColor: TBGRAPixel; AAlign: TAlignment; ARounded: Boolean = true): TRect;
    51     function DrawShaded(ADest: TBGRACustomBitmap; X, Y: integer; Shader: TCustomPhongShading; Altitude: integer; ATexture: IBGRAScanner; AAlign: TAlignment; ARounded: Boolean = true): TRect;
    52 
    53     function DrawMulticolored(ADest: TBGRACustomBitmap; X,Y: integer; const AColors: array of TBGRAPixel): TRect;
    54     function DrawMulticolored(ADest: TBGRACustomBitmap; X,Y: integer; const AColors: array of TBGRAPixel; AAlign: TAlignment): TRect;
    55     function DrawOutline(ADest: TBGRACustomBitmap; X,Y: integer; AColor: TBGRAPixel): TRect;
    56     function DrawOutline(ADest: TBGRACustomBitmap; X,Y: integer; ATexture: IBGRAScanner): TRect;
    57     function DrawOutline(ADest: TBGRACustomBitmap; X,Y: integer; AColor: TBGRAPixel; AAlign: TAlignment): TRect;
    58     function DrawOutline(ADest: TBGRACustomBitmap; X,Y: integer; ATexture: IBGRAScanner; AAlign: TAlignment): TRect;
    59     function DrawShadow(ADest: TBGRACustomBitmap; X,Y,Radius: integer; AColor: TBGRAPixel): TRect;
    60     function DrawShadow(ADest: TBGRACustomBitmap; X,Y,Radius: integer; AColor: TBGRAPixel; AAlign: TAlignment): TRect;
     43    function Draw(ADest: TBGRACustomBitmap; X,Y: integer; AColor: TBGRAPixel): TRect; overload;
     44    function Draw(ADest: TBGRACustomBitmap; X,Y: integer; ATexture: IBGRAScanner): TRect; overload;
     45    function Draw(ADest: TBGRACustomBitmap; X, Y: integer; AColor: TBGRAPixel; AAlign: TAlignment): TRect; overload;
     46    function Draw(ADest: TBGRACustomBitmap; X, Y: integer; ATexture: IBGRAScanner; AAlign: TAlignment): TRect; overload;
     47
     48    function DrawShaded(ADest: TBGRACustomBitmap; X,Y: integer; Shader: TCustomPhongShading; Altitude: integer; AColor: TBGRAPixel; ARounded: Boolean = true): TRect; overload;
     49    function DrawShaded(ADest: TBGRACustomBitmap; X,Y: integer; Shader: TCustomPhongShading; Altitude: integer; ATexture: IBGRAScanner; ARounded: Boolean = true): TRect; overload;
     50    function DrawShaded(ADest: TBGRACustomBitmap; X, Y: integer; Shader: TCustomPhongShading; Altitude: integer; AColor: TBGRAPixel; AAlign: TAlignment; ARounded: Boolean = true): TRect; overload;
     51    function DrawShaded(ADest: TBGRACustomBitmap; X, Y: integer; Shader: TCustomPhongShading; Altitude: integer; ATexture: IBGRAScanner; AAlign: TAlignment; ARounded: Boolean = true): TRect; overload;
     52
     53    function DrawMulticolored(ADest: TBGRACustomBitmap; X,Y: integer; const AColors: array of TBGRAPixel): TRect; overload;
     54    function DrawMulticolored(ADest: TBGRACustomBitmap; X,Y: integer; const AColors: array of TBGRAPixel; AAlign: TAlignment): TRect; overload;
     55    function DrawOutline(ADest: TBGRACustomBitmap; X,Y: integer; AColor: TBGRAPixel): TRect; overload;
     56    function DrawOutline(ADest: TBGRACustomBitmap; X,Y: integer; ATexture: IBGRAScanner): TRect; overload;
     57    function DrawOutline(ADest: TBGRACustomBitmap; X,Y: integer; AColor: TBGRAPixel; AAlign: TAlignment): TRect; overload;
     58    function DrawOutline(ADest: TBGRACustomBitmap; X,Y: integer; ATexture: IBGRAScanner; AAlign: TAlignment): TRect; overload;
     59    function DrawShadow(ADest: TBGRACustomBitmap; X,Y,Radius: integer; AColor: TBGRAPixel): TRect; overload;
     60    function DrawShadow(ADest: TBGRACustomBitmap; X,Y,Radius: integer; AColor: TBGRAPixel; AAlign: TAlignment): TRect; overload;
    6161    destructor Destroy; override;
    6262    property TextMask: TBGRACustomBitmap read FTextMask;
     
    417417  else
    418418    FTextMask := AMask;
     419  FShadowQuality:= rbFast;
    419420end;
    420421
  • GraphicTest/Packages/bgrabitmap/bgradefaultbitmap.pas

    r494 r521  
    3434uses
    3535  SysUtils, Classes, Types, FPImage, BGRAGraphics, BGRABitmapTypes, FPImgCanv,
    36   BGRACanvas, BGRACanvas2D, BGRAArrow, BGRAPen, BGRATransform;
     36  BGRACanvas, BGRACanvas2D, BGRAArrow, BGRAPen, BGRATransform, BGRATextBidi;
    3737
    3838type
     
    5959      gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode;
    6060      gammaColorCorrection: boolean = True; Sinus: Boolean=False;
    61       ditherAlgo: TDitheringAlgorithm = daFloydSteinberg);
     61      ditherAlgo: TDitheringAlgorithm = daFloydSteinberg); overload;
    6262    procedure GradientFillDithered(x, y, x2, y2: integer; gradient: TBGRACustomGradient;
    6363      gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode;
    6464      Sinus: Boolean=False;
    65       ditherAlgo: TDitheringAlgorithm = daFloydSteinberg);
     65      ditherAlgo: TDitheringAlgorithm = daFloydSteinberg); overload;
    6666  protected
    6767    FRefCount: integer; //reference counter (not related to interface reference counter)
     
    152152    function SimpleStretch(NewWidth, NewHeight: integer): TBGRACustomBitmap;
    153153    function CheckEmpty: boolean; override;
     154    function CheckIsZero: boolean; override;
    154155    function GetHasTransparentPixels: boolean; override;
     156    function GetHasSemiTransparentPixels: boolean; override;
    155157    function GetAverageColor: TColor; override;
    156158    function GetAveragePixel: TBGRAPixel; override;
     
    190192    procedure SetFontRenderer(AValue: TBGRACustomFontRenderer); override;
    191193    function CreateDefaultFontRenderer: TBGRACustomFontRenderer; virtual; abstract;
    192     function GetFontAnchorVerticalOffset: single;
    193     function GetFontAnchorRotatedOffset: TPointF;
    194     function GetFontAnchorRotatedOffset(ACustomOrientation: integer): TPointF;
     194    function GetFontVerticalAnchorOffset: single; override;
     195    function GetFontAnchorRotatedOffset: TPointF; overload;
     196    function GetFontAnchorRotatedOffset(ACustomOrientation: integer): TPointF; overload;
    195197
    196198    function GetClipRect: TRect; override;
     
    201203    function GetArrow: TBGRAArrow;
    202204    procedure InternalTextOutCurved(ACursor: TBGRACustomPathCursor; sUTF8: string; AColor: TBGRAPixel; ATexture: IBGRAScanner; AAlign: TAlignment; ALetterSpacing: single);
     205    procedure InternalCrossFade(ARect: TRect; Source1, Source2: IBGRAScanner; AFadePos: byte; AFadeMask: IBGRAScanner; mode: TDrawMode = dmDrawWithTransparency);
    203206
    204207    function CheckClippedRectBounds(var x,y,x2,y2: integer): boolean;
     
    227230    function GetUnique: TBGRACustomBitmap;
    228231
     232    { ** Allocate xor mask }
     233    procedure NeedXorMask; override;
     234
     235    { ** Free reference to xor mask }
     236    procedure DiscardXorMask; override;
     237
    229238    {==== Constructors ====}
    230239
    231240    {------------------------- Constructors from TFPCustomImage----------------}
    232241    {** Creates a new bitmap, initialize properties and bitmap data }
    233     constructor Create(AWidth, AHeight: integer); override;
     242    constructor Create(AWidth, AHeight: integer); overload; override;
    234243    {** Can only be called with an existing instance of ''TBGRABitmap''.
    235244        Sets the dimensions of an existing ''TBGRABitmap'' instance. }
     
    239248    {** Creates an image of width and height equal to zero. In this case,
    240249        ''Data'' = '''nil''' }
    241     constructor Create; override;
     250    constructor Create; overload; override;
    242251    {** Creates an image by copying the content of a ''TFPCustomImage'' }
    243     constructor Create(AFPImage: TFPCustomImage); override;
     252    constructor Create(AFPImage: TFPCustomImage); overload; override;
    244253    {** Creates an image by copying the content of a ''TBitmap'' }
    245     constructor Create(ABitmap: TBitmap; AUseTransparent: boolean = true); override;
     254    constructor Create(ABitmap: TBitmap; AUseTransparent: boolean = true); overload; override;
    246255    {** Creates an image of dimensions ''AWidth'' and ''AHeight'' and fills it with the opaque color ''Color'' }
    247     constructor Create(AWidth, AHeight: integer; Color: TColor); override;
     256    constructor Create(AWidth, AHeight: integer; Color: TColor); overload; override;
    248257    {** Creates an image of dimensions ''AWidth'' and ''AHeight'' and fills it with ''Color'' }
    249     constructor Create(AWidth, AHeight: integer; Color: TBGRAPixel); override;
     258    constructor Create(AWidth, AHeight: integer; Color: TBGRAPixel); overload; override;
    250259
    251260    {** Creates an image by loading its content from the file ''AFilename''.
    252261        The encoding of the string is the default one for the operating system.
    253262        It is recommended to use the next constructor and UTF8 encoding }
    254     constructor Create(AFilename: string); override;
     263    constructor Create(AFilename: string); overload; override;
    255264
    256265    {** Creates an image by loading its content from the file ''AFilename''.
    257266        The boolean ''AIsUtf8Filename'' specifies if UTF8 encoding is assumed
    258267        for the filename }
    259     constructor Create(AFilename: string; AIsUtf8: boolean); override;
    260     constructor Create(AFilename: string; AIsUtf8: boolean; AOptions: TBGRALoadingOptions); override;
     268    constructor Create(AFilename: string; AIsUtf8: boolean); overload; override;
     269    constructor Create(AFilename: string; AIsUtf8: boolean; AOptions: TBGRALoadingOptions); overload; override;
    261270
    262271    {** Creates an image by loading its content from the stream ''AStream'' }
    263     constructor Create(AStream: TStream); override;
     272    constructor Create(AStream: TStream); overload; override;
    264273    {** Free the object and all its resources }
    265274    destructor Destroy; override;
     
    269278        Creates a new instance with dimensions ''AWidth'' and ''AHeight'',
    270279        containing transparent pixels. }
    271     function NewBitmap(AWidth, AHeight: integer): TBGRACustomBitmap; override;
     280    function NewBitmap(AWidth, AHeight: integer): TBGRACustomBitmap; overload; override;
    272281
    273282    {** Can only be called from an existing instance of ''TBGRABitmap''.
    274283        Creates a new instance with dimensions ''AWidth'' and ''AHeight'',
    275284        and fills it with Color }
    276     function NewBitmap(AWidth, AHeight: integer; Color: TBGRAPixel): TBGRACustomBitmap; override;
     285    function NewBitmap(AWidth, AHeight: integer; Color: TBGRAPixel): TBGRACustomBitmap; overload; override;
    277286
    278287    {** Can only be called from an existing instance of ''TBGRABitmap''.
     
    280289        from the file ''Filename''. The encoding of the string
    281290        is the default one for the operating system }
    282     function NewBitmap(Filename: string): TBGRACustomBitmap; override;
     291    function NewBitmap(Filename: string): TBGRACustomBitmap; overload; override;
    283292
    284293    {** Can only be called from an existing instance of ''TBGRABitmap''.
    285294        Creates a new instance with by loading its content
    286295        from the file ''Filename'' }
    287     function NewBitmap(Filename: string; AIsUtf8: boolean): TBGRACustomBitmap; override;
    288     function NewBitmap(Filename: string; AIsUtf8: boolean; AOptions: TBGRALoadingOptions): TBGRACustomBitmap; override;
     296    function NewBitmap(Filename: string; AIsUtf8: boolean): TBGRACustomBitmap; overload; override;
     297    function NewBitmap(Filename: string; AIsUtf8: boolean; AOptions: TBGRALoadingOptions): TBGRACustomBitmap; overload; override;
    289298
    290299    {** Can only be called from an existing instance of ''TBGRABitmap''.
    291300        Creates an image by copying the content of a ''TFPCustomImage'' }
    292     function NewBitmap(AFPImage: TFPCustomImage): TBGRACustomBitmap; override;
     301    function NewBitmap(AFPImage: TFPCustomImage): TBGRACustomBitmap; overload; override;
    293302
    294303    {** Load image from a stream. The specified image reader is used }
    295     procedure LoadFromStream(Str: TStream; Handler: TFPCustomImageReader; AOptions: TBGRALoadingOptions); override;
     304    procedure LoadFromStream(Str: TStream; Handler: TFPCustomImageReader; AOptions: TBGRALoadingOptions); overload; override;
     305
     306    {** Load image from an embedded Lazarus resource. Format is detected automatically }
     307    procedure LoadFromResource(AFilename: string; AOptions: TBGRALoadingOptions); overload; override;
    296308
    297309    {** Assign the content of the specified ''Source''. It can be a ''TBGRACustomBitmap'' or
    298310        a ''TFPCustomImage'' }
    299     procedure Assign(Source: TPersistent); override;
     311    procedure Assign(Source: TPersistent); overload; override;
    300312    procedure Assign(Source: TBitmap; AUseTransparent: boolean); overload;
    301313    {** Stores the image in the stream without compression nor header }
     
    322334    {** Sets the pixel by replacing the content at (''x'',''y'') with the specified color.
    323335        Alpha value is set to 255 (opaque) }
    324     procedure SetPixel(x, y: int32or64; c: TColor); override;
     336    procedure SetPixel(x, y: int32or64; c: TColor); overload; override;
    325337    {** Sets the pixel at (''x'',''y'') with the specified content }
    326     procedure SetPixel(x, y: int32or64; c: TBGRAPixel); override;
     338    procedure SetPixel(x, y: int32or64; c: TBGRAPixel); overload; override;
    327339    {** Applies a logical '''xor''' to the content of the pixel with the specified value.
    328340        This includes the alpha channel, so if you want to preserve the opacity, provide
     
    371383      * ''AResampleFilter'' specifies how pixels must be interpolated. Accepted
    372384        values are ''rfBox'', ''rfLinear'', ''rfHalfCosine'' and ''rfCosine'' }
    373     function GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; override;
     385    function GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; overload; override;
    374386    {** Similar to previous ''GetPixel'' function, but the fractional part of
    375387        the coordinate is supplied with a number from 0 to 255. The actual
    376388        coordinate is (''x'' + ''fracX256''/256, ''y'' + ''fracY256''/256) }
    377     function GetPixelCycle256(x, y, fracX256,fracY256: int32or64; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; override;
     389    function GetPixelCycle256(x, y, fracX256,fracY256: int32or64; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; overload; override;
    378390    {** Computes the value of the pixel at a floating point coordiante
    379391        by interpolating the values of the pixels around it. ''repeatX'' and
     
    381393      * ''AResampleFilter'' specifies how pixels must be interpolated. Accepted
    382394        values are ''rfBox'', ''rfLinear'', ''rfHalfCosine'' and ''rfCosine'' }
    383     function GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter; repeatX: boolean; repeatY: boolean): TBGRAPixel; override;
     395    function GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter; repeatX: boolean; repeatY: boolean): TBGRAPixel; overload; override;
    384396    {** Similar to previous ''GetPixel'' function, but the fractional part of
    385397        the coordinate is supplied with a number from 0 to 255. The actual
    386398        coordinate is (''x'' + ''fracX256''/256, ''y'' + ''fracY256''/256) }
    387     function GetPixelCycle256(x, y, fracX256,fracY256: int32or64; AResampleFilter: TResampleFilter; repeatX: boolean; repeatY: boolean): TBGRAPixel; override;
     399    function GetPixelCycle256(x, y, fracX256,fracY256: int32or64; AResampleFilter: TResampleFilter; repeatX: boolean; repeatY: boolean): TBGRAPixel; overload; override;
    388400
    389401    {==== Drawing lines and polylines (integer coordinates) ====}
     
    452464    {** Draws an antialiased line from (x1,y1) to (x2,y2) using an improved version of Bresenham's algorithm
    453465        ''c'' specifies the color. ''DrawLastPixel'' specifies if (x2,y2) must be drawn }
    454     procedure DrawLineAntialias(x1, y1, x2, y2: integer; c: TBGRAPixel; DrawLastPixel: boolean); override;
     466    procedure DrawLineAntialias(x1, y1, x2, y2: integer; c: TBGRAPixel; DrawLastPixel: boolean); overload; override;
    455467    {** Draws an antialiased line with two colors ''c1'' and ''c2'' as dashes of lenght ''dashLen'' }
    456     procedure DrawLineAntialias(x1, y1, x2, y2: integer; c1, c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean); override;
     468    procedure DrawLineAntialias(x1, y1, x2, y2: integer; c1, c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean); overload; override;
    457469    {** Draws an antialiased line with two colors ''c1'' and ''c2'' as dashes of lenght ''dashLen''.
    458470        ''DashPos'' can be used to specify the start dash position and to retrieve the dash position at the end
     
    477489
    478490    {** Draws a line from (x1,y1) to (x2,y2) using current pen style/cap/join }
    479     procedure DrawLineAntialias(x1, y1, x2, y2: single; c: TBGRAPixel; w: single); override;
     491    procedure DrawLineAntialias(x1, y1, x2, y2: single; c: TBGRAPixel; w: single); overload; override;
    480492    {** Draws a line from (x1,y1) to (x2,y2) using current pen style/cap/join.
    481493        ''texture'' specifies the source color to use when filling the line }
    482     procedure DrawLineAntialias(x1, y1, x2, y2: single; texture: IBGRAScanner; w: single); override;
     494    procedure DrawLineAntialias(x1, y1, x2, y2: single; texture: IBGRAScanner; w: single); overload; override;
    483495    {** Draws a line from (x1,y1) to (x2,y2) using current pen style/cap/join.
    484496        ''Closed'' specifies if the end of the line is closed. If it is not closed,
    485497        a space is left so that the next line can fit }
    486     procedure DrawLineAntialias(x1, y1, x2, y2: single; c: TBGRAPixel; w: single; ClosedCap: boolean); override;
     498    procedure DrawLineAntialias(x1, y1, x2, y2: single; c: TBGRAPixel; w: single; ClosedCap: boolean); overload; override;
    487499    {** Same as above with ''texture'' specifying the source color to use when filling the line }
    488     procedure DrawLineAntialias(x1, y1, x2, y2: single; texture: IBGRAScanner; w: single; ClosedCap: boolean); override;
     500    procedure DrawLineAntialias(x1, y1, x2, y2: single; texture: IBGRAScanner; w: single; ClosedCap: boolean); overload; override;
    489501
    490502    {** Draws a polyline using current pen style/cap/join }
    491     procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single); override;
     503    procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single); overload; override;
    492504    {** Draws a polyline using current pen style/cap/join.
    493505        ''texture'' specifies the source color to use when filling the line }
    494     procedure DrawPolyLineAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single); override;
     506    procedure DrawPolyLineAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single); overload; override;
    495507    {** Draws a polyline using current pen style/cap/join.
    496508        ''Closed'' specifies if the end of the line is closed. If it is not closed,
    497509        a space is left so that the next line can fit }
    498     procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single; ClosedCap: boolean); override;
    499     procedure DrawPolyLineAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single; ClosedCap: boolean); override;
     510    procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single; ClosedCap: boolean); overload; override;
     511    procedure DrawPolyLineAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single; ClosedCap: boolean); overload; override;
    500512    {** Draws a polyline using current pen style/cap/join.
    501513        ''fillcolor'' specifies a color to fill the polygon formed by the points }
    502     procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single; fillcolor: TBGRAPixel); override;
     514    procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single; fillcolor: TBGRAPixel); overload; override;
    503515    {** Draws a polyline using current pen style/cap/join.
    504516        The last point considered as a join with the first point if it has
     
    509521        The polygon is always closed. You don't need to set the last point
    510522        to be the same as the first point }
    511     procedure DrawPolygonAntialias(const points: array of TPointF; c: TBGRAPixel; w: single); override;
     523    procedure DrawPolygonAntialias(const points: array of TPointF; c: TBGRAPixel; w: single); overload; override;
    512524    {** Draws a polygon using current pen style/cap/join.
    513525        The polygon is always closed. You don't need to set the last point
    514526        to be the same as the first point }
    515     procedure DrawPolygonAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single); override;
     527    procedure DrawPolygonAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single); overload; override;
    516528    {** Draws a filled polygon using current pen style/cap/join.
    517529        The polygon is always closed. You don't need to set the last point
    518530        to be the same as the first point. }
    519     procedure DrawPolygonAntialias(const points: array of TPointF; c: TBGRAPixel; w: single; fillcolor: TBGRAPixel); override;
     531    procedure DrawPolygonAntialias(const points: array of TPointF; c: TBGRAPixel; w: single; fillcolor: TBGRAPixel); overload; override;
    520532
    521533    {** Erases a line from (x1,y1) to (x2,y2) using current pen style/cap/join }
     
    538550    {** Draw a size border of a rectangle,
    539551        using the specified ''mode'' }
    540     procedure Rectangle(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); override;
     552    procedure Rectangle(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); overload; override;
    541553    {** Draw a filled rectangle with a border of color ''BorderColor'',
    542554        using the specified ''mode'' }
    543     procedure Rectangle(x, y, x2, y2: integer; BorderColor, FillColor: TBGRAPixel; mode: TDrawMode); override;
     555    procedure Rectangle(x, y, x2, y2: integer; BorderColor, FillColor: TBGRAPixel; mode: TDrawMode); overload; override;
    544556    {** Fills completely a rectangle, without any border, with the specified ''mode'' }
    545     procedure FillRect(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); override; overload;
     557    procedure FillRect(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); overload; override;
    546558    {** Fills completely a rectangle, without any border, with the specified ''texture'' and
    547559        with the specified ''mode'' }
    548     procedure FillRect(x, y, x2, y2: integer; texture: IBGRAScanner; mode: TDrawMode; AScanOffset: TPoint); override; overload;
    549     procedure FillRect(x, y, x2, y2: integer; texture: IBGRAScanner; mode: TDrawMode; AScanOffset: TPoint; ditheringAlgorithm: TDitheringAlgorithm); override; overload;
     560    procedure FillRect(x, y, x2, y2: integer; texture: IBGRAScanner; mode: TDrawMode; AScanOffset: TPoint); overload; override;
     561    procedure FillRect(x, y, x2, y2: integer; texture: IBGRAScanner; mode: TDrawMode; AScanOffset: TPoint; ditheringAlgorithm: TDitheringAlgorithm); overload; override;
    550562    {** Sets the alpha value within the specified rectangle }
    551563    procedure AlphaFillRect(x, y, x2, y2: integer; alpha: byte); override;
     
    554566    {** Draws a round rectangle, with corners having an elliptical diameter of ''DX'' and ''DY'' }
    555567    procedure RoundRect(X1, Y1, X2, Y2: integer; DX, DY: integer; BorderColor: TBGRAPixel; ADrawMode: TDrawMode = dmDrawWithTransparency); override;
     568    procedure FillRoundRect(X1, Y1, X2, Y2: integer; DX, DY: integer; FillTexture: IBGRAScanner; ADrawMode: TDrawMode = dmDrawWithTransparency); override; overload;
    556569
    557570    {==== Rectangles and ellipses (floating point coordinates) ====}
     
    572585    {** Fills a rectangle with antialiasing. For example (-0.5,-0.5,0.5,0.5)
    573586        fills one pixel }
    574     procedure FillRectAntialias(x, y, x2, y2: single; c: TBGRAPixel; pixelCenteredCoordinates: boolean = true); override;
     587    procedure FillRectAntialias(x, y, x2, y2: single; c: TBGRAPixel; pixelCenteredCoordinates: boolean = true); overload; override;
    575588    {** Fills a rectangle with a texture }
    576     procedure FillRectAntialias(x, y, x2, y2: single; texture: IBGRAScanner; pixelCenteredCoordinates: boolean = true); override;
     589    procedure FillRectAntialias(x, y, x2, y2: single; texture: IBGRAScanner; pixelCenteredCoordinates: boolean = true); overload; override;
    577590    {** Erases the content of a rectangle with antialiasing }
    578591    procedure EraseRectAntialias(x, y, x2, y2: single; alpha: byte; pixelCenteredCoordinates: boolean = true); override;
     
    581594        elliptical radius of ''rx'' and ''ry''. ''options'' specifies how to
    582595        draw the corners. See [[BGRABitmap Geometry types|geometry types]] }
    583     procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; c: TBGRAPixel; w: single; options: TRoundRectangleOptions = []); override;
     596    procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; c: TBGRAPixel; w: single; options: TRoundRectangleOptions = []); overload; override;
    584597    {** Draws a rounded rectangle border with the specified texture.
    585598        The corners have an elliptical radius of ''rx'' and ''ry''.
    586599        ''options'' specifies how to draw the corners.
    587600        See [[BGRABitmap Geometry types|geometry types]] }
    588     procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; texture: IBGRAScanner; w: single; options: TRoundRectangleOptions = []); override;
     601    procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; texture: IBGRAScanner; w: single; options: TRoundRectangleOptions = []); overload; override;
    589602    {** Draws and fills a round rectangle }
    590     procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; pencolor: TBGRAPixel; w: single; fillcolor: TBGRAPixel; options: TRoundRectangleOptions = []); override;
     603    procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; pencolor: TBGRAPixel; w: single; fillcolor: TBGRAPixel; options: TRoundRectangleOptions = []); overload; override;
    591604    {** Draws and fills a round rectangle with textures }
    592     procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; penTexture: IBGRAScanner; w: single; fillTexture: IBGRAScanner; options: TRoundRectangleOptions = []); override;
     605    procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; penTexture: IBGRAScanner; w: single; fillTexture: IBGRAScanner; options: TRoundRectangleOptions = []); overload; override;
    593606
    594607    {** Fills a rounded rectangle with antialiasing. The corners have an
    595608        elliptical radius of ''rx'' and ''ry''. ''options'' specifies how to
    596609        draw the corners. See [[BGRABitmap Geometry types|geometry types]] }
    597     procedure FillRoundRectAntialias(x,y,x2,y2,rx,ry: single; c: TBGRAPixel; options: TRoundRectangleOptions = []; pixelCenteredCoordinates: boolean = true); override;
     610    procedure FillRoundRectAntialias(x,y,x2,y2,rx,ry: single; c: TBGRAPixel; options: TRoundRectangleOptions = []; pixelCenteredCoordinates: boolean = true); overload; override;
    598611    {** Fills a rounded rectangle with a texture }
    599     procedure FillRoundRectAntialias(x,y,x2,y2,rx,ry: single; texture: IBGRAScanner; options: TRoundRectangleOptions = []; pixelCenteredCoordinates: boolean = true); override;
     612    procedure FillRoundRectAntialias(x,y,x2,y2,rx,ry: single; texture: IBGRAScanner; options: TRoundRectangleOptions = []; pixelCenteredCoordinates: boolean = true); overload; override;
    600613    {** Erases the content of a rounded rectangle with a texture }
    601     procedure EraseRoundRectAntialias(x,y,x2,y2,rx,ry: single; alpha: byte; options: TRoundRectangleOptions = []; pixelCenteredCoordinates: boolean = true); override;
    602 
     614    procedure EraseRoundRectAntialias(x,y,x2,y2,rx,ry: single; alpha: byte; options: TRoundRectangleOptions = []; pixelCenteredCoordinates: boolean = true); overload; override;
     615
     616    {** Draws an ellipse without antialising. ''rx'' is the horizontal radius and
     617        ''ry'' the vertical radius }
     618    procedure Ellipse(x, y, rx, ry: single; c: TBGRAPixel; w: single; ADrawMode: TDrawMode); overload; override;
     619    procedure Ellipse(AOrigin, AXAxis, AYAxis: TPointF; c: TBGRAPixel; w: single; ADrawMode: TDrawMode); overload; override;
    603620    {** Draws an ellipse with antialising. ''rx'' is the horizontal radius and
    604621        ''ry'' the vertical radius }
    605     procedure EllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel; w: single); override;
     622    procedure EllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel; w: single); overload; override;
     623    procedure EllipseAntialias(AOrigin, AXAxis, AYAxis: TPointF; c: TBGRAPixel; w: single); overload; override;
    606624    {** Draws an ellipse border with a ''texture'' }
    607     procedure EllipseAntialias(x, y, rx, ry: single; texture: IBGRAScanner; w: single); override;
     625    procedure EllipseAntialias(x, y, rx, ry: single; texture: IBGRAScanner; w: single); overload; override;
     626    procedure EllipseAntialias(AOrigin, AXAxis, AYAxis: TPointF; texture: IBGRAScanner; w: single); overload; override;
    608627    {** Draws and fills an ellipse }
    609     procedure EllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel; w: single; back: TBGRAPixel); override;
     628    procedure EllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel; w: single; back: TBGRAPixel); overload; override;
     629    procedure EllipseAntialias(AOrigin, AXAxis, AYAxis: TPointF; c: TBGRAPixel; w: single; back: TBGRAPixel); overload; override;
    610630    {** Fills an ellipse }
    611     procedure FillEllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel); override;
     631    procedure FillEllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel); overload; override;
     632    procedure FillEllipseAntialias(AOrigin, AXAxis, AYAxis: TPointF; c: TBGRAPixel); overload; override;
    612633    {** Fills an ellipse with a ''texture'' }
    613     procedure FillEllipseAntialias(x, y, rx, ry: single; texture: IBGRAScanner); override;
     634    procedure FillEllipseAntialias(x, y, rx, ry: single; texture: IBGRAScanner); overload; override;
     635    procedure FillEllipseAntialias(AOrigin, AXAxis, AYAxis: TPointF; texture: IBGRAScanner); overload; override;
    614636    {** Fills an ellipse with a gradient of color. ''outercolor'' specifies
    615637        the end color of the gradient on the border of the ellipse and
    616638        ''innercolor'' the end color of the gradient at the center of the
    617639        ellipse }
    618     procedure FillEllipseLinearColorAntialias(x, y, rx, ry: single; outercolor, innercolor: TBGRAPixel); override;
     640    procedure FillEllipseLinearColorAntialias(x, y, rx, ry: single; outercolor, innercolor: TBGRAPixel); overload; override;
     641    procedure FillEllipseLinearColorAntialias(AOrigin, AXAxis, AYAxis: TPointF; outercolor, innercolor: TBGRAPixel); overload; override;
    619642    {** Erases the content of an ellipse }
    620     procedure EraseEllipseAntialias(x, y, rx, ry: single; alpha: byte); override;
     643    procedure EraseEllipseAntialias(x, y, rx, ry: single; alpha: byte); overload; override;
     644    procedure EraseEllipseAntialias(AOrigin, AXAxis, AYAxis: TPointF; alpha: byte); overload; override;
    621645
    622646    {==== Polygons and path ====}
    623     procedure FillPoly(const points: array of TPointF; c: TBGRAPixel; drawmode: TDrawMode); override;
    624     procedure FillPoly(const points: array of TPointF; texture: IBGRAScanner; drawmode: TDrawMode); override;
    625     procedure FillPolyAntialias(const points: array of TPointF; c: TBGRAPixel); override;
    626     procedure FillPolyAntialias(const points: array of TPointF; texture: IBGRAScanner); override;
    627     procedure ErasePoly(const points: array of TPointF; alpha: byte); override;
    628     procedure ErasePolyAntialias(const points: array of TPointF; alpha: byte); override;
     647    procedure FillPoly(const points: array of TPointF; c: TBGRAPixel; drawmode: TDrawMode; APixelCenteredCoordinates: boolean = true); overload; override;
     648    procedure FillPoly(const points: array of TPointF; texture: IBGRAScanner; drawmode: TDrawMode; APixelCenteredCoordinates: boolean = true); overload; override;
     649    procedure FillPolyAntialias(const points: array of TPointF; c: TBGRAPixel; APixelCenteredCoordinates: boolean = true); overload; override;
     650    procedure FillPolyAntialias(const points: array of TPointF; texture: IBGRAScanner; APixelCenteredCoordinates: boolean = true); overload; override;
     651    procedure ErasePoly(const points: array of TPointF; alpha: byte; APixelCenteredCoordinates: boolean = true); override;
     652    procedure ErasePolyAntialias(const points: array of TPointF; alpha: byte; APixelCenteredCoordinates: boolean = true); override;
    629653
    630654    procedure FillTriangleLinearColor(pt1,pt2,pt3: TPointF; c1,c2,c3: TBGRAPixel); override;
     
    652676    procedure FillPolyPerspectiveMappingLightness(const points: array of TPointF; const pointsZ: array of single; texture: IBGRAScanner; texCoords: array of TPointF; lightnesses: array of word; TextureInterpolation: Boolean; zbuffer: psingle = nil); override;
    653677
    654     procedure FillShape(shape: TBGRACustomFillInfo; c: TBGRAPixel; drawmode: TDrawMode); override;
    655     procedure FillShape(shape: TBGRACustomFillInfo; texture: IBGRAScanner; drawmode: TDrawMode); override;
    656     procedure FillShapeAntialias(shape: TBGRACustomFillInfo; c: TBGRAPixel); override;
    657     procedure FillShapeAntialias(shape: TBGRACustomFillInfo; texture: IBGRAScanner); override;
     678    procedure FillShape(shape: TBGRACustomFillInfo; c: TBGRAPixel; drawmode: TDrawMode); overload; override;
     679    procedure FillShape(shape: TBGRACustomFillInfo; texture: IBGRAScanner; drawmode: TDrawMode); overload; override;
     680    procedure FillShapeAntialias(shape: TBGRACustomFillInfo; c: TBGRAPixel); overload; override;
     681    procedure FillShapeAntialias(shape: TBGRACustomFillInfo; texture: IBGRAScanner); overload; override;
    658682    procedure EraseShape(shape: TBGRACustomFillInfo; alpha: byte); override;
    659683    procedure EraseShapeAntialias(shape: TBGRACustomFillInfo; alpha: byte); override;
    660684
    661     procedure DrawPath(APath: IBGRAPath; AStrokeColor: TBGRAPixel; AWidth: single; AFillColor: TBGRAPixel); override;
    662     procedure DrawPath(APath: IBGRAPath; AStrokeTexture: IBGRAScanner; AWidth: single; AFillColor: TBGRAPixel); override;
    663     procedure DrawPath(APath: IBGRAPath; AStrokeColor: TBGRAPixel; AWidth: single; AFillTexture: IBGRAScanner); override;
    664     procedure DrawPath(APath: IBGRAPath; AStrokeTexture: IBGRAScanner; AWidth: single; AFillTexture: IBGRAScanner); override;
    665     procedure DrawPath(APath: IBGRAPath; AStrokeColor: TBGRAPixel; AWidth: single); override;
    666     procedure DrawPath(APath: IBGRAPath; AStrokeTexture: IBGRAScanner; AWidth: single); override;
    667     procedure FillPath(APath: IBGRAPath; AFillColor: TBGRAPixel); override;
    668     procedure FillPath(APath: IBGRAPath; AFillTexture: IBGRAScanner); override;
    669     procedure ErasePath(APath: IBGRAPath; alpha: byte); override;
    670 
    671     procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeColor: TBGRAPixel; AWidth: single; AFillColor: TBGRAPixel); override;
    672     procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeTexture: IBGRAScanner; AWidth: single; AFillColor: TBGRAPixel); override;
    673     procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeColor: TBGRAPixel; AWidth: single; AFillTexture: IBGRAScanner); override;
    674     procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeTexture: IBGRAScanner; AWidth: single; AFillTexture: IBGRAScanner); override;
    675     procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeColor: TBGRAPixel; AWidth: single); override;
    676     procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeTexture: IBGRAScanner; AWidth: single); override;
    677     procedure FillPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AFillColor: TBGRAPixel); override;
    678     procedure FillPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AFillTexture: IBGRAScanner); override;
    679     procedure ErasePath(APath: IBGRAPath; AMatrix: TAffineMatrix; alpha: byte); override;
     685    procedure DrawPath(APath: IBGRAPath; AStrokeColor: TBGRAPixel; AWidth: single; AFillColor: TBGRAPixel); overload; override;
     686    procedure DrawPath(APath: IBGRAPath; AStrokeTexture: IBGRAScanner; AWidth: single; AFillColor: TBGRAPixel); overload; override;
     687    procedure DrawPath(APath: IBGRAPath; AStrokeColor: TBGRAPixel; AWidth: single; AFillTexture: IBGRAScanner); overload; override;
     688    procedure DrawPath(APath: IBGRAPath; AStrokeTexture: IBGRAScanner; AWidth: single; AFillTexture: IBGRAScanner); overload; override;
     689    procedure DrawPath(APath: IBGRAPath; AStrokeColor: TBGRAPixel; AWidth: single); overload; override;
     690    procedure DrawPath(APath: IBGRAPath; AStrokeTexture: IBGRAScanner; AWidth: single); overload; override;
     691    procedure FillPath(APath: IBGRAPath; AFillColor: TBGRAPixel); overload; override;
     692    procedure FillPath(APath: IBGRAPath; AFillTexture: IBGRAScanner); overload; override;
     693    procedure ErasePath(APath: IBGRAPath; alpha: byte); overload; override;
     694
     695    procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeColor: TBGRAPixel; AWidth: single; AFillColor: TBGRAPixel); overload; override;
     696    procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeTexture: IBGRAScanner; AWidth: single; AFillColor: TBGRAPixel); overload; override;
     697    procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeColor: TBGRAPixel; AWidth: single; AFillTexture: IBGRAScanner); overload; override;
     698    procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeTexture: IBGRAScanner; AWidth: single; AFillTexture: IBGRAScanner); overload; override;
     699    procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeColor: TBGRAPixel; AWidth: single); overload; override;
     700    procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeTexture: IBGRAScanner; AWidth: single); overload; override;
     701    procedure FillPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AFillColor: TBGRAPixel); overload; override;
     702    procedure FillPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AFillTexture: IBGRAScanner); overload; override;
     703    procedure ErasePath(APath: IBGRAPath; AMatrix: TAffineMatrix; alpha: byte); overload; override;
    680704
    681705    procedure ArrowStartAsNone; override;
     
    694718      If align is taRightJustify, (x,y) is the top-right corner.
    695719      The value of FontOrientation is taken into account, so that the text may be rotated. }
    696     procedure TextOut(x, y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment); override; overload;
     720    procedure TextOut(x, y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment; ARightToLeft: boolean); overload; override;
    697721
    698722    { Same as above functions, except that the text is filled using texture.
    699723      The value of FontOrientation is taken into account, so that the text may be rotated. }
    700     procedure TextOut(x, y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment); override; overload;
     724    procedure TextOut(x, y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment; ARightToLeft: boolean); overload; override;
    701725
    702726    { Same as above, except that the orientation is specified, overriding the value of the property FontOrientation. }
    703     procedure TextOutAngle(x, y: single; orientationTenthDegCCW: integer; sUTF8: string; c: TBGRAPixel; align: TAlignment); override; overload;
    704     procedure TextOutAngle(x, y: single; orientationTenthDegCCW: integer; sUTF8: string; texture: IBGRAScanner; align: TAlignment); override; overload;
    705 
    706     procedure TextOutCurved(ACursor: TBGRACustomPathCursor; sUTF8: string; AColor: TBGRAPixel; AAlign: TAlignment; ALetterSpacing: single); override; overload;
    707     procedure TextOutCurved(ACursor: TBGRACustomPathCursor; sUTF8: string; ATexture: IBGRAScanner; AAlign: TAlignment; ALetterSpacing: single); override; overload;
     727    procedure TextOutAngle(x, y: single; orientationTenthDegCCW: integer; sUTF8: string; c: TBGRAPixel; align: TAlignment); overload; override;
     728    procedure TextOutAngle(x, y: single; orientationTenthDegCCW: integer; sUTF8: string; texture: IBGRAScanner; align: TAlignment); overload; override;
     729
     730    procedure TextOutCurved(ACursor: TBGRACustomPathCursor; sUTF8: string; AColor: TBGRAPixel; AAlign: TAlignment; ALetterSpacing: single); overload; override;
     731    procedure TextOutCurved(ACursor: TBGRACustomPathCursor; sUTF8: string; ATexture: IBGRAScanner; AAlign: TAlignment; ALetterSpacing: single); overload; override;
     732
     733    procedure TextMultiline(ALeft,ATop,AWidth: single; sUTF8: string; c: TBGRAPixel; AAlign: TBidiTextAlignment = btaNatural; AVertAlign: TTextLayout = tlTop; AParagraphSpacing: single = 0); overload; override;
     734    procedure TextMultiline(ALeft,ATop,AWidth: single; sUTF8: string; ATexture: IBGRAScanner; AAlign: TBidiTextAlignment = btaNatural; AVertAlign: TTextLayout = tlTop; AParagraphSpacing: single = 0); overload; override;
    708735
    709736    { Draw the UTF8 encoded string at the coordinate (x,y), clipped inside the rectangle ARect.
    710737      Additional style information is provided by the style parameter.
    711738      The color c or texture is used to fill the text. No rotation is applied. }
    712     procedure TextRect(ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; c: TBGRAPixel); override; overload;
    713     procedure TextRect(ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; texture: IBGRAScanner); override; overload;
     739    procedure TextRect(ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; c: TBGRAPixel); overload; override;
     740    procedure TextRect(ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; texture: IBGRAScanner); overload; override;
    714741
    715742    { Returns the total size of the string provided using the current font.
    716       Orientation is not taken into account, so that the width is along the text. }
     743      Orientation is not taken into account, so that the width is along the text. End of lines are stripped from the string. }
    717744    function TextSize(sUTF8: string): TSize; override;
     745
     746    { Returns the affine box of the string provided using the current font.
     747      Orientation is taken into account. End of lines are stripped from the string. }
     748    function TextAffineBox(sUTF8: string): TAffineBox; override;
     749
     750    { Returns the total size of a paragraph i.e. with word break }
     751    function TextSize(sUTF8: string; AMaxWidth: integer): TSize; override;
     752    function TextSize(sUTF8: string; AMaxWidth: integer; ARightToLeft: boolean): TSize; override;
     753    function TextFitInfo(sUTF8: string; AMaxWidth: integer): integer; override;
    718754
    719755    {Spline}
     
    721757    function ComputeOpenedSpline(const APoints: array of TPointF; AStyle: TSplineStyle): ArrayOfTPointF; override;
    722758
    723     function ComputeBezierCurve(const ACurve: TCubicBezierCurve): ArrayOfTPointF; override;
    724     function ComputeBezierCurve(const ACurve: TQuadraticBezierCurve): ArrayOfTPointF; override;
    725     function ComputeBezierSpline(const ASpline: array of TCubicBezierCurve): ArrayOfTPointF; override;
    726     function ComputeBezierSpline(const ASpline: array of TQuadraticBezierCurve): ArrayOfTPointF; override;
    727 
    728     function ComputeWidePolyline(const points: array of TPointF; w: single): ArrayOfTPointF; override;
    729     function ComputeWidePolyline(const points: array of TPointF; w: single; ClosedCap: boolean): ArrayOfTPointF; override;
    730     function ComputeWidePolygon(const points: array of TPointF; w: single): ArrayOfTPointF; override;
    731 
    732     function ComputeEllipseContour(x,y,rx,ry: single; quality: single = 1): ArrayOfTPointF; override;
    733     function ComputeEllipseBorder(x,y,rx,ry,w: single; quality: single = 1): ArrayOfTPointF; override;
     759    function ComputeBezierCurve(const ACurve: TCubicBezierCurve): ArrayOfTPointF; overload; override;
     760    function ComputeBezierCurve(const ACurve: TQuadraticBezierCurve): ArrayOfTPointF; overload; override;
     761    function ComputeBezierSpline(const ASpline: array of TCubicBezierCurve): ArrayOfTPointF; overload; override;
     762    function ComputeBezierSpline(const ASpline: array of TQuadraticBezierCurve): ArrayOfTPointF; overload; override;
     763
     764    function ComputeWidePolyline(const points: array of TPointF; w: single): ArrayOfTPointF; overload; override;
     765    function ComputeWidePolyline(const points: array of TPointF; w: single; ClosedCap: boolean): ArrayOfTPointF; overload; override;
     766    function ComputeWidePolygon(const points: array of TPointF; w: single): ArrayOfTPointF; overload; override;
     767
     768    function ComputeEllipseContour(x,y,rx,ry: single; quality: single = 1): ArrayOfTPointF;  overload; override;
     769    function ComputeEllipseContour(AOrigin, AXAxis, AYAxis: TPointF; quality: single = 1): ArrayOfTPointF;  overload; override;
     770    function ComputeEllipseBorder(x,y,rx,ry,w: single; quality: single = 1): ArrayOfTPointF; overload; override;
     771    function ComputeEllipseBorder(AOrigin, AXAxis, AYAxis: TPointF; w: single; quality: single = 1): ArrayOfTPointF; override; overload;
    734772    function ComputeArc65536(x,y,rx,ry: single; start65536,end65536: word; quality: single = 1): ArrayOfTPointF; override;
    735773    function ComputeArcRad(x,y,rx,ry: single; startRad,endRad: single; quality: single = 1): ArrayOfTPointF; override;
    736     function ComputeRoundRect(x1,y1,x2,y2,rx,ry: single; quality: single = 1): ArrayOfTPointF; override;
    737     function ComputeRoundRect(x1,y1,x2,y2,rx,ry: single; options: TRoundRectangleOptions; quality: single = 1): ArrayOfTPointF; override;
     774    function ComputeRoundRect(x1,y1,x2,y2,rx,ry: single; quality: single = 1): ArrayOfTPointF; overload; override;
     775    function ComputeRoundRect(x1,y1,x2,y2,rx,ry: single; options: TRoundRectangleOptions; quality: single = 1): ArrayOfTPointF; overload; override;
    738776    function ComputePie65536(x,y,rx,ry: single; start65536,end65536: word; quality: single = 1): ArrayOfTPointF; override;
    739777    function ComputePieRad(x,y,rx,ry: single; startRad,endRad: single; quality: single = 1): ArrayOfTPointF; override;
     
    741779    {Filling}
    742780    procedure NoClip; override;
    743     procedure Fill(texture: IBGRAScanner; mode: TDrawMode); override;
    744     procedure Fill(texture: IBGRAScanner); override;
    745     procedure Fill(c: TBGRAPixel; start, Count: integer); override;
     781    procedure Fill(texture: IBGRAScanner; mode: TDrawMode); overload; override;
     782    procedure Fill(texture: IBGRAScanner); overload; override;
     783    procedure Fill(c: TBGRAPixel; start, Count: integer); overload; override;
    746784    procedure DrawPixels(c: TBGRAPixel; start, Count: integer); override;
    747785    procedure AlphaFill(alpha: byte; start, Count: integer); override;
    748786    procedure FillMask(x,y: integer; AMask: TBGRACustomBitmap; color: TBGRAPixel; ADrawMode: TDrawMode); override;
    749787    procedure FillMask(x,y: integer; AMask: TBGRACustomBitmap; texture: IBGRAScanner; ADrawMode: TDrawMode; AOpacity: byte = 255); override;
     788    procedure EraseMask(x,y: integer; AMask: TBGRACustomBitmap; alpha: byte=255); override;
    750789    procedure FillClearTypeMask(x,y: integer; xThird: integer; AMask: TBGRACustomBitmap; color: TBGRAPixel; ARGBOrder: boolean = true); override;
    751790    procedure FillClearTypeMask(x,y: integer; xThird: integer; AMask: TBGRACustomBitmap; texture: IBGRAScanner; ARGBOrder: boolean = true); override;
     
    775814
    776815    {Canvas drawing functions}
    777     procedure Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean = True); override;
    778     procedure Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean = True); override;
     816    procedure Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean = True); overload; override;
     817    procedure Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean = True); overload; override;
    779818    procedure InvalidateBitmap; override;         //call if you modify with Scanline
    780819    procedure LoadFromBitmapIfNeeded; override;   //call to ensure that bitmap data is up to date
    781820
    782821    {BGRA bitmap functions}
    783     procedure CrossFade(ARect: TRect; Source1, Source2: IBGRAScanner; AFadePosition: byte; mode: TDrawMode = dmDrawWithTransparency); override;
    784     procedure CrossFade(ARect: TRect; Source1, Source2: IBGRAScanner; AFadeMask: IBGRAScanner; mode: TDrawMode = dmDrawWithTransparency); override;
    785     procedure PutImage(x, y: integer; Source: TBGRACustomBitmap; mode: TDrawMode; AOpacity: byte = 255); override;
    786     procedure PutImageAffine(AMatrix: TAffineMatrix; Source: TBGRACustomBitmap; AOutputBounds: TRect; AResampleFilter: TResampleFilter; AMode: TDrawMode; AOpacity: Byte=255); override; overload;
    787     function GetImageAffineBounds(AMatrix: TAffineMatrix; ASourceBounds: TRect; AClipOutput: boolean = true): TRect; override; overload;
    788     function IsAffineRoughlyTranslation(AMatrix: TAffineMatrix; ASourceBounds: TRect): boolean; override;
     822    procedure CrossFade(ARect: TRect; Source1, Source2: IBGRAScanner; AFadePosition: byte; mode: TDrawMode = dmDrawWithTransparency); overload; override;
     823    procedure CrossFade(ARect: TRect; Source1, Source2: IBGRAScanner; AFadeMask: IBGRAScanner; mode: TDrawMode = dmDrawWithTransparency); overload; override;
     824    procedure PutImage(x, y: integer; Source: TBGRACustomBitmap; mode: TDrawMode; AOpacity: byte = 255); overload; override;
     825    procedure PutImageAffine(AMatrix: TAffineMatrix; Source: TBGRACustomBitmap; AOutputBounds: TRect; AResampleFilter: TResampleFilter; AMode: TDrawMode; AOpacity: Byte=255); overload; override;
     826    function GetImageAffineBounds(AMatrix: TAffineMatrix; ASourceBounds: TRect; AClipOutput: boolean = true): TRect; overload; override;
     827    class function IsAffineRoughlyTranslation(AMatrix: TAffineMatrix; ASourceBounds: TRect): boolean; override;
    789828
    790829    procedure StretchPutImage(ARect: TRect; Source: TBGRACustomBitmap; mode: TDrawMode; AOpacity: byte = 255); override;
     
    796835    function GetPart(ARect: TRect): TBGRACustomBitmap; override;
    797836    function GetPtrBitmap(Top,Bottom: Integer): TBGRACustomBitmap; override;
    798     function Duplicate(DuplicateProperties: Boolean = False) : TBGRACustomBitmap; override;
     837    function Duplicate(DuplicateProperties: Boolean = False; DuplicateXorMask: Boolean = False) : TBGRACustomBitmap; override;
    799838    procedure CopyPropertiesTo(ABitmap: TBGRADefaultBitmap);
    800     function Equals(comp: TBGRACustomBitmap): boolean; override;
    801     function Equals(comp: TBGRAPixel): boolean; override;
     839    function Equals(comp: TBGRACustomBitmap): boolean; overload; override;
     840    function Equals(comp: TBGRAPixel): boolean; overload; override;
    802841    function GetDifferenceBounds(ABitmap: TBGRACustomBitmap): TRect; override;
    803842    function MakeBitmapCopy(BackgroundColor: TColor): TBitmap; override;
     
    805844    function Resample(newWidth, newHeight: integer;
    806845      mode: TResampleMode = rmFineResample): TBGRACustomBitmap; override;
    807     procedure VerticalFlip(ARect: TRect); override; overload;
    808     procedure HorizontalFlip(ARect: TRect); override; overload;
     846    procedure VerticalFlip(ARect: TRect); overload; override;
     847    procedure HorizontalFlip(ARect: TRect); overload; override;
    809848    function RotateCW: TBGRACustomBitmap; override;
    810849    function RotateCCW: TBGRACustomBitmap; override;
     
    813852    procedure LinearNegative; override;
    814853    procedure LinearNegativeRect(ABounds: TRect); override;
    815     procedure InplaceGrayscale(AGammaCorrection: boolean = true); override;
    816     procedure InplaceGrayscale(ABounds: TRect; AGammaCorrection: boolean = true); override;
    817     procedure InplaceNormalize(AEachChannel: boolean = True); override;
    818     procedure InplaceNormalize(ABounds: TRect; AEachChannel: boolean = True); override;
     854    procedure InplaceGrayscale(AGammaCorrection: boolean = true); overload; override;
     855    procedure InplaceGrayscale(ABounds: TRect; AGammaCorrection: boolean = true); overload; override;
     856    procedure InplaceNormalize(AEachChannel: boolean = True); overload; override;
     857    procedure InplaceNormalize(ABounds: TRect; AEachChannel: boolean = True); overload; override;
    819858    procedure SwapRedBlue; override;
    820859    procedure SwapRedBlue(ARect: TRect); override;
    821860    procedure GrayscaleToAlpha; override;
    822861    procedure AlphaToGrayscale; override;
    823     procedure ApplyMask(mask: TBGRACustomBitmap; ARect: TRect; AMaskRectTopLeft: TPoint); override; overload;
     862    procedure ApplyMask(mask: TBGRACustomBitmap; ARect: TRect; AMaskRectTopLeft: TPoint); overload; override;
     863    function GetMaskFromAlpha: TBGRACustomBitmap; override;
    824864    procedure ApplyGlobalOpacity(alpha: byte); override;
    825865    procedure ApplyGlobalOpacity(ABounds: TRect; alpha: byte); override;
    826866    procedure ConvertToLinearRGB; override;
    827867    procedure ConvertFromLinearRGB; override;
    828     procedure DrawCheckers(ARect: TRect; AColorEven,AColorOdd: TBGRAPixel);
     868    procedure DrawCheckers(ARect: TRect; AColorEven,AColorOdd: TBGRAPixel); override;
    829869
    830870    {Filters}
     
    832872    function FilterMedian(Option: TMedianOption): TBGRACustomBitmap; override;
    833873    function FilterSmooth: TBGRACustomBitmap; override;
    834     function FilterSharpen(Amount: single = 1): TBGRACustomBitmap; override;
    835     function FilterSharpen(ABounds: TRect; Amount: single = 1): TBGRACustomBitmap; override;
     874    function FilterSharpen(Amount: single = 1): TBGRACustomBitmap; overload; override;
     875    function FilterSharpen(ABounds: TRect; Amount: single = 1): TBGRACustomBitmap; overload; override;
    836876    function FilterContour: TBGRACustomBitmap; override;
    837877    function FilterPixelate(pixelSize: integer; useResample: boolean; filter: TResampleFilter = rfLinear): TBGRACustomBitmap; override;
    838     function FilterBlurRadial(radius: single; blurType: TRadialBlurType): TBGRACustomBitmap; override;
    839     function FilterBlurRadial(ABounds: TRect; radius: single; blurType: TRadialBlurType): TBGRACustomBitmap; override;
    840     function FilterBlurRadial(radiusX, radiusY: single; blurType: TRadialBlurType): TBGRACustomBitmap; override;
    841     function FilterBlurRadial(ABounds: TRect; radiusX, radiusY: single; blurType: TRadialBlurType): TBGRACustomBitmap; override;
    842     function FilterBlurMotion(distance: single; angle: single; oriented: boolean): TBGRACustomBitmap; override;
    843     function FilterBlurMotion(ABounds: TRect; distance: single; angle: single; oriented: boolean): TBGRACustomBitmap; override;
    844     function FilterCustomBlur(mask: TBGRACustomBitmap): TBGRACustomBitmap; override;
    845     function FilterCustomBlur(ABounds: TRect; mask: TBGRACustomBitmap): TBGRACustomBitmap; override;
    846     function FilterEmboss(angle: single; AStrength: integer= 64; AOptions: TEmbossOptions = []): TBGRACustomBitmap; override;
    847     function FilterEmboss(angle: single; ABounds: TRect; AStrength: integer= 64; AOptions: TEmbossOptions = []): TBGRACustomBitmap; override;
    848     function FilterEmbossHighlight(FillSelection: boolean): TBGRACustomBitmap; override;
    849     function FilterEmbossHighlight(FillSelection: boolean; BorderColor: TBGRAPixel): TBGRACustomBitmap; override;
    850     function FilterEmbossHighlight(FillSelection: boolean; BorderColor: TBGRAPixel; var Offset: TPoint): TBGRACustomBitmap; override;
    851     function FilterGrayscale: TBGRACustomBitmap; override;
    852     function FilterGrayscale(ABounds: TRect): TBGRACustomBitmap; override;
    853     function FilterNormalize(eachChannel: boolean = True): TBGRACustomBitmap; override;
    854     function FilterNormalize(ABounds: TRect; eachChannel: boolean = True): TBGRACustomBitmap; override;
     878    function FilterBlurRadial(radius: single; blurType: TRadialBlurType): TBGRACustomBitmap; overload; override;
     879    function FilterBlurRadial(ABounds: TRect; radius: single; blurType: TRadialBlurType): TBGRACustomBitmap; overload; override;
     880    function FilterBlurRadial(radiusX, radiusY: single; blurType: TRadialBlurType): TBGRACustomBitmap; overload; override;
     881    function FilterBlurRadial(ABounds: TRect; radiusX, radiusY: single; blurType: TRadialBlurType): TBGRACustomBitmap; overload; override;
     882    function FilterBlurMotion(distance: single; angle: single; oriented: boolean): TBGRACustomBitmap; overload; override;
     883    function FilterBlurMotion(ABounds: TRect; distance: single; angle: single; oriented: boolean): TBGRACustomBitmap; overload; override;
     884    function FilterCustomBlur(mask: TBGRACustomBitmap): TBGRACustomBitmap; overload; override;
     885    function FilterCustomBlur(ABounds: TRect; mask: TBGRACustomBitmap): TBGRACustomBitmap; overload; override;
     886    function FilterEmboss(angle: single; AStrength: integer= 64; AOptions: TEmbossOptions = []): TBGRACustomBitmap; overload; override;
     887    function FilterEmboss(angle: single; ABounds: TRect; AStrength: integer= 64; AOptions: TEmbossOptions = []): TBGRACustomBitmap; overload; override;
     888    function FilterEmbossHighlight(FillSelection: boolean): TBGRACustomBitmap; overload; override;
     889    function FilterEmbossHighlight(FillSelection: boolean; BorderColor: TBGRAPixel): TBGRACustomBitmap; overload; override;
     890    function FilterEmbossHighlight(FillSelection: boolean; BorderColor: TBGRAPixel; var Offset: TPoint): TBGRACustomBitmap; overload; override;
     891    function FilterGrayscale: TBGRACustomBitmap; overload; override;
     892    function FilterGrayscale(ABounds: TRect): TBGRACustomBitmap; overload; override;
     893    function FilterNormalize(eachChannel: boolean = True): TBGRACustomBitmap; overload; override;
     894    function FilterNormalize(ABounds: TRect; eachChannel: boolean = True): TBGRACustomBitmap; overload; override;
    855895    function FilterRotate(origin: TPointF; angle: single; correctBlur: boolean = false): TBGRACustomBitmap; override;
    856896    function FilterAffine(AMatrix: TAffineMatrix; correctBlur: boolean = false): TBGRACustomBitmap; override;
    857897    function FilterSphere: TBGRACustomBitmap; override;
    858     function FilterTwirl(ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap; override;
    859     function FilterTwirl(ABounds: TRect; ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap; override;
     898    function FilterTwirl(ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap; overload; override;
     899    function FilterTwirl(ABounds: TRect; ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap; overload; override;
    860900    function FilterCylinder: TBGRACustomBitmap; override;
    861901    function FilterPlane: TBGRACustomBitmap; override;
     
    880920  public
    881921    constructor Create(AWidth, AHeight: integer; AData: Pointer); overload;
    882     function Duplicate(DuplicateProperties: Boolean = False): TBGRACustomBitmap; override;
     922    function Duplicate(DuplicateProperties: Boolean = False; DuplicateXorMask: Boolean = False): TBGRACustomBitmap; override;
    883923    procedure SetDataPtr(AData: Pointer);
    884924    property LineOrder: TRawImageLineOrder Read GetLineOrder Write SetLineOrder;
     
    893933    procedure TakeScreenshot({%H-}ARect: TRect); override;
    894934    procedure TakeScreenshotOfPrimaryMonitor; override;
    895     procedure LoadFromDevice({%H-}DC: System.THandle); override;
    896     procedure LoadFromDevice({%H-}DC: System.THandle; {%H-}ARect: TRect); override;
     935    procedure LoadFromDevice({%H-}DC: HDC); override;
     936    procedure LoadFromDevice({%H-}DC: HDC; {%H-}ARect: TRect); override;
    897937  end;
    898938
     
    935975begin
    936976  if FUser <> nil then
     977  begin
    937978    FUser.FBitmapModified := True;
     979    FUser.FAlphaCorrectionNeeded := true;
     980  end;
    938981  inherited Changed(Sender);
    939982end;
     
    9661009end;
    9671010
     1011function TBGRADefaultBitmap.CheckIsZero: boolean;
     1012var
     1013  i: integer;
     1014  p: PBGRAPixel;
     1015begin
     1016  p := Data;
     1017  for i := (NbPixels shr 1) - 1 downto 0 do
     1018  begin
     1019    if PInt64(p)^ <> 0 then
     1020    begin
     1021      Result := False;
     1022      exit;
     1023    end;
     1024    Inc(p,2);
     1025  end;
     1026  if Odd(NbPixels) and (PDWord(p)^ <> 0) then
     1027  begin
     1028    Result := false;
     1029    exit;
     1030  end;
     1031  Result := True;
     1032end;
     1033
    9681034function TBGRADefaultBitmap.GetCanvasAlphaCorrection: boolean;
    9691035begin
     
    10551121procedure TBGRADefaultBitmap.SetArrowEndSize(AValue: TPointF);
    10561122begin
     1123  {$PUSH}{$OPTIMIZATION OFF}
    10571124  GetArrow.EndSize := AValue;
     1125  {$POP}
    10581126end;
    10591127
    10601128procedure TBGRADefaultBitmap.SetArrowStartSize(AValue: TPointF);
    10611129begin
     1130  {$PUSH}{$OPTIMIZATION OFF}
    10621131  GetArrow.StartSize := AValue;
     1132  {$POP}
    10631133end;
    10641134
     
    11481218end;
    11491219
    1150 function TBGRADefaultBitmap.GetFontAnchorVerticalOffset: single;
     1220function TBGRADefaultBitmap.GetFontVerticalAnchorOffset: single;
    11511221begin
    11521222  case FontVerticalAnchor of
     
    11731243  ACustomOrientation: integer): TPointF;
    11741244begin
    1175   result := PointF(0, GetFontAnchorVerticalOffset);
     1245  result := PointF(0, GetFontVerticalAnchorOffset);
    11761246  if ACustomOrientation <> 0 then
    11771247    result := AffineMatrixRotationDeg(-ACustomOrientation*0.1)*result;
     
    12051275function TBGRADefaultBitmap.NewReference: TBGRACustomBitmap;
    12061276begin
    1207   Inc(FRefCount);
     1277  if self <> nil then Inc(FRefCount);
    12081278  Result := self;
    12091279end;
     
    12391309end;
    12401310
     1311procedure TBGRADefaultBitmap.NeedXorMask;
     1312begin
     1313  if FXorMask = nil then
     1314    FXorMask := BGRABitmapFactory.Create(Width,Height);
     1315end;
     1316
     1317procedure TBGRADefaultBitmap.DiscardXorMask;
     1318begin
     1319  if Assigned(FXorMask) then
     1320  begin
     1321    if FXorMask is TBGRADefaultBitmap then
     1322    begin
     1323      TBGRADefaultBitmap(FXorMask).FreeReference;
     1324      FXorMask := nil;
     1325    end else
     1326      FreeAndNil(FXorMask);
     1327  end;
     1328end;
     1329
    12411330{ Creates a new bitmap with dimensions AWidth and AHeight and filled with
    12421331  transparent pixels. Internally, it uses the same type so that if you
     
    13091398  OldJpegPerf: TJPEGReadPerformance;
    13101399begin
     1400  DiscardXorMask;
    13111401  if (loBmpAutoOpaque in AOptions) and (Handler is TBGRAReaderBMP) then
    13121402  begin
     
    13241414  end else
    13251415    inherited LoadFromStream(Str, Handler, AOptions);
     1416end;
     1417
     1418procedure TBGRADefaultBitmap.LoadFromResource(AFilename: string;
     1419  AOptions: TBGRALoadingOptions);
     1420var
     1421  stream: TStream;
     1422  format: TBGRAImageFormat;
     1423  reader: TFPCustomImageReader;
     1424  magic: array[1..2] of char;
     1425  startPos: Int64;
     1426  ext: String;
     1427begin
     1428  stream := BGRAResource.GetResourceStream(AFilename);
     1429  try
     1430    ext := Uppercase(ExtractFileExt(AFilename));
     1431    if (ext = '.BMP') and BGRAResource.IsWinResource(AFilename) then
     1432    begin
     1433      reader := TBGRAReaderBMP.Create;
     1434      TBGRAReaderBMP(reader).Subformat := bsfHeaderless;
     1435    end else
     1436    begin
     1437      format := DetectFileFormat(stream, ext);
     1438      reader := CreateBGRAImageReader(format);
     1439    end;
     1440    try
     1441      LoadFromStream(stream, reader, AOptions);
     1442    finally
     1443      reader.Free;
     1444    end;
     1445  finally
     1446    stream.Free;
     1447  end;
    13261448end;
    13271449
     
    13571479  ReallocData;
    13581480  NoClip;
     1481  DiscardXorMask;
    13591482end;
    13601483
     
    14121535destructor TBGRADefaultBitmap.Destroy;
    14131536begin
     1537  DiscardXorMask;
    14141538  FPenStroker.Free;
    14151539  FFontRenderer.Free;
     
    14991623    SetSize(TBGRACustomBitmap(Source).Width, TBGRACustomBitmap(Source).Height);
    15001624    PutImage(0, 0, TBGRACustomBitmap(Source), dmSet);
     1625    if Source is TBGRADefaultBitmap then
     1626    begin
     1627      HotSpot := TBGRADefaultBitmap(Source).HotSpot;
     1628      if XorMask <> TBGRADefaultBitmap(Source).XorMask then
     1629      begin
     1630        DiscardXorMask;
     1631        if TBGRADefaultBitmap(Source).XorMask is TBGRADefaultBitmap then
     1632          FXorMask := TBGRADefaultBitmap(TBGRADefaultBitmap(Source).XorMask).NewReference as TBGRADefaultBitmap
     1633        else
     1634          FXorMask := TBGRADefaultBitmap(Source).XorMask.Duplicate;
     1635      end;
     1636    end;
    15011637  end else
    15021638  if Source is TFPCustomImage then
     
    19642100function TBGRADefaultBitmap.GetCanvas: TCanvas;
    19652101begin
    1966   Result := Bitmap.Canvas;
     2102  if FDataModified or (FBitmap = nil) then
     2103  begin
     2104    RebuildBitmap;
     2105    FDataModified := False;
     2106  end;
     2107  Result := FBitmap.Canvas;
    19672108end;
    19682109
     
    19902131
    19912132procedure TBGRADefaultBitmap.CrossFade(ARect: TRect; Source1, Source2: IBGRAScanner; AFadePosition: byte; mode: TDrawMode = dmDrawWithTransparency);
    1992 var constScanner: TBGRAConstantScanner;
    19932133begin
    19942134  if AFadePosition = 0 then
     
    19962136  if AFadePosition = 255 then
    19972137    FillRect(ARect, Source2, mode) else
    1998   begin
    1999     constScanner := TBGRAConstantScanner.Create(BGRA(AFadePosition,AFadePosition,AFadePosition,255));
    2000     CrossFade(ARect, Source1,Source2, constScanner, mode);
    2001     constScanner.Free;
    2002   end;
     2138    InternalCrossFade(ARect, Source1,Source2, AFadePosition,nil, mode);
    20032139end;
    20042140
    20052141procedure TBGRADefaultBitmap.CrossFade(ARect: TRect; Source1, Source2: IBGRAScanner; AFadeMask: IBGRAScanner; mode: TDrawMode = dmDrawWithTransparency);
    2006 var xb,yb: NativeInt;
    2007   pdest: PBGRAPixel;
    2008   c: TBGRAPixel;
    2009   fadePos: byte;
    2010 begin
    2011   if not IntersectRect(ARect,ARect,ClipRect) then exit;
    2012   for yb := ARect.top to ARect.Bottom-1 do
    2013   begin
    2014     pdest := GetScanlineFast(yb)+ARect.Left;
    2015     Source1.ScanMoveTo(ARect.left, yb);
    2016     Source2.ScanMoveTo(ARect.left, yb);
    2017     AFadeMask.ScanMoveTo(ARect.left, yb);
    2018     for xb := ARect.left to ARect.Right-1 do
    2019     begin
    2020       fadePos := AFadeMask.ScanNextPixel.green;
    2021       c := MergeBGRAWithGammaCorrection(Source1.ScanNextPixel,not fadePos,Source2.ScanNextPixel,fadePos);
    2022       case mode of
    2023       dmSet: pdest^ := c;
    2024       dmDrawWithTransparency: DrawPixelInlineWithAlphaCheck(pdest, c);
    2025       dmLinearBlend: FastBlendPixelInline(pdest,c);
    2026       dmSetExceptTransparent: if c.alpha = 255 then pdest^ := c;
    2027       end;
    2028       inc(pdest);
    2029     end;
    2030   end;
    2031   InvalidateBitmap;
     2142begin
     2143  InternalCrossFade(ARect, Source1,Source2, 0,AFadeMask, mode);
    20322144end;
    20332145
     
    23842496end;
    23852497
     2498procedure TBGRADefaultBitmap.InternalCrossFade(ARect: TRect; Source1,
     2499  Source2: IBGRAScanner; AFadePos: byte; AFadeMask: IBGRAScanner; mode: TDrawMode);
     2500var xb,yb: NativeInt;
     2501  pdest: PBGRAPixel;
     2502  c: TBGRAPixel;
     2503  buf1,buf2: ArrayOfTBGRAPixel;
     2504begin
     2505  if not IntersectRect(ARect,ARect,ClipRect) then exit;
     2506  setlength(buf1, ARect.Width);
     2507  setlength(buf2, ARect.Width);
     2508  for yb := ARect.top to ARect.Bottom-1 do
     2509  begin
     2510    pdest := GetScanlineFast(yb)+ARect.Left;
     2511    Source1.ScanMoveTo(ARect.left, yb);
     2512    Source1.ScanPutPixels(@buf1[0], length(buf1), dmSet);
     2513    Source2.ScanMoveTo(ARect.left, yb);
     2514    Source2.ScanPutPixels(@buf2[0], length(buf2), dmSet);
     2515    if AFadeMask<>nil then AFadeMask.ScanMoveTo(ARect.left, yb);
     2516    for xb := 0 to ARect.Right-ARect.left-1 do
     2517    begin
     2518      if AFadeMask<>nil then AFadePos := AFadeMask.ScanNextPixel.green;
     2519      c := MergeBGRAWithGammaCorrection(buf1[xb],not AFadePos,buf2[xb],AFadePos);
     2520      case mode of
     2521      dmSet: pdest^ := c;
     2522      dmDrawWithTransparency: DrawPixelInlineWithAlphaCheck(pdest, c);
     2523      dmLinearBlend: FastBlendPixelInline(pdest,c);
     2524      dmSetExceptTransparent: if c.alpha = 255 then pdest^ := c;
     2525      end;
     2526      inc(pdest);
     2527    end;
     2528  end;
     2529  InvalidateBitmap;
     2530end;
     2531
    23862532procedure TBGRADefaultBitmap.InternalArc(cx, cy, rx, ry: single; StartAngleRad,
    23872533  EndAngleRad: Single; ABorderColor: TBGRAPixel; w: single; AFillColor: TBGRAPixel; AOptions: TArcOptions;
     
    24412587end;
    24422588
    2443 function TBGRADefaultBitmap.IsAffineRoughlyTranslation(AMatrix: TAffineMatrix; ASourceBounds: TRect): boolean;
     2589class function TBGRADefaultBitmap.IsAffineRoughlyTranslation(AMatrix: TAffineMatrix; ASourceBounds: TRect): boolean;
    24442590const oneOver512 = 1/512;
    24452591var Orig,HAxis,VAxis: TPointF;
     
    26532799  tempPath := TBGRAPath.Create(APath);
    26542800  multi := TBGRAMultishapeFiller.Create;
     2801  multi.FillMode := FillMode;
    26552802  multi.PolygonOrder := poLastOnTop;
    26562803  multi.AddPathFill(tempPath,AMatrix,AFillColor);
     
    26682815  tempPath := TBGRAPath.Create(APath);
    26692816  multi := TBGRAMultishapeFiller.Create;
     2817  multi.FillMode := FillMode;
    26702818  multi.PolygonOrder := poLastOnTop;
    26712819  multi.AddPathFill(tempPath,AMatrix,AFillColor);
     
    26832831  tempPath := TBGRAPath.Create(APath);
    26842832  multi := TBGRAMultishapeFiller.Create;
     2833  multi.FillMode := FillMode;
    26852834  multi.PolygonOrder := poLastOnTop;
    26862835  multi.AddPathFill(tempPath,AMatrix,AFillTexture);
     
    26992848  tempPath := TBGRAPath.Create(APath);
    27002849  multi := TBGRAMultishapeFiller.Create;
     2850  multi.FillMode := FillMode;
    27012851  multi.PolygonOrder := poLastOnTop;
    27022852  multi.AddPathFill(tempPath,AMatrix,AFillTexture);
     
    30383188
    30393189procedure TBGRADefaultBitmap.FillPoly(const points: array of TPointF;
    3040   c: TBGRAPixel; drawmode: TDrawMode);
    3041 begin
    3042   BGRAPolygon.FillPolyAliased(self, points, c, FEraseMode, FillMode = fmWinding, drawmode);
     3190  c: TBGRAPixel; drawmode: TDrawMode; APixelCenteredCoordinates: boolean);
     3191begin
     3192  BGRAPolygon.FillPolyAliased(self, points, c, FEraseMode, FillMode = fmWinding, drawmode, APixelCenteredCoordinates);
    30433193end;
    30443194
    30453195procedure TBGRADefaultBitmap.FillPoly(const points: array of TPointF;
    3046   texture: IBGRAScanner; drawmode: TDrawMode);
    3047 begin
    3048   BGRAPolygon.FillPolyAliasedWithTexture(self, points, texture, FillMode = fmWinding, drawmode);
     3196  texture: IBGRAScanner; drawmode: TDrawMode; APixelCenteredCoordinates: boolean);
     3197begin
     3198  BGRAPolygon.FillPolyAliasedWithTexture(self, points, texture, FillMode = fmWinding, drawmode, APixelCenteredCoordinates);
    30493199end;
    30503200
     
    30573207end;
    30583208
    3059 procedure TBGRADefaultBitmap.FillPolyAntialias(const points: array of TPointF; c: TBGRAPixel);
    3060 begin
    3061   BGRAPolygon.FillPolyAntialias(self, points, c, FEraseMode, FillMode = fmWinding, LinearAntialiasing);
     3209procedure TBGRADefaultBitmap.FillPolyAntialias(const points: array of TPointF; c: TBGRAPixel; APixelCenteredCoordinates: boolean);
     3210begin
     3211  BGRAPolygon.FillPolyAntialias(self, points, c, FEraseMode, FillMode = fmWinding, LinearAntialiasing, APixelCenteredCoordinates);
    30623212end;
    30633213
    30643214procedure TBGRADefaultBitmap.FillPolyAntialias(const points: array of TPointF;
    3065   texture: IBGRAScanner);
    3066 begin
    3067   BGRAPolygon.FillPolyAntialiasWithTexture(self, points, texture, FillMode = fmWinding, LinearAntialiasing);
     3215  texture: IBGRAScanner; APixelCenteredCoordinates: boolean);
     3216begin
     3217  BGRAPolygon.FillPolyAntialiasWithTexture(self, points, texture, FillMode = fmWinding, LinearAntialiasing, APixelCenteredCoordinates);
    30683218end;
    30693219
    30703220procedure TBGRADefaultBitmap.ErasePoly(const points: array of TPointF;
    3071   alpha: byte);
    3072 begin
    3073   BGRAPolygon.FillPolyAliased(self, points, BGRA(0, 0, 0, alpha), True, FillMode = fmWinding, dmDrawWithTransparency);
    3074 end;
    3075 
    3076 procedure TBGRADefaultBitmap.ErasePolyAntialias(const points: array of TPointF; alpha: byte);
     3221  alpha: byte; APixelCenteredCoordinates: boolean);
     3222begin
     3223  BGRAPolygon.FillPolyAliased(self, points, BGRA(0, 0, 0, alpha), True, FillMode = fmWinding, dmDrawWithTransparency, APixelCenteredCoordinates);
     3224end;
     3225
     3226procedure TBGRADefaultBitmap.ErasePolyAntialias(const points: array of TPointF; alpha: byte; APixelCenteredCoordinates: boolean);
    30773227begin
    30783228  FEraseMode := True;
    3079   FillPolyAntialias(points, BGRA(0, 0, 0, alpha));
     3229  FillPolyAntialias(points, BGRA(0, 0, 0, alpha), APixelCenteredCoordinates);
    30803230  FEraseMode := False;
    30813231end;
     
    31553305  c: TBGRAPixel; w: single);
    31563306begin
    3157   if (PenStyle = psClear) or (c.alpha = 0) then exit;
     3307  if (PenStyle = psClear) or (c.alpha = 0) or (w = 0) then exit;
    31583308  if (PenStyle = psSolid) then
    31593309    BGRAPolygon.BorderEllipseAntialias(self, x, y, rx, ry, w, c, FEraseMode, LinearAntialiasing)
     
    31623312end;
    31633313
     3314procedure TBGRADefaultBitmap.EllipseAntialias(AOrigin, AXAxis, AYAxis: TPointF;
     3315  c: TBGRAPixel; w: single);
     3316begin
     3317  if (PenStyle = psClear) or (c.alpha = 0) or (w = 0) then exit;
     3318  DrawPolygonAntialias(ComputeEllipseContour(AOrigin, AXAxis, AYAxis),c,w);
     3319end;
     3320
    31643321procedure TBGRADefaultBitmap.EllipseAntialias(x, y, rx, ry: single;
    31653322  texture: IBGRAScanner; w: single);
    31663323begin
    3167   if (PenStyle = psClear) then exit;
     3324  if (PenStyle = psClear) or (w = 0) then exit;
    31683325  if (PenStyle = psSolid) then
    31693326    BGRAPolygon.BorderEllipseAntialiasWithTexture(self, x, y, rx, ry, w, texture, LinearAntialiasing)
     
    31723329end;
    31733330
     3331procedure TBGRADefaultBitmap.EllipseAntialias(AOrigin, AXAxis, AYAxis: TPointF;
     3332  texture: IBGRAScanner; w: single);
     3333begin
     3334  if (PenStyle = psClear) or (w = 0) then exit;
     3335  DrawPolygonAntialias(ComputeEllipseContour(AOrigin, AXAxis, AYAxis),texture,w);
     3336end;
     3337
    31743338procedure TBGRADefaultBitmap.EllipseAntialias(x, y, rx, ry: single;
    31753339  c: TBGRAPixel; w: single; back: TBGRAPixel);
     
    31773341    hw: single;
    31783342begin
    3179   if w=0 then exit;
     3343  if (w=0) or (PenStyle = psClear) or (c.alpha = 0) then
     3344  begin
     3345    FillEllipseAntialias(x, y, rx, ry, back);
     3346    exit;
     3347  end;
    31803348  rx := abs(rx);
    31813349  ry := abs(ry);
     
    31883356  { use multishape filler for fine junction between polygons }
    31893357  multi := TBGRAMultishapeFiller.Create;
    3190   if not (PenStyle = psClear) and (c.alpha <> 0) then
    3191   begin
    3192     if (PenStyle = psSolid) then
    3193     begin
    3194       multi.AddEllipse(x,y,rx-hw,ry-hw,back);
    3195       multi.AddEllipseBorder(x,y,rx,ry,w,c)
    3196     end
    3197     else
    3198     begin
    3199       multi.AddEllipse(x,y,rx,ry,back);
    3200       multi.AddPolygon(ComputeWidePolygon(ComputeEllipseContour(x,y,rx,ry),w),c);
    3201       multi.PolygonOrder := poLastOnTop;
    3202     end;
    3203   end;
     3358  if (PenStyle = psSolid) then
     3359  begin
     3360    if back.alpha <> 0 then multi.AddEllipse(x,y,rx-hw,ry-hw,back);
     3361    multi.AddEllipseBorder(x,y,rx,ry,w,c)
     3362  end
     3363  else
     3364  begin
     3365    if back.alpha <> 0 then multi.AddEllipse(x,y,rx,ry,back);
     3366    multi.AddPolygon(ComputeWidePolygon(ComputeEllipseContour(x,y,rx,ry),w),c);
     3367  end;
     3368  multi.PolygonOrder := poLastOnTop;
    32043369  multi.Draw(self);
    32053370  multi.Free;
    32063371end;
    32073372
     3373procedure TBGRADefaultBitmap.EllipseAntialias(AOrigin, AXAxis, AYAxis: TPointF;
     3374  c: TBGRAPixel; w: single; back: TBGRAPixel);
     3375var multi: TBGRAMultishapeFiller;
     3376    pts: ArrayOfTPointF;
     3377begin
     3378  if (w=0) or (PenStyle = psClear) or (c.alpha = 0) then
     3379  begin
     3380    FillEllipseAntialias(AOrigin, AXAxis, AYAxis, back);
     3381    exit;
     3382  end;
     3383  { use multishape filler for fine junction between polygons }
     3384  multi := TBGRAMultishapeFiller.Create;
     3385  pts := ComputeEllipseContour(AOrigin, AXAxis, AYAxis);
     3386  if back.alpha <> 0 then multi.AddPolygon(pts, back);
     3387  pts := ComputeWidePolygon(pts,w);
     3388  multi.AddPolygon(pts,c);
     3389  multi.PolygonOrder := poLastOnTop;
     3390  multi.Draw(self);
     3391  multi.Free;
     3392end;
     3393
    32083394procedure TBGRADefaultBitmap.FillEllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel);
    32093395begin
    32103396  BGRAPolygon.FillEllipseAntialias(self, x, y, rx, ry, c, FEraseMode, LinearAntialiasing);
     3397end;
     3398
     3399procedure TBGRADefaultBitmap.FillEllipseAntialias(AOrigin, AXAxis,
     3400  AYAxis: TPointF; c: TBGRAPixel);
     3401var
     3402  pts: array of TPointF;
     3403begin
     3404  if c.alpha = 0 then exit;
     3405  pts := ComputeEllipseContour(AOrigin,AXAxis,AYAxis);
     3406  FillPolyAntialias(pts, c);
    32113407end;
    32123408
     
    32153411begin
    32163412  BGRAPolygon.FillEllipseAntialiasWithTexture(self, x, y, rx, ry, texture, LinearAntialiasing);
     3413end;
     3414
     3415procedure TBGRADefaultBitmap.FillEllipseAntialias(AOrigin, AXAxis,
     3416  AYAxis: TPointF; texture: IBGRAScanner);
     3417var
     3418  pts: array of TPointF;
     3419begin
     3420  pts := ComputeEllipseContour(AOrigin,AXAxis,AYAxis);
     3421  FillPolyAntialias(pts, texture);
    32173422end;
    32183423
     
    32413446end;
    32423447
     3448procedure TBGRADefaultBitmap.FillEllipseLinearColorAntialias(AOrigin, AXAxis,
     3449  AYAxis: TPointF; outercolor, innercolor: TBGRAPixel);
     3450var
     3451  grad: TBGRAGradientScanner;
     3452  affine: TBGRAAffineScannerTransform;
     3453begin
     3454  grad := TBGRAGradientScanner.Create(innercolor,outercolor,gtRadial,PointF(0,0),PointF(1,0),True);
     3455  affine := TBGRAAffineScannerTransform.Create(grad);
     3456  affine.Fit(AOrigin,AXAxis,AYAxis);
     3457  FillEllipseAntialias(AOrigin,AXAxis,AYAxis,affine);
     3458  affine.Free;
     3459  grad.Free;
     3460end;
     3461
    32433462procedure TBGRADefaultBitmap.EraseEllipseAntialias(x, y, rx, ry: single; alpha: byte);
    32443463begin
    32453464  FEraseMode := True;
    32463465  FillEllipseAntialias(x, y, rx, ry, BGRA(0, 0, 0, alpha));
     3466  FEraseMode := False;
     3467end;
     3468
     3469procedure TBGRADefaultBitmap.EraseEllipseAntialias(AOrigin, AXAxis,
     3470  AYAxis: TPointF; alpha: byte);
     3471begin
     3472  FEraseMode := True;
     3473  FillEllipseAntialias(AOrigin, AXAxis, AYAxis, BGRA(0, 0, 0, alpha));
    32473474  FEraseMode := False;
    32483475end;
     
    37073934  c: TBGRAPixel; options: TRoundRectangleOptions; pixelCenteredCoordinates: boolean);
    37083935begin
    3709   if not pixelCenteredCoordinates then
    3710   begin
    3711     x -= 0.5;
    3712     y -= 0.5;
    3713     x2 -= 0.5;
    3714     y2 -= 0.5;
    3715   end;
    3716   BGRAPolygon.FillRoundRectangleAntialias(self,x,y,x2,y2,rx,ry,options,c,False, LinearAntialiasing);
     3936  BGRAPolygon.FillRoundRectangleAntialias(self,x,y,x2,y2,rx,ry,options,c,False, LinearAntialiasing, pixelCenteredCoordinates);
    37173937end;
    37183938
     
    37203940  ry: single; texture: IBGRAScanner; options: TRoundRectangleOptions; pixelCenteredCoordinates: boolean);
    37213941begin
    3722   if not pixelCenteredCoordinates then
    3723   begin
    3724     x -= 0.5;
    3725     y -= 0.5;
    3726     x2 -= 0.5;
    3727     y2 -= 0.5;
    3728   end;
    3729   BGRAPolygon.FillRoundRectangleAntialiasWithTexture(self,x,y,x2,y2,rx,ry,options,texture, LinearAntialiasing);
     3942  BGRAPolygon.FillRoundRectangleAntialiasWithTexture(self,x,y,x2,y2,rx,ry,options,texture, LinearAntialiasing, pixelCenteredCoordinates);
    37303943end;
    37313944
     
    37333946  ry: single; alpha: byte; options: TRoundRectangleOptions; pixelCenteredCoordinates: boolean);
    37343947begin
    3735   if not pixelCenteredCoordinates then
    3736   begin
    3737     x -= 0.5;
    3738     y -= 0.5;
    3739     x2 -= 0.5;
    3740     y2 -= 0.5;
    3741   end;
    3742   BGRAPolygon.FillRoundRectangleAntialias(self,x,y,x2,y2,rx,ry,options,BGRA(0,0,0,alpha),True, LinearAntialiasing);
     3948  BGRAPolygon.FillRoundRectangleAntialias(self,x,y,x2,y2,rx,ry,options,BGRA(0,0,0,alpha),True, LinearAntialiasing, pixelCenteredCoordinates);
     3949end;
     3950
     3951procedure TBGRADefaultBitmap.Ellipse(x, y, rx, ry: single; c: TBGRAPixel;
     3952  w: single; ADrawMode: TDrawMode);
     3953begin
     3954  if (PenStyle = psClear) or (c.alpha = 0) or (w = 0) then exit;
     3955  if (PenStyle = psSolid) then
     3956    BGRAPolygon.BorderEllipse(self, x, y, rx, ry, w, c, FEraseMode, ADrawMode)
     3957  else
     3958    FillPoly(ComputeWidePolygon(ComputeEllipseContour(x,y,rx,ry),w),c, ADrawMode);
     3959end;
     3960
     3961procedure TBGRADefaultBitmap.Ellipse(AOrigin, AXAxis, AYAxis: TPointF;
     3962  c: TBGRAPixel; w: single; ADrawMode: TDrawMode);
     3963begin
     3964  if (PenStyle = psClear) or (c.alpha = 0) or (w = 0) then exit;
     3965  FillPoly(ComputeWidePolygon(ComputeEllipseContour(AOrigin, AXAxis, AYAxis),w),c,ADrawMode);
    37433966end;
    37443967
     
    37553978end;
    37563979
     3980procedure TBGRADefaultBitmap.FillRoundRect(X1, Y1, X2, Y2: integer; DX,
     3981  DY: integer; FillTexture: IBGRAScanner; ADrawMode: TDrawMode);
     3982begin
     3983  BGRAFillRoundRectAliased(self,X1,Y1,X2,Y2,DX,DY,BGRAPixelTransparent,FillTexture,ADrawMode);
     3984end;
     3985
    37573986{------------------------- Text functions ---------------------------------------}
    37583987
     
    37814010end;
    37824011
     4012procedure TBGRADefaultBitmap.TextMultiline(ALeft, ATop, AWidth: single; sUTF8: string;
     4013  c: TBGRAPixel; AAlign: TBidiTextAlignment; AVertAlign: TTextLayout; AParagraphSpacing: single);
     4014var
     4015  layout: TBidiTextLayout;
     4016  i: Integer;
     4017begin
     4018  if FontBidiMode = fbmAuto then
     4019    layout := TBidiTextLayout.Create(FontRenderer, sUTF8)
     4020  else
     4021    layout := TBidiTextLayout.Create(FontRenderer, sUTF8, GetFontRightToLeftFor(sUTF8));
     4022  for i := 0 to layout.ParagraphCount-1 do
     4023    layout.ParagraphAlignment[i] := AAlign;
     4024  layout.ParagraphSpacingBelow:= AParagraphSpacing;
     4025  layout.AvailableWidth := AWidth;
     4026  case AVertAlign of
     4027    tlBottom: layout.TopLeft := PointF(ALeft,ATop-layout.TotalTextHeight);
     4028    tlCenter: layout.TopLeft := PointF(ALeft,ATop-layout.TotalTextHeight/2);
     4029    else layout.TopLeft := PointF(ALeft,ATop);
     4030  end;
     4031  layout.DrawText(self, c);
     4032  layout.Free;
     4033end;
     4034
     4035procedure TBGRADefaultBitmap.TextMultiline(ALeft, ATop, AWidth: single;
     4036  sUTF8: string; ATexture: IBGRAScanner; AAlign: TBidiTextAlignment;
     4037  AVertAlign: TTextLayout; AParagraphSpacing: single);
     4038var
     4039  layout: TBidiTextLayout;
     4040  i: Integer;
     4041begin
     4042  if FontBidiMode = fbmAuto then
     4043    layout := TBidiTextLayout.Create(FontRenderer, sUTF8)
     4044  else
     4045    layout := TBidiTextLayout.Create(FontRenderer, sUTF8, GetFontRightToLeftFor(sUTF8));
     4046  for i := 0 to layout.ParagraphCount-1 do
     4047    layout.ParagraphAlignment[i] := AAlign;
     4048  layout.ParagraphSpacingBelow:= AParagraphSpacing;
     4049  layout.AvailableWidth := AWidth;
     4050  case AVertAlign of
     4051    tlBottom: layout.TopLeft := PointF(ALeft,ATop-layout.TotalTextHeight);
     4052    tlCenter: layout.TopLeft := PointF(ALeft,ATop-layout.TotalTextHeight/2);
     4053    else layout.TopLeft := PointF(ALeft,ATop);
     4054  end;
     4055  layout.DrawText(self, ATexture);
     4056  layout.Free;
     4057end;
     4058
    37834059procedure TBGRADefaultBitmap.TextOut(x, y: single; sUTF8: string;
    3784   texture: IBGRAScanner; align: TAlignment);
    3785 begin
    3786   FontRenderer.TextOut(self,x,y,CleanTextOutString(sUTF8),texture,align);
     4060  texture: IBGRAScanner; align: TAlignment; ARightToLeft: boolean);
     4061begin
     4062  FontRenderer.TextOut(self,x,y,CleanTextOutString(sUTF8),texture,align, ARightToLeft);
    37874063end;
    37884064
    37894065procedure TBGRADefaultBitmap.TextOut(x, y: single; sUTF8: string;
    3790   c: TBGRAPixel; align: TAlignment);
     4066  c: TBGRAPixel; align: TAlignment; ARightToLeft: boolean);
    37914067begin
    37924068  with (PointF(x,y)-GetFontAnchorRotatedOffset) do
    3793     FontRenderer.TextOut(self,x,y,CleanTextOutString(sUTF8),c,align);
     4069    FontRenderer.TextOut(self,x,y,CleanTextOutString(sUTF8),c,align, ARightToLeft);
    37944070end;
    37954071
     
    38124088function TBGRADefaultBitmap.TextSize(sUTF8: string): TSize;
    38134089begin
    3814   result := FontRenderer.TextSize(sUTF8);
     4090  result := FontRenderer.TextSize(CleanTextOutString(sUTF8));
     4091end;
     4092
     4093function TBGRADefaultBitmap.TextAffineBox(sUTF8: string): TAffineBox;
     4094var size: TSize;
     4095  m: TAffineMatrix;
     4096  dy: single;
     4097begin
     4098  dy := GetFontVerticalAnchorOffset;
     4099  size := FontRenderer.TextSizeAngle(sUTF8, FontOrientation);
     4100  m := AffineMatrixRotationDeg(-FontOrientation*0.1);
     4101  result := TAffineBox.AffineBox(PointF(0,-dy), m*PointF(size.cx,-dy), m*PointF(0,size.cy-dy));
     4102end;
     4103
     4104function TBGRADefaultBitmap.TextSize(sUTF8: string; AMaxWidth: integer): TSize;
     4105begin
     4106  result := FontRenderer.TextSize(sUTF8, AMaxWidth, GetFontRightToLeftFor(sUTF8));
     4107end;
     4108
     4109function TBGRADefaultBitmap.TextSize(sUTF8: string; AMaxWidth: integer;
     4110  ARightToLeft: boolean): TSize;
     4111begin
     4112  result := FontRenderer.TextSize(sUTF8, AMaxWidth, ARightToLeft);
     4113end;
     4114
     4115function TBGRADefaultBitmap.TextFitInfo(sUTF8: string; AMaxWidth: integer
     4116  ): integer;
     4117begin
     4118  result := FontRenderer.TextFitInfo(sUTF8, AMaxWidth);
    38154119end;
    38164120
     
    38744178end;
    38754179
     4180function TBGRADefaultBitmap.ComputeEllipseContour(AOrigin, AXAxis,
     4181  AYAxis: TPointF; quality: single): ArrayOfTPointF;
     4182begin
     4183  result := BGRAPath.ComputeEllipse(AOrigin,AXAxis,AYAxis, quality);
     4184end;
     4185
    38764186function TBGRADefaultBitmap.ComputeEllipseBorder(x, y, rx, ry, w: single; quality: single): ArrayOfTPointF;
    38774187begin
    38784188  result := ComputeWidePolygon(ComputeEllipseContour(x,y,rx,ry, quality),w);
     4189end;
     4190
     4191function TBGRADefaultBitmap.ComputeEllipseBorder(AOrigin, AXAxis,
     4192  AYAxis: TPointF; w: single; quality: single): ArrayOfTPointF;
     4193begin
     4194  result := ComputeWidePolygon(ComputeEllipseContour(AOrigin,AXAxis,AYAxis, quality),w);
    38794195end;
    38804196
     
    39804296  self.FillRect(X,Y,X+AMask.Width,Y+AMask.Height,scan,ADrawMode);
    39814297  scan.Free;
     4298end;
     4299
     4300procedure TBGRADefaultBitmap.EraseMask(x, y: integer; AMask: TBGRACustomBitmap;
     4301  alpha: byte);
     4302var
     4303  x0,y0,x2, y2, yb,xb, tx, delta: integer;
     4304  p, psrc: PBGRAPixel;
     4305begin
     4306  if (AMask = nil) or (alpha = 0) then exit;
     4307  x0 := x;
     4308  y0 := y;
     4309  x2 := x+AMask.Width;
     4310  y2 := y+AMask.Height;
     4311  if not CheckClippedRectBounds(x,y,x2,y2) then exit;
     4312  tx := x2 - x;
     4313  Dec(x2);
     4314  Dec(y2);
     4315
     4316  p := Scanline[y] + x;
     4317  if FLineOrder = riloBottomToTop then
     4318    delta := -Width
     4319  else
     4320    delta := Width;
     4321
     4322  for yb := y to y2 do
     4323  begin
     4324    psrc := AMask.ScanLine[yb-y0]+(x-x0);
     4325    if alpha = 255 then
     4326    begin
     4327      for xb := tx-1 downto 0 do
     4328      begin
     4329        ErasePixelInline(p, psrc^.green);
     4330        inc(p);
     4331        inc(psrc);
     4332      end;
     4333    end else
     4334    begin
     4335      for xb := tx-1 downto 0 do
     4336      begin
     4337        ErasePixelInline(p, ApplyOpacity(psrc^.green,alpha));
     4338        inc(p);
     4339        inc(psrc);
     4340      end;
     4341    end;
     4342    dec(p, tx);
     4343    Inc(p, delta);
     4344  end;
     4345
     4346  InvalidateBitmap;
    39824347end;
    39834348
     
    41754540      exit;
    41764541    StartMask := $FFFFFFFF shl (X1 and 31);
    4177     if X2 and 31 = 31 then
    4178       EndMask := $FFFFFFFF
     4542    case X2 and 31 of
     4543    31: EndMask := $FFFFFFFF;
     4544    30: EndMask := $7FFFFFFF;
    41794545    else
    41804546      EndMask := 1 shl ((X2 and 31) + 1) - 1;
     4547    end;
    41814548    StartPos := X1 shr 5 + AY * VisitedLineSize;
    41824549    EndPos := X2 shr 5 + AY * VisitedLineSize;
     
    46535020      end;
    46545021      InvalidateBitmap;
     5022      if (Source is TBGRADefaultBitmap) and Assigned(TBGRADefaultBitmap(Source).XorMask) then
     5023        PutImage(x,y,TBGRADefaultBitmap(Source).XorMask,dmXor,AOpacity);
    46555024    end;
    46565025    dmDrawWithTransparency:
     
    46805049      end;
    46815050      InvalidateBitmap;
     5051      if (Source is TBGRADefaultBitmap) and Assigned(TBGRADefaultBitmap(Source).XorMask) then
     5052        PutImage(x,y,TBGRADefaultBitmap(Source).XorMask,dmXor,AOpacity);
    46825053    end;
    46835054    dmFastBlend:
     
    47065077      end;
    47075078      InvalidateBitmap;
     5079      if (Source is TBGRADefaultBitmap) and Assigned(TBGRADefaultBitmap(Source).XorMask) then
     5080        PutImage(x,y,TBGRADefaultBitmap(Source).XorMask,dmXor,AOpacity);
    47085081    end;
    47095082    dmXor:
     
    48755248procedure TBGRADefaultBitmap.StretchPutImage(ARect: TRect;
    48765249  Source: TBGRACustomBitmap; mode: TDrawMode; AOpacity: byte);
     5250var noTransition: boolean;
    48775251begin
    48785252  If (Source = nil) or (AOpacity = 0) then exit;
     
    48805254     PutImage(ARect.Left,ARect.Top,Source,mode,AOpacity)
    48815255  else
    4882      BGRAResample.StretchPutImage(Source, ARect.Right-ARect.Left, ARect.Bottom-ARect.Top, self, ARect.left,ARect.Top, mode, AOpacity);
     5256  begin
     5257     noTransition:= (mode = dmXor) or ((mode in [dmDrawWithTransparency,dmFastBlend,dmSetExceptTransparent]) and
     5258                                       (Source is TBGRADefaultBitmap) and
     5259                                       Assigned(TBGRADefaultBitmap(Source).XorMask));
     5260     BGRAResample.StretchPutImage(Source, ARect.Right-ARect.Left, ARect.Bottom-ARect.Top, self, ARect.left,ARect.Top, mode, AOpacity, noTransition);
     5261    if (mode in [dmDrawWithTransparency,dmFastBlend,dmSetExceptTransparent]) and Assigned(TBGRADefaultBitmap(Source).XorMask) then
     5262      BGRAResample.StretchPutImage(TBGRADefaultBitmap(Source).XorMask, ARect.Right-ARect.Left, ARect.Bottom-ARect.Top, self, ARect.left,ARect.Top, dmXor, AOpacity, noTransition);
     5263  end;
    48835264end;
    48845265
    48855266{ Duplicate bitmap content. Optionally, bitmap properties can be also duplicated }
    4886 function TBGRADefaultBitmap.Duplicate(DuplicateProperties: Boolean = False): TBGRACustomBitmap;
     5267function TBGRADefaultBitmap.Duplicate(DuplicateProperties: Boolean = False; DuplicateXorMask: Boolean = False): TBGRACustomBitmap;
    48875268var Temp: TBGRADefaultBitmap;
    48885269begin
     
    48935274  if DuplicateProperties then
    48945275    CopyPropertiesTo(Temp);
     5276  if DuplicateXorMask and Assigned(XorMask) then
     5277    Temp.FXorMask := FXorMask.Duplicate(True) as TBGRADefaultBitmap;
    48955278  Result := Temp;
    48965279end;
     
    49085291  ABitmap.FontAntialias := FontAntialias;
    49095292  ABitmap.FontOrientation := FontOrientation;
     5293  ABitmap.FontBidiMode:= FontBidiMode;
    49105294  ABitmap.LineCap := LineCap;
    49115295  ABitmap.JoinStyle := JoinStyle;
    49125296  ABitmap.FillMode := FillMode;
    49135297  ABitmap.ClipRect := ClipRect;
     5298  ABitmap.HotSpot := HotSpot;
    49145299end;
    49155300
     
    51855570end;
    51865571
     5572function TBGRADefaultBitmap.GetHasSemiTransparentPixels: boolean;
     5573var
     5574  n: integer;
     5575  p: PBGRAPixel;
     5576begin
     5577  p := Data;
     5578  for n := NbPixels - 1 downto 0 do
     5579  begin
     5580    if (p^.alpha > 0) and (p^.alpha < 255) then
     5581    begin
     5582      result := true;
     5583      exit;
     5584    end;
     5585    inc(p);
     5586  end;
     5587  result := false;
     5588end;
     5589
    51875590function TBGRADefaultBitmap.GetAverageColor: TColor;
    51885591var
     
    53185721  freemem(line);
    53195722  InvalidateBitmap;
     5723
     5724  if Assigned(XorMask) then XorMask.VerticalFlip(ARect);
    53205725end;
    53215726
     
    53515756  end;
    53525757  InvalidateBitmap;
     5758
     5759  if Assigned(XorMask) then XorMask.HorizontalFlip(ARect);
    53535760end;
    53545761
     
    53775784    end;
    53785785  end;
     5786
     5787  if Assigned(XorMask) then TBGRADefaultBitmap(result).FXorMask := self.XorMask.RotateCW;
    53795788end;
    53805789
     
    54035812    end;
    54045813  end;
     5814
     5815  if Assigned(XorMask) then TBGRADefaultBitmap(result).FXorMask := self.XorMask.RotateCCW;
    54055816end;
    54065817
     
    55495960  end;
    55505961  InvalidateBitmap;
     5962end;
     5963
     5964function TBGRADefaultBitmap.GetMaskFromAlpha: TBGRACustomBitmap;
     5965var y,x: integer;
     5966  psrc, pdest: PBGRAPixel;
     5967begin
     5968  result := BGRABitmapFactory.Create(Width,Height);
     5969  for y := 0 to self.Height-1 do
     5970  begin
     5971    psrc := self.ScanLine[y];
     5972    pdest := result.ScanLine[y];
     5973    for x := 0 to self.Width-1 do
     5974    begin
     5975      pdest^ := BGRA(psrc^.alpha,psrc^.alpha,psrc^.alpha);
     5976      inc(psrc);
     5977      inc(pdest);
     5978    end;
     5979  end;
    55515980end;
    55525981
     
    59636392end;
    59646393
    5965 function TBGRAPtrBitmap.Duplicate(DuplicateProperties: Boolean = False): TBGRACustomBitmap;
     6394function TBGRAPtrBitmap.Duplicate(DuplicateProperties: Boolean = False; DuplicateXorMask: Boolean = False): TBGRACustomBitmap;
    59666395begin
    59676396  Result := NewBitmap(Width, Height);
    59686397  if DuplicateProperties then CopyPropertiesTo(TBGRADefaultBitmap(Result));
     6398  if DuplicateXorMask and Assigned(XorMask) then
     6399    TBGRADefaultBitmap(Result).FXorMask := FXorMask.Duplicate(True);
    59696400end;
    59706401
     
    60076438end;
    60086439
    6009 procedure TBGRAPtrBitmap.LoadFromDevice(DC: System.THandle);
    6010 begin
    6011   CannotResize;
    6012 end;
    6013 
    6014 procedure TBGRAPtrBitmap.LoadFromDevice(DC: System.THandle; ARect: TRect);
    6015 begin
    6016   CannotResize;
     6440procedure TBGRAPtrBitmap.LoadFromDevice(DC: HDC);
     6441begin
     6442  NotImplemented;
     6443end;
     6444
     6445procedure TBGRAPtrBitmap.LoadFromDevice(DC: HDC; ARect: TRect);
     6446begin
     6447  NotImplemented;
    60176448end;
    60186449
  • GraphicTest/Packages/bgrabitmap/bgradithering.pas

    r494 r521  
    7878    procedure SetTransparentColorIndex(AValue: integer);
    7979  public
    80     constructor Create(APalette: TBGRACustomApproxPalette; AIgnoreAlpha: boolean; ABitsPerPixelForIndices: integer); //use platform byte order
    81     constructor Create(APalette: TBGRACustomApproxPalette; AIgnoreAlpha: boolean; ABitsPerPixelForIndices: integer; AByteOrder: TRawImageByteOrder); //maybe necessary if larger than 8 bits per pixel
     80    constructor Create(APalette: TBGRACustomApproxPalette; AIgnoreAlpha: boolean; ABitsPerPixelForIndices: integer); overload; //use platform byte order
     81    constructor Create(APalette: TBGRACustomApproxPalette; AIgnoreAlpha: boolean; ABitsPerPixelForIndices: integer; AByteOrder: TRawImageByteOrder); overload; //maybe necessary if larger than 8 bits per pixel
    8282
    8383    function DitherImage(AAlgorithm: TDitheringAlgorithm; AImage: TBGRACustomBitmap): Pointer; overload; //use minimum scanline size
  • GraphicTest/Packages/bgrabitmap/bgradnetdeserial.pas

    r494 r521  
    6363    FContainer: TDotNetDeserialization;
    6464    function GetTypeAsString: string; virtual; abstract;
    65     function GetFieldAsString(Index: longword): string; virtual; abstract;
    66     function GetFieldAsString(Name: string): string;
     65    function GetFieldAsString(Index: longword): string; overload; virtual; abstract;
     66    function GetFieldAsString(Name: string): string; overload;
    6767    function GetFieldCount: longword; virtual; abstract;
    6868    function GetFieldName(Index: longword): string; virtual; abstract;
     
    147147    function FindObject(typeName: string): TCustomSerializedObject;
    148148    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;
     149    function GetObjectField(obj: TCustomSerializedObject; Name: string): TCustomSerializedObject; overload;
     150    function GetObjectField(obj: TCustomSerializedObject; index: integer): TCustomSerializedObject; overload;
     151    function GetObject(id: string): TCustomSerializedObject; overload;
     152    function GetObject(id: longword): TCustomSerializedObject; overload;
    153153    function IsBoxedValue(obj: TCustomSerializedObject; index: integer): boolean;
    154154    function GetBoxedValue(obj: TCustomSerializedObject; index: integer): string;
  • GraphicTest/Packages/bgrabitmap/bgrafillinfo.pas

    r494 r521  
    111111  public
    112112    WindingFactor: integer;
    113     constructor Create(x1, y1, x2, y2, rx, ry: single; options: TRoundRectangleOptions);
     113    constructor Create(x1, y1, x2, y2, rx, ry: single; options: TRoundRectangleOptions; APixelCenteredCoordinates: boolean = true);
    114114    function SegmentsCurved: boolean; override;
    115115    function GetBounds: TRect; override;
     
    129129      var inter: ArrayOfTIntersectionInfo; var nbInter: integer); override;
    130130  public
    131     constructor Create(x1, y1, x2, y2, rx, ry, w: single; options: TRoundRectangleOptions);
     131    constructor Create(x1, y1, x2, y2, rx, ry, w: single; options: TRoundRectangleOptions; APixelCenteredCoordinates: boolean = true);
    132132    function GetBounds: TRect; override;
    133133    function SegmentsCurved: boolean; override;
     
    161161    function NbMaxIntersection: integer; override;
    162162    procedure SetIntersectionValues(AInter: TIntersectionInfo; AInterX: Single; AWinding, ANumSegment: integer; {%H-}dy: single; {%H-}AData: pointer); virtual;
     163    procedure InitPoints(const points: array of TPointF);
    163164  public
    164     constructor Create(const points: array of TPointF);
     165    constructor Create(const points: array of TPointF; APixelCenteredCoordinates: boolean = true);
    165166    function CreateSegmentData(numPt,nextPt: integer; x,y: single): pointer; virtual;
    166167    procedure FreeSegmentData(data: pointer); virtual;
     
    180181      var inter: ArrayOfTIntersectionInfo; var nbInter: integer); override;
    181182  public
    182     constructor Create(const points: array of TPointF);
     183    constructor Create(const points: array of TPointF; APixelCenteredCoordinates: boolean = true);
    183184    destructor Destroy; override;
    184185    function GetSliceIndex: integer; override;
     
    216217      var inter: ArrayOfTIntersectionInfo; var nbInter: integer); override;
    217218  public
    218     constructor Create(const points: array of TPointF);
     219    constructor Create(const points: array of TPointF; APixelCenteredCoordinates: boolean = true);
    219220    function CreateIntersectionArray: ArrayOfTIntersectionInfo; override;
    220221    function GetSliceIndex: integer; override;
     
    454455procedure TFillShapeInfo.SortIntersection(var inter: ArrayOfTIntersectionInfo; nbInter: integer);
    455456var
    456   i,j: Integer;
     457  i,j,k: Integer;
    457458  tempInter: TIntersectionInfo;
    458459begin
     
    460461  begin
    461462    j := i;
    462     while (j > 0) and (inter[j - 1].interX > inter[j].interX) do
    463     begin
    464       tempInter    := inter[j - 1];
    465       inter[j - 1] := inter[j];
    466       inter[j]     := tempInter;
    467       Dec(j);
     463    while (j > 0) and (inter[i].interX < inter[j-1].interX) do dec(j);
     464    if j <> i then
     465    begin
     466      tempInter := inter[i];
     467      for k := i-1 downto j do
     468        inter[k+1] := inter[k];
     469      inter[j]  := tempInter;
    468470    end;
    469471  end;
     
    482484    if (windingSum = 0) xor (prevSum = 0) then
    483485    begin
    484       tempInfo := inter[nbAlternate];
    485       inter[nbAlternate] := inter[i];
    486       inter[i] := tempInfo;
     486      if nbAlternate<>i then
     487      begin
     488        tempInfo := inter[nbAlternate];
     489        inter[nbAlternate] := inter[i];
     490        inter[i] := tempInfo;
     491      end;
    487492      inc(nbAlternate);
    488493    end;
     
    628633{ TCustomFillPolyInfo }
    629634
    630 constructor TCustomFillPolyInfo.Create(const points: array of TPointF);
     635constructor TCustomFillPolyInfo.Create(const points: array of TPointF; APixelCenteredCoordinates: boolean);
    631636var
    632   i, j: integer;
    633   First, cur, nbP: integer;
    634 begin
    635   setlength(FPoints, length(points));
    636   nbP := 0;
    637   first := -1;
    638   for i := 0 to high(points) do
    639   if isEmptyPointF(points[i]) then
    640   begin
    641     if first<>-1 then
    642     begin
    643       if nbP = first+1 then //is there only one point?
    644       begin
    645         dec(nbP);
    646         first := -1; //remove subpolygon
    647       end else
    648       if (FPoints[nbP-1] = FPoints[first]) then
    649         dec(nbP); //remove just last looping point
    650     end;
    651     if first<>-1 then
    652     begin
    653       FPoints[nbP] := points[i];
    654       inc(nbP);
    655       first := -1;
    656     end;
    657   end else
    658   if (first=-1) or (points[i]<>points[i-1]) then
    659   begin
    660     if first = -1 then first := nbP;
    661     FPoints[nbP] := points[i];
    662     inc(nbP);
    663   end;
    664   setlength(FPoints, nbP);
     637  cur, first, i, j: integer;
     638
     639begin
     640  InitPoints(points);
    665641
    666642  //look for empty points, correct coordinate and successors
     
    669645
    670646  cur   := -1;
    671   First := -1;
     647  first := -1;
    672648  for i := 0 to high(FPoints) do
    673649    if not isEmptyPointF(FPoints[i]) then
    674650    begin
    675651      FEmptyPt[i]  := False;
    676       FPoints[i].x += 0.5;
    677       FPoints[i].y += 0.5;
     652      if APixelCenteredCoordinates then
     653      begin
     654        FPoints[i].x += 0.5;
     655        FPoints[i].y += 0.5;
     656      end;
    678657      if cur <> -1 then
    679658        FNext[cur] := i;
    680       if First = -1 then
    681         First := i;
     659      if first = -1 then
     660        first := i;
    682661      cur     := i;
    683662    end
    684663    else
    685664    begin
    686       if (First <> -1) and (cur <> First) then
    687         FNext[cur] := First;
     665      if (first <> -1) and (cur <> first) then
     666        FNext[cur] := first;
    688667
    689668      FEmptyPt[i] := True;
    690669      FNext[i] := -1;
    691670      cur   := -1;
    692       First := -1;
    693     end;
    694   if (First <> -1) and (cur <> First) then
    695     FNext[cur] := First;
     671      first := -1;
     672    end;
     673  if (first <> -1) and (cur <> first) then
     674    FNext[cur] := first;
    696675
    697676  setlength(FPrev, length(FPoints));
     
    779758end;
    780759
     760procedure TCustomFillPolyInfo.InitPoints(const points: array of TPointF);
     761const
     762  minDist = 0.00390625; //1 over 256
     763
     764var
     765  i, first, nbP: integer;
     766
     767  function PointAlmostEqual(const p1,p2: TPointF): boolean;
     768  begin
     769    result := (abs(p1.x-p2.x) < minDist) and (abs(p1.y-p2.y) < minDist);
     770  end;
     771
     772  procedure EndOfSubPolygon;
     773  begin
     774    //if there is a subpolygon
     775    if first<>-1 then
     776    begin
     777      //last point is the same as first point?
     778      if (nbP >= first+2) and PointAlmostEqual(FPoints[nbP-1],FPoints[first]) then
     779        dec(nbP); //remove superfluous looping point
     780
     781      if (nbP <= first+2) then //are there only one or two points?
     782      begin
     783        //remove subpolygon because we need at least a triangle
     784        nbP := first;
     785        first := -1;
     786      end;
     787
     788    end;
     789  end;
     790
     791begin
     792  setlength(FPoints, length(points));
     793  nbP := 0;
     794  first := -1;
     795  for i := 0 to high(points) do
     796  if isEmptyPointF(points[i]) then
     797  begin
     798    EndOfSubPolygon;
     799    if first<>-1 then
     800    begin
     801      FPoints[nbP] := EmptyPointF;
     802      inc(nbP);
     803      first := -1;
     804    end;
     805  end else
     806  if (first=-1) or not PointAlmostEqual(FPoints[nbP-1],points[i]) then
     807  begin
     808    if first = -1 then first := nbP;
     809    FPoints[nbP] := points[i];
     810    inc(nbP);
     811  end;
     812  EndOfSubPolygon;
     813  //if last point was a subpolygon delimiter (EmptyPointF) then removes it
     814  if (nbP > 0) and isEmptyPointF(FPoints[nbP-1]) then dec(nbP);
     815
     816  setlength(FPoints, nbP);
     817end;
     818
    781819{ TFillPolyInfo }
    782820
     
    807845end;
    808846
    809 constructor TFillPolyInfo.Create(const points: array of TPointF);
     847constructor TFillPolyInfo.Create(const points: array of TPointF; APixelCenteredCoordinates: boolean);
    810848  function AddSeg(numSlice: integer): integer;
    811849  begin
     
    824862
    825863begin
    826   inherited Create(points);
     864  inherited Create(points, APixelCenteredCoordinates);
    827865
    828866  //slice
     
    10421080end;
    10431081
    1044 constructor TOnePassFillPolyInfo.Create(const points: array of TPointF);
     1082constructor TOnePassFillPolyInfo.Create(const points: array of TPointF; APixelCenteredCoordinates: boolean);
    10451083var i,j: integer;
    10461084  p: POnePassRecord;
    10471085  temp: single;
    10481086begin
    1049   inherited create(points);
     1087  inherited create(points, APixelCenteredCoordinates);
    10501088
    10511089  FShouldInitializeDrawing := true;
     
    12931331{ TFillRoundRectangleInfo }
    12941332
    1295 constructor TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry: single; options: TRoundRectangleOptions);
     1333constructor TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry: single; options: TRoundRectangleOptions; APixelCenteredCoordinates: boolean);
    12961334var
    12971335  temp: Single;
     
    13091347    x2 := temp;
    13101348  end;
    1311   FX1  := x1 + 0.5;
    1312   FY1  := y1 + 0.5;
    1313   FX2  := x2 + 0.5;
    1314   FY2  := y2 + 0.5;
     1349  if APixelCenteredCoordinates then
     1350  begin
     1351    FX1  := x1 + 0.5;
     1352    FY1  := y1 + 0.5;
     1353    FX2  := x2 + 0.5;
     1354    FY2  := y2 + 0.5;
     1355  end else
     1356  begin
     1357    FX1 := x1;
     1358    FY1 := y1;
     1359    FX2 := x2;
     1360    FY2 := y2;
     1361  end;
    13151362  FRX := abs(rx);
    13161363  FRY := abs(ry);
     
    14221469{ TFillBorderRoundRectInfo }
    14231470
    1424 constructor TFillBorderRoundRectInfo.Create(x1, y1, x2, y2, rx, ry, w: single; options: TRoundRectangleOptions);
     1471constructor TFillBorderRoundRectInfo.Create(x1, y1, x2, y2, rx, ry, w: single; options: TRoundRectangleOptions; APixelCenteredCoordinates: boolean);
    14251472var rdiff: single;
    14261473  temp: Single;
     
    14461493  if 2*ry > y2-y1 then ry := (y2-y1)/2;
    14471494  rdiff := w*(sqrt(2)-1);
    1448   FOuterBorder := TFillRoundRectangleInfo.Create(x1-w/2,y1-w/2,x2+w/2,y2+w/2, rx+rdiff, ry+rdiff, options);
     1495  FOuterBorder := TFillRoundRectangleInfo.Create(x1-w/2,y1-w/2,x2+w/2,y2+w/2, rx+rdiff, ry+rdiff, options, APixelCenteredCoordinates);
    14491496  if (abs(x2-x1) > w) and (abs(y2-y1) > w) then
    14501497  begin
    14511498    if (rx-rdiff <= 0) or (ry-rdiff <= 0) then
    1452       FInnerBorder := TFillRoundRectangleInfo.Create(x1+w/2, y1+w/2, x2-w/2, y2-w/2, 0,0, options)
     1499      FInnerBorder := TFillRoundRectangleInfo.Create(x1+w/2, y1+w/2, x2-w/2, y2-w/2, 0,0, options, APixelCenteredCoordinates)
    14531500    else
    1454       FInnerBorder := TFillRoundRectangleInfo.Create(x1+w/2, y1+w/2, x2-w/2, y2-w/2, rx-rdiff, ry-rdiff, options);
     1501      FInnerBorder := TFillRoundRectangleInfo.Create(x1+w/2, y1+w/2, x2-w/2, y2-w/2, rx-rdiff, ry-rdiff, options, APixelCenteredCoordinates);
    14551502    FInnerBorder.WindingFactor := -1;
    14561503  end
  • GraphicTest/Packages/bgrabitmap/bgrafilterblur.pas

    r494 r521  
    3232  public
    3333    constructor Create(bmp: TBGRACustomBitmap; ABounds: TRect; radius: single;
    34                        blurType: TRadialBlurType);
     34                       blurType: TRadialBlurType); overload;
    3535    constructor Create(bmp: TBGRACustomBitmap; ABounds: TRect; radiusX,radiusY: single;
    36                        blurType: TRadialBlurType);
     36                       blurType: TRadialBlurType); overload;
    3737  protected
    3838    procedure DoExecute; override;
     
    5757
    5858procedure FilterBlur(bmp: TBGRACustomBitmap; ABounds: TRect;
    59    blurMask: TBGRACustomBitmap; ADestination: TBGRACustomBitmap; ACheckShouldStop: TCheckShouldStopFunc); forward;
     59   blurMask: TBGRACustomBitmap; ADestination: TBGRACustomBitmap; ACheckShouldStop: TCheckShouldStopFunc); forward; overload;
    6060procedure FilterBlurMotion(bmp: TBGRACustomBitmap; ABounds: TRect; distance: single;
    61   angle: single; oriented: boolean; ADestination: TBGRACustomBitmap; ACheckShouldStop: TCheckShouldStopFunc); forward;
     61  angle: single; oriented: boolean; ADestination: TBGRACustomBitmap; ACheckShouldStop: TCheckShouldStopFunc); forward; overload;
    6262procedure FilterBlurRadial(bmp: TBGRACustomBitmap; ABounds: TRect; radiusX,radiusY: single;
    63   blurType: TRadialBlurType; ADestination: TBGRACustomBitmap; ACheckShouldStop: TCheckShouldStopFunc); forward;
     63  blurType: TRadialBlurType; ADestination: TBGRACustomBitmap; ACheckShouldStop: TCheckShouldStopFunc); forward; overload;
    6464
    6565type
     
    7171    FRadiusX,FRadiusY: single;
    7272  public
    73     constructor Create(bmp: TBGRACustomBitmap; ABounds: TRect; radius: single);
    74     constructor Create(bmp: TBGRACustomBitmap; ABounds: TRect; radiusX,radiusY: single);
     73    constructor Create(bmp: TBGRACustomBitmap; ABounds: TRect; radius: single); overload;
     74    constructor Create(bmp: TBGRACustomBitmap; ABounds: TRect; radiusX,radiusY: single); overload;
    7575  protected
    7676    {$IFNDEF CPU64}
     
    310310
    311311procedure FilterBlurRadial(bmp: TBGRACustomBitmap; ABounds: TRect; radius: single;
    312   blurType: TRadialBlurType; ADestination: TBGRACustomBitmap; ACheckShouldStop: TCheckShouldStopFunc);
     312  blurType: TRadialBlurType; ADestination: TBGRACustomBitmap; ACheckShouldStop: TCheckShouldStopFunc); overload;
    313313begin
    314314  if radius = 0 then
     
    347347end;
    348348
    349 function FilterBlurRadial(bmp: TBGRACustomBitmap; radius: single;
    350   blurType: TRadialBlurType): TBGRACustomBitmap;
     349function FilterBlurRadial(bmp: TBGRACustomBitmap; radius: single; blurType: TRadialBlurType): TBGRACustomBitmap;  overload;
    351350begin
    352351  if blurType = rbBox then
     
    361360
    362361function FilterBlurRadial(bmp: TBGRACustomBitmap; radiusX: single;
    363   radiusY: single; blurType: TRadialBlurType): TBGRACustomBitmap;
     362  radiusY: single; blurType: TRadialBlurType): TBGRACustomBitmap; overload;
    364363begin
    365364  if blurType = rbBox then
     
    374373
    375374function CreateRadialBlurTask(ABmp: TBGRACustomBitmap; ABounds: TRect; ARadius: single;
    376   ABlurType: TRadialBlurType): TFilterTask;
     375  ABlurType: TRadialBlurType): TFilterTask; overload;
    377376begin
    378377  if ABlurType = rbBox then
     
    383382
    384383function CreateRadialBlurTask(ABmp: TBGRACustomBitmap; ABounds: TRect;
    385   ARadiusX, ARadiusY: single; ABlurType: TRadialBlurType): TFilterTask;
     384  ARadiusX, ARadiusY: single; ABlurType: TRadialBlurType): TFilterTask; overload;
    386385begin
    387386  if ABlurType = rbBox then
     
    432431
    433432function FilterBlurMotion(bmp: TBGRACustomBitmap; distance: single;
    434   angle: single; oriented: boolean): TBGRACustomBitmap;
     433  angle: single; oriented: boolean): TBGRACustomBitmap;  overload;
    435434begin
    436435  result := bmp.NewBitmap(bmp.Width,bmp.Height);
     
    463462end;
    464463
    465 function FilterBlur(bmp: TBGRACustomBitmap; blurMask: TBGRACustomBitmap): TBGRACustomBitmap;
     464function FilterBlur(bmp: TBGRACustomBitmap; blurMask: TBGRACustomBitmap): TBGRACustomBitmap; overload;
    466465begin
    467466  result := bmp.NewBitmap(bmp.Width,bmp.Height);
  • GraphicTest/Packages/bgrabitmap/bgrafilters.pas

    r494 r521  
    2929
    3030{ Grayscale converts colored pixel into grayscale with same luminosity }
    31 function FilterGrayscale(bmp: TBGRACustomBitmap): TBGRACustomBitmap;
    32 function FilterGrayscale(bmp: TBGRACustomBitmap; ABounds: TRect): TBGRACustomBitmap;
     31function FilterGrayscale(bmp: TBGRACustomBitmap): TBGRACustomBitmap; overload;
     32function FilterGrayscale(bmp: TBGRACustomBitmap; ABounds: TRect): TBGRACustomBitmap; overload;
    3333function CreateGrayscaleTask(bmp: TBGRACustomBitmap; ABounds: TRect): TFilterTask;
    3434
     
    3636  and light colors lightest possible }
    3737function FilterNormalize(bmp: TBGRACustomBitmap;
    38   eachChannel: boolean = True): TBGRACustomBitmap;
     38  eachChannel: boolean = True): TBGRACustomBitmap; overload;
    3939function FilterNormalize(bmp: TBGRACustomBitmap; ABounds: TRect;
    40   eachChannel: boolean = True): TBGRACustomBitmap;
     40  eachChannel: boolean = True): TBGRACustomBitmap; overload;
    4141
    4242////////////////////// 3X3 FILTERS ////////////////////////////////////////////
    4343
    4444{ Sharpen filter add more contrast between pixels }
    45 function FilterSharpen(bmp: TBGRACustomBitmap; AAmount: integer = 256): TBGRACustomBitmap;
    46 function FilterSharpen(bmp: TBGRACustomBitmap; ABounds: TRect; AAmount: integer = 256): TBGRACustomBitmap;
     45function FilterSharpen(bmp: TBGRACustomBitmap; AAmount: integer = 256): TBGRACustomBitmap; overload;
     46function FilterSharpen(bmp: TBGRACustomBitmap; ABounds: TRect; AAmount: integer = 256): TBGRACustomBitmap; overload;
    4747
    4848{ Compute a contour, as if the image was drawn with a 2 pixels-wide black pencil }
     
    5050
    5151{ Emboss filter compute a color difference in the angle direction }
    52 function FilterEmboss(bmp: TBGRACustomBitmap; angle: single; AStrength: integer= 64; AOptions: TEmbossOptions = []): TBGRACustomBitmap;
    53 function FilterEmboss(bmp: TBGRACustomBitmap; angle: single; ABounds: TRect; AStrength: integer= 64; AOptions: TEmbossOptions = []): TBGRACustomBitmap;
     52function FilterEmboss(bmp: TBGRACustomBitmap; angle: single; AStrength: integer= 64; AOptions: TEmbossOptions = []): TBGRACustomBitmap; overload;
     53function FilterEmboss(bmp: TBGRACustomBitmap; angle: single; ABounds: TRect; AStrength: integer= 64; AOptions: TEmbossOptions = []): TBGRACustomBitmap; overload;
    5454
    5555{ Emboss highlight computes a sort of emboss with 45 degrees angle and
     
    7272
    7373{ Twirl distortion, i.e. a progressive rotation }
    74 function FilterTwirl(bmp: TBGRACustomBitmap; ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap;
    75 function FilterTwirl(bmp: TBGRACustomBitmap; ABounds: TRect; ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap;
     74function FilterTwirl(bmp: TBGRACustomBitmap; ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap; overload;
     75function FilterTwirl(bmp: TBGRACustomBitmap; ABounds: TRect; ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap; overload;
    7676
    7777{ Distort the image as if it were on a vertical cylinder }
     
    9191  with rbFast blur, the optimization entails an hyperbolic shape. }
    9292type TRadialBlurTask = BGRAFilterBlur.TRadialBlurTask;
    93 function FilterBlurRadial(bmp: TBGRACustomBitmap; radius: single; blurType: TRadialBlurType): TBGRACustomBitmap;
    94 function FilterBlurRadial(bmp: TBGRACustomBitmap; radiusX: single; radiusY: single; blurType: TRadialBlurType): TBGRACustomBitmap;
    95 function CreateRadialBlurTask(ABmp: TBGRACustomBitmap; ABounds: TRect; ARadius: single; ABlurType: TRadialBlurType): TRadialBlurTask;
    96 function CreateRadialBlurTask(ABmp: TBGRACustomBitmap; ABounds: TRect; ARadiusX,ARadiusY: single; ABlurType: TRadialBlurType): TRadialBlurTask;
     93function FilterBlurRadial(bmp: TBGRACustomBitmap; radius: single; blurType: TRadialBlurType): TBGRACustomBitmap; overload;
     94function FilterBlurRadial(bmp: TBGRACustomBitmap; radiusX: single; radiusY: single; blurType: TRadialBlurType): TBGRACustomBitmap; overload;
     95function CreateRadialBlurTask(ABmp: TBGRACustomBitmap; ABounds: TRect; ARadius: single; ABlurType: TRadialBlurType): TRadialBlurTask; overload;
     96function CreateRadialBlurTask(ABmp: TBGRACustomBitmap; ABounds: TRect; ARadiusX,ARadiusY: single; ABlurType: TRadialBlurType): TRadialBlurTask; overload;
    9797
    9898{ The precise blur allow to specify the blur radius with subpixel accuracy }
  • GraphicTest/Packages/bgrabitmap/bgrafilterscanner.pas

    r494 r521  
    6161      ADest: PBGRAPixel; ACount: integer); override;
    6262  public
    63     constructor Create(ASource: IBGRAScanner; ABounds: TRect);
    64     constructor Create(ASource: TBGRACustomBitmap);
     63    constructor Create(ASource: IBGRAScanner; ABounds: TRect); overload;
     64    constructor Create(ASource: TBGRACustomBitmap); overload;
    6565    property SourceBorderColor: TBGRAPixel read FSourceBorderColor write FSourceBorderColor;
    6666    property DestinationBorderColor: TBGRAPixel read FDestinationBorderColor write FDestinationBorderColor;
     
    7979  public
    8080    constructor Create(ASource: IBGRAScanner; ABounds: TRect;
    81                        AGammaCorrection: boolean = False);
     81                       AGammaCorrection: boolean = False); overload;
    8282    constructor Create(ASource: TBGRACustomBitmap;
    83                        AGammaCorrection: boolean = False);
     83                       AGammaCorrection: boolean = False); overload;
    8484    property Opacity: Byte read FOpacity write FOpacity;
    8585  end;
     
    9393  public
    9494    constructor Create(ASource: IBGRAScanner; ABounds: TRect;
    95                        AAmount: integer = 256);
     95                       AAmount: integer = 256); overload;
    9696    constructor Create(ASource: TBGRACustomBitmap;
    97                        AAmount: integer = 256);
     97                       AAmount: integer = 256); overload;
    9898  end;
    9999
     
    108108    procedure SetSourceChannel(AValue: TChannel);
    109109  public
    110     constructor Create(ASource: IBGRAScanner; ABounds: TRect; ABoundsVisible: Boolean);
    111     constructor Create(ASource: TBGRACustomBitmap; ABoundsVisible: Boolean);
     110    constructor Create(ASource: IBGRAScanner; ABounds: TRect; ABoundsVisible: Boolean); overload;
     111    constructor Create(ASource: TBGRACustomBitmap; ABoundsVisible: Boolean); overload;
    112112    property FillSelection: boolean read FFillSelection write FFillSelection;
    113113    property SourceChannel: TChannel read FSourceChannel write SetSourceChannel;
     
    138138  highlight: TBGRAPixel;
    139139begin
    140   sum := (PByte(PTop)+FChannelOffset)^ + (PByte(PTop+1)+FChannelOffset)^+
    141          (PByte(PMiddle)+FChannelOffset)^ - (PByte(PMiddle+2)+FChannelOffset)^ -
    142          (PByte(PBottom+1)+FChannelOffset)^ - (PByte(PBottom+2)+FChannelOffset)^;
     140  sum := NativeInt((PByte(PTop)+FChannelOffset)^) +
     141         NativeInt((PByte(PTop+1)+FChannelOffset)^) +
     142         NativeInt((PByte(PMiddle)+FChannelOffset)^) -
     143         NativeInt((PByte(PMiddle+2)+FChannelOffset)^) -
     144         NativeInt((PByte(PBottom+1)+FChannelOffset)^) -
     145         NativeInt((PByte(PBottom+2)+FChannelOffset)^);
    143146  sum := 128 - sum div 3;
    144147  if sum > 255 then
     
    711714      begin
    712715        if ADest^.alpha <> 0 then
    713           DWord(ADest^) := DWord(ADest^) xor (not ($ff shl TBGRAPixel_AlphaShift));
     716          DWord(ADest^) := DWord(ADest^) xor ($ffffffff and not ($ff shl TBGRAPixel_AlphaShift));
    714717        Inc(ADest);
    715718        dec(ACount);
     
    738741          ADest^ := BGRAPixelTransparent
    739742        else
    740           DWord(ADest^) := DWord(ASource^) xor (not ($ff shl TBGRAPixel_AlphaShift));
     743          DWord(ADest^) := DWord(ASource^) xor ($ffffffff and not ($ff shl TBGRAPixel_AlphaShift));
    741744        inc(ASource);
    742745        Inc(ADest);
  • GraphicTest/Packages/bgrabitmap/bgrafontgl.pas

    r494 r521  
    107107    function CreateGlyph(AIdentifier: string): TRenderedGlyph; virtual;
    108108    procedure CopyFontToRenderer; virtual;
    109     procedure DoTextOut(X, Y: Single; const Text : UTF8String; AColor: TBGRAPixel; AHorizontalAlign: TAlignment; AVerticalAlign: TTextLayout); virtual;
    110     procedure DoTextOut(X, Y: Single; const Text : UTF8String; AColor: TBGRAPixel); override;
     109    procedure DoTextOut(X, Y: Single; const Text : UTF8String; AColor: TBGRAPixel; AHorizontalAlign: TAlignment; AVerticalAlign: TTextLayout); overload; virtual;
     110    procedure DoTextOut(X, Y: Single; const Text : UTF8String; AColor: TBGRAPixel); overload; override;
    111111    procedure DoTextRect(X, Y, Width, Height: Single; const Text : UTF8String; AColor: TBGRAPixel); override;
    112112    function GetClipped: boolean; override;
  • GraphicTest/Packages/bgrabitmap/bgrafpguibitmap.pas

    r494 r521  
    4646    procedure TakeScreenshot({%H-}ARect: TRect); override; //not available
    4747    procedure TakeScreenshotOfPrimaryMonitor; override; //not available
    48     procedure LoadFromDevice({%H-}DC: System.THandle); override; //not available
    49     procedure LoadFromDevice({%H-}DC: System.THandle; {%H-}ARect: TRect); override; //not available
     48    procedure LoadFromDevice({%H-}DC: HDC); override; //not available
     49    procedure LoadFromDevice({%H-}DC: HDC; {%H-}ARect: TRect); override; //not available
    5050    property BitmapTransparent: boolean read GetBitmapTransparent write SetBitmapTransparent;
    5151    property Canvas: TBGRACanvas read GetPseudoCanvas;
     
    254254end;
    255255
    256 procedure TBGRAfpGUIBitmap.LoadFromDevice(DC: System.THandle);
    257 begin
    258   NotAvailable;
    259 end;
    260 
    261 procedure TBGRAfpGUIBitmap.LoadFromDevice(DC: System.THandle; ARect: TRect);
     256procedure TBGRAfpGUIBitmap.LoadFromDevice(DC: HDC);
     257begin
     258  NotAvailable;
     259end;
     260
     261procedure TBGRAfpGUIBitmap.LoadFromDevice(DC: HDC; ARect: TRect);
    262262begin
    263263  NotAvailable;
  • GraphicTest/Packages/bgrabitmap/bgrafreetype.pas

    r494 r521  
    5151    procedure UpdateFont;
    5252    procedure Init;
     53    procedure TextOutAnglePatch(ADest: TBGRACustomBitmap; x, y: single; orientation: integer; s: string;
     54              c: TBGRAPixel; tex: IBGRAScanner; align: TAlignment);
    5355  public
    5456    FontHinted: boolean;
     
    6668    OutlineTexture: IBGRAScanner;
    6769
    68     constructor Create;
    69     constructor Create(AShader: TCustomPhongShading; AShaderOwner: boolean);
     70    constructor Create; overload;
     71    constructor Create(AShader: TCustomPhongShading; AShaderOwner: boolean); overload;
    7072    function GetFontPixelMetric: TFontPixelMetric; override;
    71     procedure TextOutAngle({%H-}ADest: TBGRACustomBitmap; {%H-}x, {%H-}y: single; {%H-}orientation: integer; {%H-}s: string; {%H-}c: TBGRAPixel; {%H-}align: TAlignment); override;
    72     procedure TextOutAngle({%H-}ADest: TBGRACustomBitmap; {%H-}x, {%H-}y: single; {%H-}orientation: integer; {%H-}s: string; {%H-}texture: IBGRAScanner; {%H-}align: TAlignment); override;
    73     procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; s: string; texture: IBGRAScanner; align: TAlignment); override;
    74     procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; s: string; c: TBGRAPixel; align: TAlignment); override;
    75     procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; s: string; style: TTextStyle; c: TBGRAPixel); override;
    76     procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; s: string; style: TTextStyle; texture: IBGRAScanner); override;
    77     function TextSize(s: string): TSize; override;
     73    procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientation: integer; s: string; c: TBGRAPixel; align: TAlignment); overload; override;
     74    procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientation: integer; s: string; texture: IBGRAScanner; align: TAlignment); overload; override;
     75    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; s: string; texture: IBGRAScanner; align: TAlignment); overload; override;
     76    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; s: string; c: TBGRAPixel; align: TAlignment); overload; override;
     77    procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; s: string; style: TTextStyle; c: TBGRAPixel); overload; override;
     78    procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; s: string; style: TTextStyle; texture: IBGRAScanner); overload; override;
     79    function TextSize(s: string): TSize; overload; override;
     80    function TextSize(sUTF8: string; AMaxWidth: integer; {%H-}ARightToLeft: boolean): TSize; overload; override;
     81    function TextFitInfo(sUTF8: string; AMaxWidth: integer): integer; override;
    7882    destructor Destroy; override;
    7983    property Collection: TCustomFreeTypeFontCollection read GetCollection;
     
    112116
    113117    constructor Create(ADestination: TBGRACustomBitmap);
    114     procedure DrawText(AText: string; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TFPColor); override; overload;
     118    procedure DrawText(AText: string; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TFPColor); overload; override;
    115119    procedure DrawText(AText: string; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TBGRAPixel); overload;
    116120    procedure DrawText(AText: string; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TBGRAPixel; AAlign: TFreeTypeAlignments); overload;
     
    122126    {$ENDIF}
    123127    {$IFDEF BGRABITMAP_USE_LCL15}
    124     procedure DrawGlyph(AGlyph: integer; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TFPColor); override; overload;
     128    procedure DrawGlyph(AGlyph: integer; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TFPColor); overload; override;
    125129    procedure DrawGlyph(AGlyph: integer; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TBGRAPixel); overload;
    126130    procedure DrawGlyph(AGlyph: integer; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TBGRAPixel; AAlign: TFreeTypeAlignments); overload;
     
    133137implementation
    134138
    135 uses BGRABlend, Math;
     139uses BGRABlend, Math, BGRATransform;
    136140
    137141{ TBGRAFreeTypeFontRenderer }
     
    242246end;
    243247
     248procedure TBGRAFreeTypeFontRenderer.TextOutAnglePatch(ADest: TBGRACustomBitmap;
     249  x, y: single; orientation: integer; s: string; c: TBGRAPixel;
     250  tex: IBGRAScanner; align: TAlignment);
     251const orientationToDeg = -0.1;
     252var
     253  temp: TBGRACustomBitmap;
     254  coord: TPointF;
     255  angleDeg: single;
     256  OldOrientation: integer;
     257  filter: TResampleFilter;
     258  OldFontQuality: TBGRAFontQuality;
     259begin
     260  OldOrientation := FontOrientation;
     261  FontOrientation:= 0;
     262  OldFontQuality := FontQuality;
     263
     264  if FontQuality in[fqFineClearTypeRGB,fqFineClearTypeBGR] then FontQuality:= fqFineAntialiasing
     265  else if FontQuality = fqSystemClearType then FontQuality:= fqSystem;
     266
     267  temp := BGRABitmapFactory.Create;
     268  with TextSize(s) do
     269    temp.SetSize(cx,cy);
     270  temp.FillTransparent;
     271  if tex<>nil then
     272    TextOut(temp,0,0, s, tex, taLeftJustify)
     273  else
     274    TextOut(temp,0,0, s, c, taLeftJustify);
     275
     276  orientation:= orientation mod 3600;
     277  if orientation < 0 then orientation += 3600;
     278
     279  angleDeg := orientation * orientationToDeg;
     280  coord := PointF(x,y);
     281  case align of
     282  taRightJustify: coord -= AffineMatrixRotationDeg(angleDeg)*PointF(temp.Width,0);
     283  taCenter: coord -= AffineMatrixRotationDeg(angleDeg)*PointF(temp.Width,0)*0.5;
     284  end;
     285  case orientation of
     286  0,900,1800,2700: filter := rfBox;
     287  else filter := rfCosine;
     288  end;
     289  ADest.PutImageAngle(coord.x,coord.y, temp, angleDeg, filter);
     290  temp.Free;
     291
     292  FontOrientation:= OldOrientation;
     293  FontQuality:= OldFontQuality;
     294end;
     295
    244296constructor TBGRAFreeTypeFontRenderer.Create;
    245297begin
     
    269321  y: single; orientation: integer; s: string; c: TBGRAPixel; align: TAlignment);
    270322begin
     323  TextOutAnglePatch(ADest, x,y, orientation, s, c, nil, align);
     324{procedure TForm1.TextOutAnglePatch(ADest: TBGRABitmap;
     325  x, y: single; orientationTenthDegCCW: integer;
     326  s: string; c: TBGRAPixel; AAlign: TAlignment; AResampleFilter: TResampleFilter);
     327const orientationToDeg = -0.1;
     328var
     329  temp: TBGRABitmap;
     330  coord: TPointF;
     331  angleDeg: single;
     332begin
     333  temp := TBGRABitmap.Create;
     334  ADest.CopyPropertiesTo(temp);
     335  temp.FontOrientation := 0;
     336  with temp.TextSize(s) do
     337    temp.SetSize(cx,cy);
     338  temp.FillTransparent;
     339+
     340  temp.TextOut(0,0, s, c);
     341
     342  angleDeg := orientationTenthDegCCW * orientationToDeg;
     343  coord := PointF(x,y);
     344  case AAlign of
     345  taRightJustify: coord -= AffineMatrixRotationDeg(angleDeg)*PointF(temp.Width,0);
     346  taCenter: coord -= AffineMatrixRotationDeg(angleDeg)*PointF(temp.Width,0)*0.5;
     347  end;
     348
     349  ADest.PutImageAngle(coord.x,coord.y, temp, angleDeg, rfBox);
     350  temp.Free;
     351end;           }
    271352
    272353end;
     
    276357  align: TAlignment);
    277358begin
    278 
     359  TextOutAnglePatch(ADest, x,y, orientation, s, BGRAPixelTransparent, texture, align);
    279360end;
    280361
     
    368449  result.cx := round(FFont.TextWidth(s));
    369450  result.cy := round(FFont.LineFullHeight);
     451end;
     452
     453function TBGRAFreeTypeFontRenderer.TextSize(sUTF8: string; AMaxWidth: integer;
     454  ARightToLeft: boolean): TSize;
     455var
     456  remains: string;
     457  w,h,totalH: single;
     458begin
     459  UpdateFont;
     460
     461  result.cx := 0;
     462  totalH := 0;
     463  h := FFont.LineFullHeight;
     464  repeat
     465    FFont.SplitText(sUTF8, AMaxWidth, remains);
     466    w := FFont.TextWidth(sUTF8);
     467    if round(w)>result.cx then result.cx := round(w);
     468    totalH += h;
     469    sUTF8 := remains;
     470  until remains = '';
     471  result.cy := ceil(totalH);
     472end;
     473
     474function TBGRAFreeTypeFontRenderer.TextFitInfo(sUTF8: string; AMaxWidth: integer): integer;
     475var
     476  remains: string;
     477begin
     478  UpdateFont;
     479  FFont.SplitText(sUTF8, AMaxWidth, remains);
     480  result := length(sUTF8);
    370481end;
    371482
  • GraphicTest/Packages/bgrabitmap/bgragifformat.pas

    r494 r521  
    7272    AspectRatio: single;
    7373    BackgroundColor: TColor;
     74    LoopCount: Word;
    7475    Images: array of TGifSubImage;
    7576  end;
     
    8990  GIFExtensionIntroducer = $21;
    9091  GIFBlockTerminator     = $00;
     92  GIFFileTerminator      = $3B;
    9193
    9294  GIFGraphicControlExtension_TransparentFlag = $01;  //transparent color index is provided
     
    104106  GIFCodeTableSize = 4096;
    105107
     108  NetscapeApplicationIdentifier = 'NETSCAPE2.0';
     109  NetscapeSubBlockIdLoopCount = 1;
     110  NetscapeSubBlockIdBuffering = 2;
     111
    106112function CeilLn2(AValue: Integer): integer;
    107113function BGRAToPackedRgbTriple(color: TBGRAPixel): TPackedRGBTriple;
    108114function PackedRgbTribleToBGRA(rgb: TPackedRGBTriple): TBGRAPixel;
    109 function GIFLoadFromStream(stream: TStream): TGIFData;
     115function GIFLoadFromStream(stream: TStream; MaxImageCount: integer = maxLongint): TGIFData;
    110116procedure GIFSaveToStream(AData: TGifData; Stream: TStream; AQuantizerFactory: TBGRAColorQuantizerAny;
    111117          ADitheringAlgorithm: TDitheringAlgorithm);
     
    117123//Adapted from the work of Udo Schmal, http://www.gocher.me/FPWriteGIF
    118124procedure GIFEncodeLZW(AStream: TStream; AImageData: PByte;
    119           AImageWidth, AImageHeight: integer; ABitDepth: integer);
     125          AImageWidth, AImageHeight: integer; ABitDepth: byte);
    120126
    121127implementation
     
    224230      if (bytinbuf = 0) then
    225231      begin
    226         AStream.Read(bytinbuf, 1);
     232        if AStream.Read(bytinbuf, 1) <> 1 then
     233          raise exception.Create('Unexpected end of stream');
     234
    227235        if (bytinbuf = 0) then
     236        begin
    228237          endofsrc := True;
     238          result := endcode;
     239          exit;
     240        end;
    229241        AStream.Read(bytbuf, bytinbuf);
    230242        bytbufidx := 0;
     
    238250    bitbuf := bitbuf shr codelen;
    239251    Dec(bitsinbuf, codelen);
     252    //write(inttostr(result)+'@'+inttostr(codelen)+' ');
    240253  end;
    241254
     
    278291      if interlaced then
    279292      begin
    280         while (ycnt >= yd) and (pass < 5) do
    281         begin
     293        while ycnt >= yd do
     294        begin
     295          if pass >= 5 then exit;
     296
    282297          Inc(pass);
    283298          ycnt  := GIFInterlacedStart[pass];
    284299          ystep := GIFInterlacedStep[pass];
    285300        end;
    286       end;
     301      end else exit;
    287302    end;
    288303
     
    346361  InitStringTable;
    347362  curcode := getnextcode;
     363  //Write('Reading ');
    348364  while (curcode <> endcode) and (pass < 5) and not endofsrc do
    349365  begin
     
    370386      begin
    371387        if (curcode > stridx) then
     388        begin
     389          //write('!Invalid! ');
    372390          break;
     391        end;
    373392        AddStr2Tab(Code2Str(oldcode), firstchar(Code2Str(oldcode)));
    374393        WriteStr(Code2Str(stridx - 1));
     
    379398  end;
    380399  DoneStringTable;
     400  //Writeln;
    381401  if not endofsrc then
    382402  begin
    383403    bytinbuf:= 0;
    384     AStream.Read(bytinbuf, 1);
     404    AStream.ReadBuffer(bytinbuf, 1);
    385405    if bytinbuf <> 0 then
    386406      raise exception.Create('Invalid GIF format: expecting block terminator');
     
    391411//Adapted from the work of Udo Schmal, http://www.gocher.me/FPWriteGIF
    392412procedure GIFEncodeLZW(AStream: TStream; AImageData: PByte;
    393           AImageWidth, AImageHeight: integer; ABitDepth: integer);
     413          AImageWidth, AImageHeight: integer; ABitDepth: byte);
     414
     415var  //input position
     416  PInput, PInputEnd: PByte;
     417
     418  // get the next pixel from the bitmap
     419  function ReadValue: byte;
     420  begin
     421    result := PInput^;
     422    Inc(PInput);
     423  end;
     424
     425var // GIF buffer can be up to 255 bytes long
     426  OutputBufferSize: NativeInt;
     427  OutputBuffer: packed array[0..255] of byte;
     428
     429  procedure FlushByteOutput;
     430  begin
     431    if OutputBufferSize > 0 then
     432    begin
     433      OutputBuffer[0] := OutputBufferSize;
     434      AStream.WriteBuffer(OutputBuffer, OutputBufferSize+1);
     435      OutputBufferSize := 0;
     436    end;
     437  end;
     438
     439  procedure OutputByte(AValue: byte);
     440  begin
     441    if OutputBufferSize = 255 then FlushByteOutput;
     442    inc(OutputBufferSize);
     443    OutputBuffer[OutputBufferSize] := AValue;
     444  end;
     445
     446type TCode = Word;
     447
    394448var
    395    LZWSize: byte;
    396    OutputBufferSize: NativeInt;
    397    OutputBuffer: packed array[0..255] of byte;
    398 
    399    rPrefix: array[0..GIFCodeTableSize-1] of integer; // string prefixes
    400    rSuffix: array[0..GIFCodeTableSize-1] of integer; // string suffixes
    401    rCodeStack: array[0..GIFCodeTableSize-1] of byte; // encoded pixels
    402    rSP: integer; // pointer into CodeStack
    403    rClearCode: integer; // reset decode params
    404    rEndCode: integer; // last code in input stream
    405    rCurSize: integer; // current code size
    406    rBitString: integer; // steady stream of bits to be decoded
    407    rBits: integer; // number of valid bits in BitString
    408    rMaxVal: boolean; // max code value found?
    409    rCurX: integer; // position of next pixel
    410    rCurY: integer; // position of next pixel
    411    rCurScan: PByte;
    412    rFirstSlot: integer; // for encoding an image
    413    rNextSlot: integer; // for encoding
    414    rRowsLeft: integer; // rows left to do
    415    rLast: integer; // last byte read in
    416    rUnget: boolean; // read a new byte, or use zLast?
    417 
    418    procedure FlushOutput;
     449  BitBuffer       : DWord; // steady stream of bit output
     450  BitBufferLen    : Byte;  // number of bits in buffer
     451  CurCodeSize     : byte;  // current code size
     452
     453  // save the code in the output data stream
     454  procedure WriteCode(Code: TCode);
     455  begin
     456    //Write(IntToStr(Code)+'@'+IntToStr(CurCodeSize)+' ');
     457
     458    // append code to bit buffer
     459    BitBuffer := BitBuffer or (Code shl BitBufferLen);
     460    BitBufferLen := BitBufferLen + CurCodeSize;
     461    // output whole bytes
     462    while BitBufferLen >= 8 do
     463    begin
     464      OutputByte(BitBuffer and $ff);
     465      BitBuffer := BitBuffer shr 8;
     466      BitBufferLen -= 8;
     467    end;
     468  end;
     469
     470  procedure CloseBitOutput;
     471  begin
     472    // write out the rest of the bit string
     473    // and add padding bits if necessary
     474    while BitBufferLen > 0 do
     475    begin
     476      OutputByte(BitBuffer and $ff);
     477      BitBuffer := BitBuffer shr 8;
     478      if BitBufferLen >= 8 then
     479        BitBufferLen -= 8
     480      else
     481        BitBufferLen := 0;
     482    end;
     483  end;
     484
     485type
     486  PCodeTableEntry = ^TCodeTableEntry;
     487  TCodeTableEntry = packed record
     488               Prefix: TCode;
     489               LongerFirst, LongerLast: TCode;
     490               Suffix, Padding: Byte;
     491               NextWithPrefix: TCode;
     492             end;
     493
     494var
     495  ClearCode     : TCode;   // reset decode params
     496  EndStreamCode : TCode;   // last code in input stream
     497  FirstCodeSlot : TCode;   // first slot when table is empty
     498  NextCodeSlot  : TCode;   // next slot to be used
     499
     500  PEntry: PCodeTableEntry;
     501  CodeTable: array of TCodeTableEntry;
     502  CurrentCode   : TCode; // code representing current string
     503
     504  procedure DoClearCode;
     505  var
     506    i: Word;
     507  begin
     508    for i := 0 to (1 shl ABitDepth)-1 do
     509    with CodeTable[i] do
     510    begin
     511      LongerFirst:= 0;
     512      LongerLast:= 0;
     513    end;
     514
     515    WriteCode(ClearCode);
     516    CurCodeSize := ABitDepth + 1;
     517    NextCodeSlot := FirstCodeSlot;
     518  end;
     519
     520var
     521  CurValue: Byte;
     522  i: TCode;
     523  found: boolean; // decoded string in prefix table?
     524begin
     525   if ABitDepth > 8 then
     526     raise exception.Create('Maximum bit depth is 8');
     527
     528   //output
     529   AStream.WriteByte(ABitDepth);
     530   ClearCode := 1 shl ABitDepth;
     531   EndStreamCode := ClearCode + 1;
     532   FirstCodeSlot := ClearCode + 2;
     533   CurCodeSize := ABitDepth + 1;
     534
     535   OutputBufferSize := 0;
     536   BitBuffer := 0;
     537   BitBufferLen := 0;
     538
     539   //input
     540   PInput := AImageData;
     541   PInputEnd := AImageData + PtrInt(AImageWidth)*AImageHeight;
     542
     543   setlength(CodeTable, GIFCodeTableSize);
     544   DoClearCode;
     545   //write('Writing ');
     546
     547   while PInput < PInputEnd do
    419548   begin
    420      if OutputBufferSize > 0 then
     549     CurrentCode := ReadValue;
     550     if CurrentCode >= ClearCode then
     551       raise exception.Create('Internal error');
     552
     553     //try to match the longest string
     554     while PInput < PInputEnd do
    421555     begin
    422        OutputBuffer[0] := OutputBufferSize;
    423        AStream.WriteBuffer(OutputBuffer, OutputBufferSize+1);
    424        OutputBufferSize := 0;
    425      end;
    426    end;
    427 
    428    procedure OutputByte(AValue: byte);
    429    begin
    430      if OutputBufferSize = 255 then FlushOutput;
    431      inc(OutputBufferSize);
    432      OutputBuffer[OutputBufferSize] := AValue;
    433    end;
    434 
    435    procedure LZWReset;
    436    var i: integer;
    437    begin
    438      for i := 0 to (GIFCodeTableSize - 1) do
    439      begin
    440        rPrefix[i] := 0;
    441        rSuffix[i] := 0;
    442      end;
    443      rCurSize := LZWSize + 1;
    444      rClearCode := (1 shl LZWSize);
    445      rEndCode := rClearCode + 1;
    446      rFirstSlot := (1 shl (rCurSize - 1)) + 2;
    447      rNextSlot := rFirstSlot;
    448      rMaxVal := false;
    449    end;
    450 
    451    // save a code value on the code stack
    452    procedure LZWSaveCode(Code: integer);
    453    begin
    454      rCodeStack[rSP] := Code;
    455      inc(rSP);
    456    end;
    457 
    458    // save the code in the output data stream
    459    procedure LZWPutCode(code: integer);
    460    var
    461      n: integer;
    462      b: byte;
    463    begin
    464      // write out finished bytes
    465      // a literal "8" for 8 bits per byte
    466      while (rBits >= 8) do
    467      begin
    468        b := (rBitString and $ff);
    469        rBitString := (rBitString shr 8);
    470        rBits := rBits - 8;
    471        OutputByte(b);
    472      end;
    473      // make sure no junk bits left above the first byte
    474      rBitString := (rBitString and $ff);
    475      // and save out-going code
    476      n := (code shl rBits);
    477      rBitString := (rBitString or n);
    478      rBits := rBits + rCurSize;
    479    end;
    480 
    481    // get the next pixel from the bitmap, and return it as an index into the colormap
    482    function LZWReadBitmap: integer;
    483    begin
    484      if rUnget then
    485      begin
    486        result := rLast;
    487        rUnget := false;
    488      end
    489      else
    490      begin
    491        if rCurScan = nil then
    492          rCurScan := AImageData + rCurY*AImageWidth;
    493        result := (rCurScan+rCurX)^;
    494        inc(rCurX); // inc X position
    495        if (rCurX >= AImageWidth) then // bumping Y ?
     556       CurValue := ReadValue;
     557
     558       found := false;
     559
     560       i := CodeTable[CurrentCode].LongerFirst;
     561       while i <> 0 do
    496562       begin
    497          rCurX := 0;
    498          inc(rCurY);
    499          rCurScan := nil;
    500          dec(rRowsLeft);
     563         PEntry := @CodeTable[i];
     564         if PEntry^.Suffix = CurValue then
     565         begin
     566           found := true;
     567           CurrentCode := i;
     568           break;
     569         end;
     570         i := PEntry^.NextWithPrefix;
     571       end;
     572
     573       if not found then
     574       begin
     575         PEntry := @CodeTable[CurrentCode];
     576         if PEntry^.LongerFirst = 0 then
     577         begin
     578           //store the first and last code being longer
     579           PEntry^.LongerFirst := NextCodeSlot;
     580           PEntry^.LongerLast := NextCodeSlot;
     581         end else
     582         begin
     583           //link next entry having the same prefix
     584           CodeTable[PEntry^.LongerLast].NextWithPrefix:= NextCodeSlot;
     585           PEntry^.LongerLast := NextCodeSlot;
     586         end;
     587
     588         // add new encode table entry
     589         PEntry := @CodeTable[NextCodeSlot];
     590         PEntry^.Prefix := CurrentCode;
     591         PEntry^.Suffix := CurValue;
     592         PEntry^.LongerFirst := 0;
     593         PEntry^.LongerLast := 0;
     594         PEntry^.NextWithPrefix := 0;
     595         inc(NextCodeSlot);
     596
     597         Dec(PInput);
     598         break;
    501599       end;
    502600     end;
    503      rLast := result;
     601
     602     // write the code of the longest entry found
     603     WriteCode(CurrentCode);
     604
     605     if NextCodeSlot >= GIFCodeTableSize then
     606       DoClearCode
     607     else if NextCodeSlot > 1 shl CurCodeSize then
     608       inc(CurCodeSize);
    504609   end;
    505610
    506 var
    507    i,n,
    508    cc: integer; // current code to translate
    509    oc: integer; // last code encoded
    510    found: boolean; // decoded string in prefix table?
    511    pixel: byte; // lowest code to search for
    512    ldx: integer; // last index found
    513    fdx: integer; // current index found
    514    b: byte;
    515 begin
    516    LZWSize := ABitDepth;
    517    AStream.WriteBuffer(LZWSize, 1);
    518    OutputBufferSize := 0;
    519 
    520    // init data block
    521    fillchar(rCodeStack, sizeof(rCodeStack), 0);
    522    rBitString := 0;
    523    rBits := 0;
    524    rCurX := 0;
    525    rCurY := 0;
    526    rCurScan := nil;
    527    rLast := 0;
    528    rUnget:= false;
    529 
    530    LZWReset;
    531    // all within the data record
    532    // always save the clear code first ...
    533    LZWPutCode(rClearCode);
    534    // and first pixel
    535    oc := LZWReadBitmap;
    536    LZWPutCode(oc);
    537    // nothing found yet (but then, we haven't searched)
    538    ldx := 0;
    539    fdx := 0;
    540    // and the rest of the pixels
    541    rRowsLeft := AImageHeight;
    542    while (rRowsLeft > 0) do
    543    begin
    544      rSP := 0; // empty the stack of old data
    545      n := LZWReadBitmap; // next pixel from the bitmap
    546      LZWSaveCode(n);
    547      cc := rCodeStack[0]; // beginning of the string
    548      // add new encode table entry
    549      rPrefix[rNextSlot] := oc;
    550      rSuffix[rNextSlot] := cc;
    551      inc(rNextSlot);
    552      if (rNextSlot >= GIFCodeTableSize) then
    553        rMaxVal := true
    554      else if (rNextSlot > (1 shl rCurSize)) then
    555        inc(rCurSize);
    556      // find the running string of matching codes
    557      ldx := cc;
    558      found := true;
    559      while (found and (rRowsLeft > 0)) do
    560      begin
    561        n := LZWReadBitmap;
    562        LZWSaveCode(n);
    563        cc := rCodeStack[0];
    564        if (ldx < rFirstSlot) then
    565          i := rFirstSlot
    566        else
    567          i := ldx + 1;
    568        pixel := rCodeStack[rSP - 1];
    569        found := false;
    570        while ((not found) and (i < rNextSlot)) do
    571        begin
    572          found := ((rPrefix[i] = ldx) and (rSuffix[i] = pixel));
    573          inc(i);
    574        end;
    575        if (found) then
    576        begin
    577          ldx := i - 1;
    578          fdx := i - 1;
    579        end;
    580      end;
    581      // if not found, save this index, and get the same code again
    582      if (not found) then
    583      begin
    584        rUnget := true;
    585        rLast := rCodeStack[rSP-1];
    586        dec(rSP);
    587        cc := ldx;
    588      end
    589      else
    590        cc := fdx;
    591      // whatever we got, write it out as current table entry
    592      LZWPutCode(cc);
    593      if (rMaxVal and (rRowsLeft > 0)) then
    594      begin
    595        LZWPutCode(rClearCode);
    596        LZWReset;
    597        cc := LZWReadBitmap;
    598        LZWPutCode(cc);
    599      end;
    600      oc := cc;
    601    end;
    602    LZWPutCode(rEndCode);
    603    // write out the rest of the bit string
    604    while (rBits > 0) do
    605    begin
    606      b := (rBitString and $ff);
    607      rBitString := (rBitString shr 8);
    608      rBits := rBits - 8;
    609      OutputByte(b);
    610    end;
    611    FlushOutput;
    612    b := 0;
    613    AStream.Write(b, 1);
     611   WriteCode(EndStreamCode);
     612   CloseBitOutput;
     613   FlushByteOutput;
     614
     615   AStream.WriteByte(0); //GIF block terminator
     616   //Writeln;
    614617end;
    615618
    616 function GIFLoadFromStream(stream: TStream): TGIFData;
     619function GIFLoadFromStream(stream: TStream; MaxImageCount: integer = maxLongint): TGIFData;
    617620
    618621  procedure DumpData;
     
    625628      stream.position := stream.position + Count;
    626629    until (Count = 0) or (stream.position >= stream.size);
     630  end;
     631
     632  function ReadString: string;
     633  var Count: byte;
     634  begin
     635    Count := 0;
     636    stream.Read(Count, 1);
     637    setlength(result, Count);
     638    if Count > 0 then
     639      stream.ReadBuffer(result[1], length(result));
    627640  end;
    628641
     
    715728    GIFExtensionBlock: TGIFExtensionBlock;
    716729    GIFGraphicControlExtension: TGIFGraphicControlExtension;
    717     mincount, Count:   byte;
     730    mincount, Count, SubBlockId:   byte;
     731    app: String;
    718732
    719733  begin
    720734    stream.ReadBuffer({%H-}GIFExtensionBlock, sizeof(GIFExtensionBlock));
    721735    case GIFExtensionBlock.FunctionCode of
    722       $F9:
     736      $F9: //graphic control extension
    723737      begin
    724738        Count := 0;
     
    745759        DumpData;
    746760      end;
     761      $ff: //application extension
     762      begin
     763        app := ReadString;
     764        if app <> '' then
     765        begin
     766          if app = NetscapeApplicationIdentifier then
     767          begin
     768            repeat
     769              Count := 0;
     770              stream.Read(Count,1);
     771              if Count = 0 then break;
     772              stream.ReadBuffer({%H-}SubBlockId,1);
     773              Dec(Count);
     774              if (SubBlockId = NetscapeSubBlockIdLoopCount) and (Count >= 2) then
     775              begin
     776                stream.ReadBuffer(result.LoopCount, 2);
     777                dec(Count,2);
     778                result.LoopCount := LEtoN(result.LoopCount);
     779                if result.LoopCount > 0 then inc(result.LoopCount);
     780              end;
     781              stream.Position:= stream.Position+Count;
     782            until false;
     783          end else
     784            DumpData;
     785        end;
     786      end
    747787      else
    748788      begin
     
    758798  result.Images := nil;
    759799  result.AspectRatio := 1;
     800  result.LoopCount := 1;
    760801  if stream = nil then exit;
    761802
     
    790831      case GIFBlockID of
    791832        ';': ;
    792         ',': LoadImage;
     833        ',': begin
     834               if NbImages >= MaxImageCount then break;
     835               LoadImage;
     836             end;
    793837        '!': ReadExtension;
    794838        else
     
    10091053          for x := 0 to Image.Width -1 do
    10101054          begin
    1011             pdest^ := APalette.IndexOfColor(psource^);
     1055            if psource^.alpha < 128 then
     1056              pdest^ := APalette.IndexOfColor(BGRAPixelTransparent)
     1057            else
     1058              pdest^ := APalette.IndexOfColor(BGRA(psource^.red,psource^.green,psource^.blue,255));
    10121059            inc(psource);
    10131060            inc(pdest);
     
    10871134    for i := 0 to ImageCount-1 do
    10881135      WriteImage(i);
     1136  end;
     1137
     1138  procedure WriteLoopExtension;
     1139  var
     1140    app: shortstring;
     1141    w: Word;
     1142  begin
     1143    if AData.LoopCount = 1 then exit;
     1144
     1145    Stream.WriteByte(GIFExtensionIntroducer);
     1146    Stream.WriteByte($ff);
     1147    app := NetscapeApplicationIdentifier;
     1148    Stream.WriteBuffer(app[0], length(app)+1);
     1149
     1150    Stream.WriteByte(3);
     1151    Stream.WriteByte(NetscapeSubBlockIdLoopCount);
     1152    if AData.LoopCount = 0 then
     1153      w := 0
     1154    else
     1155      w := AData.LoopCount-1;
     1156    w := NtoLE(w);
     1157    Stream.WriteWord(w);
     1158
     1159    Stream.WriteByte(0);
    10891160  end;
    10901161
     
    11061177    WriteGlobalPalette;
    11071178
     1179    WriteLoopExtension;
     1180
    11081181    WriteImages;
    1109     Stream.WriteByte($3B); //end of file
     1182    Stream.WriteByte(GIFFileTerminator); //end of file
    11101183
    11111184  finally
  • GraphicTest/Packages/bgrabitmap/bgragradients.pas

    r494 r521  
    2929function nGradientInfo(StartColor, StopColor: TBGRAPixel; Direction: TGradientDirection; EndPercent: Single): TnGradientInfo;
    3030
    31 function nGradientAlphaFill(ARect: TRect; ADir: TGradientDirection; const AGradient: array of TnGradientInfo): TBGRABitmap;
    32 function nGradientAlphaFill(AWidth, AHeight: Integer; ADir: TGradientDirection; const AGradient: array of TnGradientInfo): TBGRABitmap;
    33 procedure nGradientAlphaFill(ACanvas: TCanvas; ARect: TRect; ADir: TGradientDirection; const AGradient: array of TnGradientInfo);
    34 procedure nGradientAlphaFill(ABitmap: TBGRABitmap; ARect: TRect; ADir: TGradientDirection; const AGradient: array of TnGradientInfo);
     31function nGradientAlphaFill(ARect: TRect; ADir: TGradientDirection; const AGradient: array of TnGradientInfo): TBGRABitmap; overload;
     32function nGradientAlphaFill(AWidth, AHeight: Integer; ADir: TGradientDirection; const AGradient: array of TnGradientInfo): TBGRABitmap; overload;
     33procedure nGradientAlphaFill(ACanvas: TCanvas; ARect: TRect; ADir: TGradientDirection; const AGradient: array of TnGradientInfo); overload;
     34procedure nGradientAlphaFill(ABitmap: TBGRABitmap; ARect: TRect; ADir: TGradientDirection; const AGradient: array of TnGradientInfo); overload;
    3535
    3636function DoubleGradientAlphaFill(ARect: TRect; AStart1,AStop1,AStart2,AStop2: TBGRAPixel;
    37                                  ADirection1,ADirection2,ADir: TGradientDirection; AValue: Single): TBGRABitmap;
     37                                 ADirection1,ADirection2,ADir: TGradientDirection; AValue: Single): TBGRABitmap; overload;
    3838function DoubleGradientAlphaFill(AWidth,AHeight: Integer; AStart1,AStop1,AStart2,AStop2: TBGRAPixel;
    39                                  ADirection1,ADirection2,ADir: TGradientDirection; AValue: Single): TBGRABitmap;
     39                                 ADirection1,ADirection2,ADir: TGradientDirection; AValue: Single): TBGRABitmap; overload;
    4040procedure DoubleGradientAlphaFill(ACanvas: TCanvas; ARect: TRect; AStart1,AStop1,AStart2,AStop2: TBGRAPixel;
    41                                  ADirection1,ADirection2,ADir: TGradientDirection; AValue: Single);
     41                                 ADirection1,ADirection2,ADir: TGradientDirection; AValue: Single); overload;
    4242procedure DoubleGradientAlphaFill(ABitmap: TBGRABitmap; ARect: TRect; AStart1,AStop1,AStart2,AStop2: TBGRAPixel;
    43                                  ADirection1,ADirection2,ADir: TGradientDirection; AValue: Single);
     43                                 ADirection1,ADirection2,ADir: TGradientDirection; AValue: Single); overload;
    4444
    4545{----------------------------------------------------------------------}
     
    155155{ Create a precise height map for a rectangle height map with a border (not grayscale anymore but more precise) }
    156156function CreateRectanglePreciseMap(width,height,border: integer; options: TRectangleMapOptions = []): TBGRABitmap;
     157function CreateRectanglePreciseMap(width, height, borderWidth, borderHeight: integer; options: TRectangleMapOptions): TBGRABitmap;
    157158
    158159{ Create a round rectangle height map with a border }
     
    161162{ Create a precise height map for a round rectangle height map with a border (not grayscale anymore but more precise) }
    162163function CreateRoundRectanglePreciseMap(width,height,border: integer; options: TRectangleMapOptions = []): TBGRABitmap;
     164function CreateRoundRectanglePreciseMap(width,height,borderWidth,borderHeight: integer; options: TRectangleMapOptions = []): TBGRABitmap;
    163165
    164166{---------- Perlin Noise -------------}
     
    177179implementation
    178180
    179 uses Types, SysUtils{$IFDEF BGRABITMAP_USE_LCL}, BGRATextFX{$ENDIF}; {GraphType unit used by phongdraw.inc}
     181uses Types, Math, SysUtils{$IFDEF BGRABITMAP_USE_LCL}, BGRATextFX{$ENDIF}; {GraphType unit used by phongdraw.inc}
    180182
    181183{$IFDEF BGRABITMAP_USE_LCL}function TextShadow(AWidth, AHeight: Integer; AText: String;
     
    767769end;
    768770
     771procedure MapBorderLimit(width,height: integer; options: TRectangleMapOptions; var borderHoriz,borderVert: integer);
     772var maxHoriz,maxVert: integer;
     773begin
     774  if [rmoNoLeftBorder,rmoNoRightBorder] <= options then maxHoriz := borderHoriz else
     775  if [rmoNoLeftBorder,rmoNoRightBorder] * options = [] then maxHoriz := width div 2 else
     776    maxHoriz := width;
     777  if borderHoriz > maxHoriz then borderHoriz := maxHoriz;
     778
     779  if [rmoNoTopBorder,rmoNoBottomBorder] <= options then maxVert := borderVert else
     780  if [rmoNoTopBorder,rmoNoBottomBorder] * options = [] then maxVert := height div 2 else
     781    maxVert := height;
     782  if borderVert > maxVert then borderVert := maxVert;
     783end;
     784
    769785function CreateSpherePreciseMap(width, height: integer): TBGRABitmap;
    770786var cx,cy,rx,ry,d: single;
     
    898914     if rmoLinearBorder in options then h := h/border else
    899915       h := sin((h+1/2)/border*Pi/2);
     916
     917     p^ := MapHeightToBGRA(h,255);
     918
     919     inc(p);
     920   end;
     921  end;
     922
     923  RectangleMapRemoveCorners(result,options);
     924end;
     925
     926function CreateRectanglePreciseMap(width, height, borderWidth, borderHeight: integer;
     927  options: TRectangleMapOptions): TBGRABitmap;
     928var xb,yb, minBorder: integer;
     929    p: PBGRAPixel;
     930    h: single;
     931    smallStep: single;
     932begin
     933  MapBorderLimit(width,height,options,borderWidth,borderHeight);
     934
     935  minBorder := min(borderWidth,borderHeight);
     936  if minBorder > 0 then smallStep := 1/minBorder else smallStep:= 0;
     937
     938  result := TBGRABitmap.Create(width,height);
     939  for yb := 0 to height-1 do
     940  begin
     941   p := result.scanline[yb];
     942   for xb := 0 to width-1 do
     943   begin
     944     if not (rmoNoLeftBorder in options) and (xb < borderWidth) and (yb < borderHeight) then
     945        h := min(xb/borderWidth, yb/borderHeight) else
     946     if not (rmoNoRightBorder in options) and (xb > width-1-borderWidth) and (yb < borderHeight) then
     947        h := min((width-1-xb)/borderWidth, yb/borderHeight) else
     948     if not (rmoNoTopBorder in options) and (xb < borderWidth) and (yb > height-1-borderHeight) then
     949        h := min(xb/borderWidth, (height-1-yb)/borderHeight) else
     950     if not (rmoNoBottomBorder in options) and  (xb > width-1-borderWidth) and (yb > height-1-borderHeight) then
     951        h := min((width-1-xb)/borderWidth, (height-1-yb)/borderHeight) else
     952     if not (rmoNoLeftBorder in options) and (xb < borderWidth) then h := xb/borderWidth else
     953     if not (rmoNoRightBorder in options) and (xb > width-1-borderWidth) then h := (width-1-xb)/borderWidth else
     954     if not (rmoNoTopBorder in options) and (yb < borderHeight) then h := yb/borderHeight else
     955     if not (rmoNoBottomBorder in options) and (yb > height-1-borderHeight) then h := (height-1-yb)/borderHeight else
     956     begin
     957       p^ := BGRAWhite;
     958       inc(p);
     959       Continue;
     960     end;
     961
     962     if not (rmoLinearBorder in options) then
     963       h := sin((h+smallStep*0.5)*Pi*0.5);
    900964
    901965     p^ := MapHeightToBGRA(h,255);
     
    10901154end;
    10911155
     1156function CreateRoundRectanglePreciseMap(width, height, borderWidth,
     1157  borderHeight: integer; options: TRectangleMapOptions): TBGRABitmap;
     1158var d: single;
     1159    xb,yb: integer;
     1160    p: PBGRAPixel;
     1161    h,smallStep,factor: single;
     1162    minBorder: integer;
     1163begin
     1164  MapBorderLimit(width,height,options,borderWidth,borderHeight);
     1165
     1166  minBorder := min(borderWidth,borderHeight);
     1167  if minBorder > 0 then smallStep := 1/minBorder else smallStep:= 0;
     1168  factor := minBorder/(minBorder+1);
     1169  result := TBGRABitmap.Create(width,height);
     1170  for yb := 0 to height-1 do
     1171  begin
     1172   p := result.scanline[yb];
     1173   for xb := 0 to width-1 do
     1174   begin
     1175     if not (rmoNoLeftBorder in options) and not (rmoNoTopBorder in options) and (xb < borderWidth) and (yb < borderHeight) then
     1176        d := 1-sqrt(sqr((borderWidth-xb)/borderWidth)+sqr((borderHeight-yb)/borderHeight)) else
     1177     if not (rmoNoLeftBorder in options) and not (rmoNoBottomBorder in options) and (xb < borderWidth) and (yb > height-1-borderHeight) then
     1178        d := 1-sqrt(sqr((borderWidth-xb)/borderWidth)+sqr((borderHeight-(height-1-yb))/borderHeight)) else
     1179     if not (rmoNoRightBorder in options) and not (rmoNoTopBorder in options) and (xb > width-1-borderWidth) and (yb < borderHeight) then
     1180        d := 1-sqrt(sqr((borderWidth-(width-1-xb))/borderWidth)+sqr((borderHeight-yb)/borderHeight)) else
     1181     if not (rmoNoRightBorder in options) and not (rmoNoBottomBorder in options) and (xb > width-1-borderWidth) and (yb > height-1-borderHeight) then
     1182        d := 1-sqrt(sqr((borderWidth-(width-1-xb))/borderWidth)+sqr((borderHeight-(height-1-yb))/borderHeight)) else
     1183     if not (rmoNoLeftBorder in options) and (xb < borderWidth) then d := xb/borderWidth else
     1184     if not (rmoNoRightBorder in options) and (xb > width-1-borderWidth) then d := (width-1-xb)/borderWidth else
     1185     if not (rmoNoTopBorder in options) and (yb < borderHeight) then d := yb/borderHeight else
     1186     if not (rmoNoBottomBorder in options) and (yb > height-1-borderHeight) then d := (height-1-yb)/borderHeight else
     1187     begin
     1188       p^ := BGRAWhite;
     1189       inc(p);
     1190       Continue;
     1191     end;
     1192
     1193     d := (d + smallStep)*factor;
     1194
     1195     if d < 0 then
     1196       p^ := BGRAPixelTransparent else
     1197     begin
     1198       if rmoLinearBorder in options then h := d else
     1199         h := sin((d+smallStep*0.5)*Pi*0.5);
     1200
     1201       if d < smallStep then p^:= MapHeightToBGRA(h,round(d/smallStep*255)) else
     1202         p^ := MapHeightToBGRA(h,255);
     1203     end;
     1204     inc(p);
     1205   end;
     1206  end;
     1207end;
     1208
    10921209initialization
    10931210
  • GraphicTest/Packages/bgrabitmap/bgragradientscanner.pas

    r494 r521  
    1111
    1212type
    13   { TBGRASimpleGradientWithoutGammaCorrection }
    14 
    15   TBGRASimpleGradientWithoutGammaCorrection = class(TBGRACustomGradient)
    16   private
     13  TBGRAColorInterpolation = (ciStdRGB, ciLinearRGB, ciLinearHSLPositive, ciLinearHSLNegative, ciGSBPositive, ciGSBNegative);
     14  TBGRAGradientRepetition = (grPad, grRepeat, grReflect, grSine);
     15
     16  { TBGRASimpleGradient }
     17
     18  TBGRASimpleGradient = class(TBGRACustomGradient)
     19  protected
    1720    FColor1,FColor2: TBGRAPixel;
    1821    ec1,ec2: TExpandedPixel;
     22    FRepetition: TBGRAGradientRepetition;
     23    constructor Create(AColor1,AColor2: TBGRAPixel; ARepetition: TBGRAGradientRepetition); overload;
     24    constructor Create(AColor1,AColor2: TExpandedPixel; ARepetition: TBGRAGradientRepetition); overload;
     25    function InterpolateToBGRA(position: word): TBGRAPixel; virtual; abstract;
     26    function InterpolateToExpanded(position: word): TExpandedPixel; virtual; abstract;
    1927  public
    20     constructor Create(Color1,Color2: TBGRAPixel);
     28    class function CreateAny(AInterpolation: TBGRAColorInterpolation; AColor1,AColor2: TBGRAPixel; ARepetition: TBGRAGradientRepetition): TBGRASimpleGradient; overload;
     29    class function CreateAny(AInterpolation: TBGRAColorInterpolation; AColor1,AColor2: TExpandedPixel; ARepetition: TBGRAGradientRepetition): TBGRASimpleGradient; overload;
    2130    function GetColorAt(position: integer): TBGRAPixel; override;
    2231    function GetColorAtF(position: single): TBGRAPixel; override;
     
    2433    function GetExpandedColorAtF(position: single): TExpandedPixel; override;
    2534    function GetAverageColor: TBGRAPixel; override;
    26     function GetMonochrome: boolean; override;
    27   end;
    28 
    29   { TBGRASimpleGradientWithGammaCorrection }
    30 
    31   TBGRASimpleGradientWithGammaCorrection = class(TBGRACustomGradient)
    32   private
    33     FColor1,FColor2: TBGRAPixel;
    34     ec1,ec2: TExpandedPixel;
    35   public
    36     constructor Create(Color1,Color2: TBGRAPixel);
    37     function GetColorAt(position: integer): TBGRAPixel; override;
    38     function GetColorAtF(position: single): TBGRAPixel; override;
    39     function GetAverageColor: TBGRAPixel; override;
    40     function GetExpandedColorAt(position: integer): TExpandedPixel; override;
    41     function GetExpandedColorAtF(position: single): TExpandedPixel; override;
    4235    function GetAverageExpandedColor: TExpandedPixel; override;
    4336    function GetMonochrome: boolean; override;
    44   end;
    45 
    46   THueGradientOption = (hgoRepeat, hgoPositiveDirection, hgoNegativeDirection, hgoHueCorrection, hgoLightnessCorrection);
     37    property Repetition: TBGRAGradientRepetition read FRepetition write FRepetition;
     38  end;
     39
     40  { TBGRASimpleGradientWithoutGammaCorrection }
     41
     42  TBGRASimpleGradientWithoutGammaCorrection = class(TBGRASimpleGradient)
     43  protected
     44    function InterpolateToBGRA(position: word): TBGRAPixel; override;
     45    function InterpolateToExpanded(position: word): TExpandedPixel; override;
     46  public
     47    constructor Create(Color1,Color2: TBGRAPixel; ARepetition: TBGRAGradientRepetition = grPad); overload;
     48    constructor Create(Color1,Color2: TExpandedPixel; ARepetition: TBGRAGradientRepetition = grPad); overload;
     49  end;
     50
     51  { TBGRASimpleGradientWithGammaCorrection }
     52
     53  TBGRASimpleGradientWithGammaCorrection = class(TBGRASimpleGradient)
     54  protected
     55    function InterpolateToBGRA(position: word): TBGRAPixel; override;
     56    function InterpolateToExpanded(position: word): TExpandedPixel; override;
     57  public
     58    constructor Create(Color1,Color2: TBGRAPixel; ARepetition: TBGRAGradientRepetition = grPad); overload;
     59    constructor Create(Color1,Color2: TExpandedPixel; ARepetition: TBGRAGradientRepetition = grPad); overload;
     60  end;
     61
     62  THueGradientOption = (hgoRepeat, hgoReflect,                       //repetition
     63                        hgoPositiveDirection, hgoNegativeDirection,  //hue orientation
     64                        hgoHueCorrection, hgoLightnessCorrection);   //color interpolation
    4765  THueGradientOptions = set of THueGradientOption;
    4866
    4967  { TBGRAHueGradient }
    5068
    51   TBGRAHueGradient = class(TBGRACustomGradient)
     69  TBGRAHueGradient = class(TBGRASimpleGradient)
    5270  private
    53     FColor1,FColor2: TBGRAPixel;
    54     ec1,ec2: TExpandedPixel;
    5571    hsla1,hsla2: THSLAPixel;
    5672    hue1,hue2: longword;
    5773    FOptions: THueGradientOptions;
    5874    procedure Init(c1,c2: THSLAPixel; AOptions: THueGradientOptions);
    59     function GetColorNoBoundCheck(position: integer): THSLAPixel;
     75    function InterpolateToHSLA(position: word): THSLAPixel;
     76  protected
     77    function InterpolateToBGRA(position: word): TBGRAPixel; override;
     78    function InterpolateToExpanded(position: word): TExpandedPixel; override;
    6079  public
    6180    constructor Create(Color1,Color2: TBGRAPixel; options: THueGradientOptions); overload;
     81    constructor Create(Color1,Color2: TExpandedPixel; options: THueGradientOptions); overload;
    6282    constructor Create(Color1,Color2: THSLAPixel; options: THueGradientOptions); overload;
    6383    constructor Create(AHue1,AHue2: Word; Saturation,Lightness: Word; options: THueGradientOptions); overload;
    64     function GetColorAt(position: integer): TBGRAPixel; override;
    65     function GetColorAtF(position: single): TBGRAPixel; override;
    66     function GetAverageColor: TBGRAPixel; override;
    67     function GetExpandedColorAt(position: integer): TExpandedPixel; override;
    68     function GetExpandedColorAtF(position: single): TExpandedPixel; override;
    69     function GetAverageExpandedColor: TExpandedPixel; override;
    7084    function GetMonochrome: boolean; override;
    7185  end;
     
    96110  end;
    97111
     112  TBGRAGradientScannerInternalScanNextFunc = function():single of object;
     113  TBGRAGradientScannerInternalScanAtFunc = function(const p: TPointF):single of object;
     114
    98115  { TBGRAGradientScanner }
    99116
     
    101118  protected
    102119    FGradientType: TGradientType;
    103     FOrigin1,FOrigin2: TPointF;
     120    FOrigin,FDir1,FDir2: TPointF;
     121    FRelativeFocal: TPointF;
     122    FRadius, FFocalRadius: single;
     123    FTransform, FHiddenTransform: TAffineMatrix;
    104124    FSinus: Boolean;
    105     u: TPointF;
    106     len,aFactor,aFactorF: single;
    107     mergedColor: TBGRAPixel;
    108     mergedExpandedColor: TExpandedPixel;
    109125    FGradient: TBGRACustomGradient;
    110126    FGradientOwner: boolean;
     127    FFlipGradient: boolean;
     128
     129    FMatrix: TAffineMatrix;
     130    FRepeatHoriz, FIsAverage: boolean;
     131    FAverageColor: TBGRAPixel;
     132    FAverageExpandedColor: TExpandedPixel;
     133    FScanNextFunc: TBGRAGradientScannerInternalScanNextFunc;
     134    FScanAtFunc: TBGRAGradientScannerInternalScanAtFunc;
     135    FFocalDistance: single;
     136    FFocalDirection, FFocalNormal: TPointF;
     137    FRadialDenominator, FRadialDeltaSign, maxW1, maxW2: single;
     138
     139    FPosition: TPointF;
    111140    FHorizColor: TBGRAPixel;
    112141    FHorizExpandedColor: TExpandedPixel;
    113     FVertical: boolean;
    114     FDotProduct,FDotProductPerp: Single;
    115     procedure Init(gtype: TGradientType; o1, o2: TPointF; Sinus: Boolean=False);
    116     procedure InitScanInline(x,y: integer);
     142
     143    procedure Init(AGradientType: TGradientType; AOrigin, d1: TPointF; ATransform: TAffineMatrix; Sinus: Boolean=False); overload;
     144    procedure Init(AGradientType: TGradientType; AOrigin, d1, d2: TPointF; ATransform: TAffineMatrix; Sinus: Boolean=False); overload;
     145    procedure Init(AOrigin: TPointF; ARadius: single; AFocal: TPointF; AFocalRadius: single; ATransform: TAffineMatrix; AHiddenTransform: TAffineMatrix); overload;
     146
     147    procedure InitGradientType;
     148    procedure InitTransform;
     149    procedure InitGradient;
     150
     151    function ComputeRadialFocal(const p: TPointF): single;
     152
     153    function ScanNextLinear: single;
     154    function ScanNextReflected: single;
     155    function ScanNextDiamond: single;
     156    function ScanNextRadial: single;
     157    function ScanNextRadial2: single;
     158    function ScanNextRadialFocal: single;
     159    function ScanNextAngular: single;
     160
     161    function ScanAtLinear(const p: TPointF): single;
     162    function ScanAtReflected(const p: TPointF): single;
     163    function ScanAtDiamond(const p: TPointF): single;
     164    function ScanAtRadial(const p: TPointF): single;
     165    function ScanAtRadial2(const p: TPointF): single;
     166    function ScanAtRadialFocal(const p: TPointF): single;
     167    function ScanAtAngular(const p: TPointF): single;
     168
    117169    function ScanNextInline: TBGRAPixel; inline;
    118170    function ScanNextExpandedInline: TExpandedPixel; inline;
     171    procedure SetTransform(AValue: TAffineMatrix);
     172    procedure SetFlipGradient(AValue: boolean);
     173    function GetGradientColor(a: single): TBGRAPixel;
     174    function GetGradientExpandedColor(a: single): TExpandedPixel;
    119175  public
    120     constructor Create(c1, c2: TBGRAPixel; gtype: TGradientType; o1, o2: TPointF;
    121                        gammaColorCorrection: boolean = True; Sinus: Boolean=False);
    122     constructor Create(gradient: TBGRACustomGradient; gtype: TGradientType; o1, o2: TPointF; Sinus: Boolean=False; AGradientOwner: Boolean=False);
     176    constructor Create(AGradientType: TGradientType; AOrigin, d1: TPointF); overload;
     177    constructor Create(AGradientType: TGradientType; AOrigin, d1, d2: TPointF); overload;
     178    constructor Create(AOrigin, d1, d2, AFocal: TPointF; ARadiusRatio: single = 1; AFocalRadiusRatio: single = 0); overload;
     179    constructor Create(AOrigin: TPointF; ARadius: single; AFocal: TPointF; AFocalRadius: single); overload;
     180
     181    constructor Create(c1, c2: TBGRAPixel; AGradientType: TGradientType; AOrigin, d1: TPointF;
     182                       gammaColorCorrection: boolean = True; Sinus: Boolean=False); overload;
     183    constructor Create(c1, c2: TBGRAPixel; AGradientType: TGradientType; AOrigin, d1, d2: TPointF;
     184                       gammaColorCorrection: boolean = True; Sinus: Boolean=False); overload;
     185
     186    constructor Create(gradient: TBGRACustomGradient; AGradientType: TGradientType; AOrigin, d1: TPointF;
     187                       Sinus: Boolean=False; AGradientOwner: Boolean=False); overload;
     188    constructor Create(gradient: TBGRACustomGradient; AGradientType: TGradientType; AOrigin, d1, d2: TPointF;
     189                       Sinus: Boolean=False; AGradientOwner: Boolean=False); overload;
     190    constructor Create(gradient: TBGRACustomGradient; AOrigin: TPointF; ARadius: single; AFocal: TPointF;
     191                       AFocalRadius: single; AGradientOwner: Boolean=False); overload;
     192
     193    procedure SetGradient(c1,c2: TBGRAPixel; AGammaCorrection: boolean = true); overload;
     194    procedure SetGradient(AGradient: TBGRACustomGradient; AOwner: boolean); overload;
    123195    destructor Destroy; override;
    124196    procedure ScanMoveTo(X, Y: Integer); override;
     
    129201    procedure ScanPutPixels(pdest: PBGRAPixel; count: integer; mode: TDrawMode); override;
    130202    function IsScanPutPixelsDefined: boolean; override;
     203    property Transform: TAffineMatrix read FTransform write SetTransform;
     204    property Gradient: TBGRACustomGradient read FGradient;
     205    property FlipGradient: boolean read FFlipGradient write SetFlipGradient;
     206    property Sinus: boolean Read FSinus write FSinus;
    131207  end;
    132208
     
    143219    FOpacity: byte;
    144220    FGrayscale: boolean;
     221    FRandomBuffer, FRandomBufferCount: integer;
    145222  public
    146223    constructor Create(AGrayscale: Boolean; AOpacity: byte);
     
    213290  private
    214291      FTexture: IBGRAScanner;
     292      FOwnedScanner: TBGRACustomScanner;
    215293      FGlobalOpacity: Byte;
    216294      FScanNext : TScanNextPixelFunction;
     
    219297  public
    220298    constructor Create(ATexture: IBGRAScanner; AGlobalOpacity: Byte = 255);
     299    constructor Create(ATexture: TBGRACustomScanner; AGlobalOpacity: Byte; AOwned: boolean);
    221300    destructor Destroy; override;
    222301    function IsScanPutPixelsDefined: boolean; override;
     
    231310uses BGRABlend, Math;
    232311
     312{ TBGRASimpleGradient }
     313
     314constructor TBGRASimpleGradient.Create(AColor1, AColor2: TBGRAPixel; ARepetition: TBGRAGradientRepetition);
     315begin
     316  FColor1 := AColor1;
     317  FColor2 := AColor2;
     318  ec1 := GammaExpansion(AColor1);
     319  ec2 := GammaExpansion(AColor2);
     320  FRepetition:= ARepetition;
     321end;
     322
     323constructor TBGRASimpleGradient.Create(AColor1, AColor2: TExpandedPixel;
     324  ARepetition: TBGRAGradientRepetition);
     325begin
     326  FColor1 := GammaCompression(AColor1);
     327  FColor2 := GammaCompression(AColor2);
     328  ec1 := AColor1;
     329  ec2 := AColor2;
     330  FRepetition:= ARepetition;
     331end;
     332
     333class function TBGRASimpleGradient.CreateAny(AInterpolation: TBGRAColorInterpolation;
     334  AColor1, AColor2: TBGRAPixel; ARepetition: TBGRAGradientRepetition): TBGRASimpleGradient;
     335begin
     336  case AInterpolation of
     337    ciStdRGB: result := TBGRASimpleGradientWithoutGammaCorrection.Create(AColor1,AColor2);
     338    ciLinearRGB: result := TBGRASimpleGradientWithGammaCorrection.Create(AColor1,AColor2);
     339    ciLinearHSLPositive: result := TBGRAHueGradient.Create(AColor1,AColor2,[hgoPositiveDirection]);
     340    ciLinearHSLNegative: result := TBGRAHueGradient.Create(AColor1,AColor2,[hgoNegativeDirection]);
     341    ciGSBPositive: result := TBGRAHueGradient.Create(AColor1,AColor2,[hgoPositiveDirection, hgoHueCorrection, hgoLightnessCorrection]);
     342    ciGSBNegative: result := TBGRAHueGradient.Create(AColor1,AColor2,[hgoNegativeDirection, hgoHueCorrection, hgoLightnessCorrection]);
     343  end;
     344  result.Repetition := ARepetition;
     345end;
     346
     347class function TBGRASimpleGradient.CreateAny(AInterpolation: TBGRAColorInterpolation;
     348  AColor1, AColor2: TExpandedPixel; ARepetition: TBGRAGradientRepetition): TBGRASimpleGradient;
     349begin
     350  case AInterpolation of
     351    ciStdRGB: result := TBGRASimpleGradientWithoutGammaCorrection.Create(AColor1,AColor2);
     352    ciLinearRGB: result := TBGRASimpleGradientWithGammaCorrection.Create(AColor1,AColor2);
     353    ciLinearHSLPositive: result := TBGRAHueGradient.Create(AColor1,AColor2,[hgoPositiveDirection]);
     354    ciLinearHSLNegative: result := TBGRAHueGradient.Create(AColor1,AColor2,[hgoNegativeDirection]);
     355    ciGSBPositive: result := TBGRAHueGradient.Create(AColor1,AColor2,[hgoPositiveDirection, hgoHueCorrection, hgoLightnessCorrection]);
     356    ciGSBNegative: result := TBGRAHueGradient.Create(AColor1,AColor2,[hgoNegativeDirection, hgoHueCorrection, hgoLightnessCorrection]);
     357  end;
     358  result.Repetition := ARepetition;
     359end;
     360
     361function TBGRASimpleGradient.GetAverageColor: TBGRAPixel;
     362begin
     363  result := InterpolateToBGRA(32768);
     364end;
     365
     366function TBGRASimpleGradient.GetAverageExpandedColor: TExpandedPixel;
     367begin
     368  Result:= InterpolateToExpanded(32768);
     369end;
     370
     371function TBGRASimpleGradient.GetColorAt(position: integer): TBGRAPixel;
     372begin
     373  case FRepetition of
     374  grSine: begin
     375            position := Sin65536(position and $ffff);
     376            if position = 65536 then
     377              result := FColor2
     378            else
     379              result := InterpolateToBGRA(position);
     380          end;
     381  grRepeat: result := InterpolateToBGRA(position and $ffff);
     382  grReflect:
     383    begin
     384      position := position and $1ffff;
     385      if position >= $10000 then
     386      begin
     387        if position = $10000 then
     388          result := FColor2
     389        else
     390          result := InterpolateToBGRA($20000 - position);
     391      end
     392      else
     393        result := InterpolateToBGRA(position);
     394    end;
     395  else
     396    begin
     397      if position <= 0 then
     398        result := FColor1 else
     399      if position >= 65536 then
     400        result := FColor2 else
     401        result := InterpolateToBGRA(position);
     402    end;
     403  end;
     404end;
     405
     406function TBGRASimpleGradient.GetColorAtF(position: single): TBGRAPixel;
     407begin
     408  if FRepetition <> grPad then
     409    result := GetColorAt(round(frac(position*0.5)*131072)) else  //divided by 2 for reflected repetition
     410  begin
     411    if position <= 0 then
     412      result := FColor1 else
     413    if position >= 1 then
     414      result := FColor2 else
     415      result := GetColorAt(round(position*65536));
     416  end;
     417end;
     418
     419function TBGRASimpleGradient.GetExpandedColorAt(position: integer
     420  ): TExpandedPixel;
     421begin
     422  case FRepetition of
     423  grSine: begin
     424            position := Sin65536(position and $ffff);
     425            if position = 65536 then
     426              result := ec2
     427            else
     428              result := InterpolateToExpanded(position);
     429          end;
     430  grRepeat: result := InterpolateToExpanded(position and $ffff);
     431  grReflect:
     432    begin
     433      position := position and $1ffff;
     434      if position >= $10000 then
     435      begin
     436        if position = $10000 then
     437          result := ec2
     438        else
     439          result := InterpolateToExpanded($20000 - position);
     440      end
     441      else
     442        result := InterpolateToExpanded(position);
     443    end;
     444  else
     445    begin
     446      if position <= 0 then
     447        result := ec1 else
     448      if position >= 65536 then
     449        result := ec2 else
     450        result := InterpolateToExpanded(position);
     451    end;
     452  end;
     453end;
     454
     455function TBGRASimpleGradient.GetExpandedColorAtF(position: single
     456  ): TExpandedPixel;
     457begin
     458  if FRepetition <> grPad then
     459    result := GetExpandedColorAt(round(frac(position*0.5)*131072)) else  //divided by 2 for reflected repetition
     460  begin
     461    if position <= 0 then
     462      result := ec1 else
     463    if position >= 1 then
     464      result := ec2 else
     465      result := GetExpandedColorAt(round(position*65536));
     466  end;
     467end;
     468
     469function TBGRASimpleGradient.GetMonochrome: boolean;
     470begin
     471  Result:= (FColor1 = FColor2);
     472end;
     473
    233474{ TBGRAConstantScanner }
    234475
     
    244485  FGrayscale:= AGrayscale;
    245486  FOpacity:= AOpacity;
     487  FRandomBufferCount := 0;
    246488end;
    247489
     
    252494
    253495function TBGRARandomScanner.ScanNextPixel: TBGRAPixel;
     496var rgb: integer;
    254497begin
    255498  if FGrayscale then
    256499  begin
    257     result.red := random(256);
     500    if FRandomBufferCount = 0 then
     501    begin
     502      FRandomBuffer := random(256*256*256);
     503      FRandomBufferCount := 3;
     504    end;
     505    result.red := FRandomBuffer and 255;
     506    FRandomBuffer:= FRandomBuffer shr 8;
     507    FRandomBufferCount -= 1;
    258508    result.green := result.red;
    259509    result.blue := result.red;
    260510    result.alpha:= FOpacity;
    261511  end else
    262     Result:= BGRA(random(256),random(256),random(256),FOpacity);
     512  begin
     513    rgb := random(256*256*256);
     514    Result:= BGRA(rgb and 255,(rgb shr 8) and 255,(rgb shr 16) and 255,FOpacity);
     515  end;
    263516end;
    264517
     
    272525procedure TBGRAHueGradient.Init(c1, c2: THSLAPixel; AOptions: THueGradientOptions);
    273526begin
    274   FColor1 := HSLAToBGRA(c1);
    275   FColor2 := HSLAToBGRA(c2);
    276   ec1 := GammaExpansion(FColor1);
    277   ec2 := GammaExpansion(FColor2);
    278527  FOptions:= AOptions;
    279528  if (hgoLightnessCorrection in AOptions) then
    280529  begin
    281     hsla1 := BGRAToGSBA(FColor1);
    282     hsla2 := BGRAToGSBA(FColor2);
     530    hsla1 := ExpandedToGSBA(ec1);
     531    hsla2 := ExpandedToGSBA(ec2);
    283532  end else
    284533  begin
     
    305554end;
    306555
    307 function TBGRAHueGradient.GetColorNoBoundCheck(position: integer): THSLAPixel;
     556function TBGRAHueGradient.InterpolateToHSLA(position: word): THSLAPixel;
    308557var b,b2: LongWord;
    309558begin
     
    325574end;
    326575
     576function TBGRAHueGradient.InterpolateToBGRA(position: word): TBGRAPixel;
     577begin
     578  if hgoLightnessCorrection in FOptions then
     579    result := GSBAToBGRA(InterpolateToHSLA(position))
     580  else
     581    result := HSLAToBGRA(InterpolateToHSLA(position));
     582end;
     583
     584function TBGRAHueGradient.InterpolateToExpanded(position: word): TExpandedPixel;
     585begin
     586  if hgoLightnessCorrection in FOptions then
     587    result := GSBAToExpanded(InterpolateToHSLA(position))
     588  else
     589    result := HSLAToExpanded(InterpolateToHSLA(position));
     590end;
     591
    327592constructor TBGRAHueGradient.Create(Color1, Color2: TBGRAPixel;options: THueGradientOptions);
    328593begin
     594  if hgoReflect in options then
     595    inherited Create(Color1,Color2,grReflect)
     596  else if hgoRepeat in options then
     597    inherited Create(Color1,Color2,grRepeat)
     598  else
     599    inherited Create(Color1,Color2,grPad);
     600
    329601  Init(BGRAToHSLA(Color1),BGRAToHSLA(Color2),options);
    330602end;
    331603
     604constructor TBGRAHueGradient.Create(Color1, Color2: TExpandedPixel;
     605  options: THueGradientOptions);
     606begin
     607  if hgoReflect in options then
     608    inherited Create(Color1,Color2,grReflect)
     609  else if hgoRepeat in options then
     610    inherited Create(Color1,Color2,grRepeat)
     611  else
     612    inherited Create(Color1,Color2,grPad);
     613
     614  Init(ExpandedToHSLA(Color1),ExpandedToHSLA(Color2),options);
     615end;
     616
    332617constructor TBGRAHueGradient.Create(Color1, Color2: THSLAPixel; options: THueGradientOptions);
    333618begin
     619  if hgoReflect in options then
     620    inherited Create(Color1.ToExpanded,Color2.ToExpanded,grReflect)
     621  else if hgoRepeat in options then
     622    inherited Create(Color1.ToExpanded,Color2.ToExpanded,grRepeat)
     623  else
     624    inherited Create(Color1.ToExpanded,Color2.ToExpanded,grPad);
     625
    334626  Init(Color1,Color2, options);
    335627end;
     
    338630  Lightness: Word; options: THueGradientOptions);
    339631begin
    340   Init(HSLA(AHue1,saturation,lightness), HSLA(AHue2,saturation,lightness), options);
    341 end;
    342 
    343 function TBGRAHueGradient.GetColorAt(position: integer): TBGRAPixel;
    344 var interm: THSLAPixel;
    345 begin
    346   if hgoRepeat in FOptions then
    347   begin
    348     position := position and $ffff;
    349     if position = 0 then
    350     begin
    351       result := FColor1;
    352       exit;
    353     end;
    354   end else
    355   begin
    356     if position <= 0 then
    357     begin
    358       result := FColor1;
    359       exit
    360     end else
    361     if position >= 65536 then
    362     begin
    363       result := FColor2;
    364       exit
    365     end;
    366   end;
    367   interm := GetColorNoBoundCheck(position);
    368   if hgoLightnessCorrection in FOptions then
    369     result := GSBAToBGRA(interm)
    370   else
    371     result := HSLAToBGRA(interm);
    372 end;
    373 
    374 function TBGRAHueGradient.GetColorAtF(position: single): TBGRAPixel;
    375 var interm: THSLAPixel;
    376 begin
    377   if hgoRepeat in FOptions then
    378   begin
    379     position := frac(position);
    380     if position = 0 then
    381     begin
    382       result := FColor1;
    383       exit;
    384     end;
    385   end else
    386   begin
    387     if position <= 0 then
    388     begin
    389       result := FColor1;
    390       exit;
    391     end else
    392     if position >= 1 then
    393     begin
    394       result := FColor2;
    395       exit
    396     end;
    397   end;
    398   interm := GetColorNoBoundCheck(round(position*65536));
    399   if hgoLightnessCorrection in FOptions then
    400     result := GSBAToBGRA(interm)
    401   else
    402     result := HSLAToBGRA(interm);
    403 end;
    404 
    405 function TBGRAHueGradient.GetAverageColor: TBGRAPixel;
    406 begin
    407   Result:= GetColorAt(32768);
    408 end;
    409 
    410 function TBGRAHueGradient.GetExpandedColorAt(position: integer): TExpandedPixel;
    411 var interm: THSLAPixel;
    412 begin
    413   if hgoRepeat in FOptions then
    414   begin
    415     position := position and $ffff;
    416     if position = 0 then
    417     begin
    418       result := ec1;
    419       exit;
    420     end;
    421   end else
    422   begin
    423     if position <= 0 then
    424     begin
    425       result := ec1;
    426       exit
    427     end else
    428     if position >= 65536 then
    429     begin
    430       result := ec2;
    431       exit
    432     end;
    433   end;
    434   interm := GetColorNoBoundCheck(position);
    435   if hgoLightnessCorrection in FOptions then
    436     result := GSBAToExpanded(interm)
    437   else
    438     result := HSLAToExpanded(interm);
    439 end;
    440 
    441 function TBGRAHueGradient.GetExpandedColorAtF(position: single): TExpandedPixel;
    442 var interm: THSLAPixel;
    443 begin
    444   if hgoRepeat in FOptions then
    445   begin
    446     position := frac(position);
    447     if position = 0 then
    448     begin
    449       result := ec1;
    450       exit;
    451     end;
    452   end else
    453   begin
    454     if position <= 0 then
    455     begin
    456       result := ec1;
    457       exit;
    458     end else
    459     if position >= 1 then
    460     begin
    461       result := ec2;
    462       exit
    463     end;
    464   end;
    465   interm := GetColorNoBoundCheck(round(position*65536));
    466   if hgoLightnessCorrection in FOptions then
    467     result := GSBAToExpanded(interm)
    468   else
    469     result := HSLAToExpanded(interm);
    470 end;
    471 
    472 function TBGRAHueGradient.GetAverageExpandedColor: TExpandedPixel;
    473 begin
    474   Result:= GetExpandedColorAt(32768);
     632  Create(HSLA(AHue1,saturation,lightness), HSLA(AHue2,saturation,lightness), options);
    475633end;
    476634
     
    670828{ TBGRASimpleGradientWithGammaCorrection }
    671829
    672 constructor TBGRASimpleGradientWithGammaCorrection.Create(Color1,
    673   Color2: TBGRAPixel);
    674 begin
    675   FColor1 := Color1;
    676   FColor2 := Color2;
    677   ec1 := GammaExpansion(Color1);
    678   ec2 := GammaExpansion(Color2);
    679 end;
    680 
    681 function TBGRASimpleGradientWithGammaCorrection.GetColorAt(position: integer
     830function TBGRASimpleGradientWithGammaCorrection.InterpolateToBGRA(position: word
    682831  ): TBGRAPixel;
    683832var b,b2: cardinal;
    684833    ec: TExpandedPixel;
    685834begin
    686   if position <= 0 then
    687     result := FColor1 else
    688   if position >= 65536 then
    689     result := FColor2 else
    690   begin
    691     b      := position;
    692     b2     := 65536-b;
    693     ec.red := (ec1.red * b2 + ec2.red * b + 32767) shr 16;
    694     ec.green := (ec1.green * b2 + ec2.green * b + 32767) shr 16;
    695     ec.blue := (ec1.blue * b2 + ec2.blue * b + 32767) shr 16;
    696     ec.alpha := (ec1.alpha * b2 + ec2.alpha * b + 32767) shr 16;
    697     result := GammaCompression(ec);
    698   end;
    699 end;
    700 
    701 function TBGRASimpleGradientWithGammaCorrection.GetColorAtF(position: single): TBGRAPixel;
     835  b      := position;
     836  b2     := 65536-b;
     837  ec.red := (ec1.red * b2 + ec2.red * b + 32767) shr 16;
     838  ec.green := (ec1.green * b2 + ec2.green * b + 32767) shr 16;
     839  ec.blue := (ec1.blue * b2 + ec2.blue * b + 32767) shr 16;
     840  ec.alpha := (ec1.alpha * b2 + ec2.alpha * b + 32767) shr 16;
     841  result := GammaCompression(ec);
     842end;
     843
     844function TBGRASimpleGradientWithGammaCorrection.InterpolateToExpanded(
     845  position: word): TExpandedPixel;
    702846var b,b2: cardinal;
    703     ec: TExpandedPixel;
    704 begin
    705   if position <= 0 then
    706     result := FColor1 else
    707   if position >= 1 then
    708     result := FColor2 else
    709   begin
    710     b      := round(position*65536);
    711     b2     := 65536-b;
    712     ec.red := (ec1.red * b2 + ec2.red * b + 32767) shr 16;
    713     ec.green := (ec1.green * b2 + ec2.green * b + 32767) shr 16;
    714     ec.blue := (ec1.blue * b2 + ec2.blue * b + 32767) shr 16;
    715     ec.alpha := (ec1.alpha * b2 + ec2.alpha * b + 32767) shr 16;
    716     result := GammaCompression(ec);
    717   end;
    718 end;
    719 
    720 function TBGRASimpleGradientWithGammaCorrection.GetAverageColor: TBGRAPixel;
    721 begin
    722   result := GammaCompression(MergeBGRA(ec1,ec2));
    723 end;
    724 
    725 function TBGRASimpleGradientWithGammaCorrection.GetExpandedColorAt(
    726   position: integer): TExpandedPixel;
     847begin
     848  b      := position;
     849  b2     := 65536-b;
     850  result.red := (ec1.red * b2 + ec2.red * b + 32767) shr 16;
     851  result.green := (ec1.green * b2 + ec2.green * b + 32767) shr 16;
     852  result.blue := (ec1.blue * b2 + ec2.blue * b + 32767) shr 16;
     853  result.alpha := (ec1.alpha * b2 + ec2.alpha * b + 32767) shr 16;
     854end;
     855
     856constructor TBGRASimpleGradientWithGammaCorrection.Create(Color1,
     857  Color2: TBGRAPixel; ARepetition: TBGRAGradientRepetition);
     858begin
     859  inherited Create(Color1,Color2,ARepetition);
     860end;
     861
     862constructor TBGRASimpleGradientWithGammaCorrection.Create(Color1,
     863  Color2: TExpandedPixel; ARepetition: TBGRAGradientRepetition);
     864begin
     865  inherited Create(Color1,Color2,ARepetition);
     866end;
     867
     868{ TBGRASimpleGradientWithoutGammaCorrection }
     869
     870function TBGRASimpleGradientWithoutGammaCorrection.InterpolateToBGRA(
     871  position: word): TBGRAPixel;
    727872var b,b2: cardinal;
    728873begin
    729   if position <= 0 then
    730     result := ec1 else
    731   if position >= 65536 then
    732     result := ec2 else
    733   begin
    734     b      := position;
    735     b2     := 65536-b;
    736     result.red := (ec1.red * b2 + ec2.red * b + 32767) shr 16;
    737     result.green := (ec1.green * b2 + ec2.green * b + 32767) shr 16;
    738     result.blue := (ec1.blue * b2 + ec2.blue * b + 32767) shr 16;
    739     result.alpha := (ec1.alpha * b2 + ec2.alpha * b + 32767) shr 16;
    740   end;
    741 end;
    742 
    743 function TBGRASimpleGradientWithGammaCorrection.GetExpandedColorAtF(
    744   position: single): TExpandedPixel;
    745 var b,b2: cardinal;
    746 begin
    747   if position <= 0 then
    748     result := ec1 else
    749   if position >= 1 then
    750     result := ec2 else
    751   begin
    752     b      := round(position*65536);
    753     b2     := 65536-b;
    754     result.red := (ec1.red * b2 + ec2.red * b + 32767) shr 16;
    755     result.green := (ec1.green * b2 + ec2.green * b + 32767) shr 16;
    756     result.blue := (ec1.blue * b2 + ec2.blue * b + 32767) shr 16;
    757     result.alpha := (ec1.alpha * b2 + ec2.alpha * b + 32767) shr 16;
    758   end;
    759 end;
    760 
    761 function TBGRASimpleGradientWithGammaCorrection.GetAverageExpandedColor: TExpandedPixel;
    762 begin
    763   result := MergeBGRA(ec1,ec2);
    764 end;
    765 
    766 function TBGRASimpleGradientWithGammaCorrection.GetMonochrome: boolean;
    767 begin
    768   Result:= (FColor1 = FColor2);
    769 end;
    770 
    771 { TBGRASimpleGradientWithoutGammaCorrection }
    772 
    773 constructor TBGRASimpleGradientWithoutGammaCorrection.Create(Color1,
    774   Color2: TBGRAPixel);
    775 begin
    776   FColor1 := Color1;
    777   FColor2 := Color2;
    778   ec1 := GammaExpansion(Color1);
    779   ec2 := GammaExpansion(Color2);
    780 end;
    781 
    782 function TBGRASimpleGradientWithoutGammaCorrection.GetColorAt(position: integer
    783   ): TBGRAPixel;
    784 var b,b2: cardinal;
    785 begin
    786   if position <= 0 then
    787     result := FColor1 else
    788   if position >= 65536 then
    789     result := FColor2 else
    790   begin
    791     b      := position shr 6;
    792     b2     := 1024-b;
    793     result.red  := (FColor1.red * b2 + FColor2.red * b + 511) shr 10;
    794     result.green := (FColor1.green * b2 + FColor2.green * b + 511) shr 10;
    795     result.blue := (FColor1.blue * b2 + FColor2.blue * b + 511) shr 10;
    796     result.alpha := (FColor1.alpha * b2 + FColor2.alpha * b + 511) shr 10;
    797   end;
    798 end;
    799 
    800 function TBGRASimpleGradientWithoutGammaCorrection.GetColorAtF(position: single): TBGRAPixel;
    801 begin
    802   if position <= 0 then
    803     result := FColor1 else
    804   if position >= 1 then
    805     result := FColor2 else
    806     result := GetColorAt(round(position*65536));
    807 end;
    808 
    809 function TBGRASimpleGradientWithoutGammaCorrection.GetExpandedColorAt(
    810   position: integer): TExpandedPixel;
     874  b      := position shr 6;
     875  b2     := 1024-b;
     876  result.red  := (FColor1.red * b2 + FColor2.red * b + 511) shr 10;
     877  result.green := (FColor1.green * b2 + FColor2.green * b + 511) shr 10;
     878  result.blue := (FColor1.blue * b2 + FColor2.blue * b + 511) shr 10;
     879  result.alpha := (FColor1.alpha * b2 + FColor2.alpha * b + 511) shr 10;
     880end;
     881
     882function TBGRASimpleGradientWithoutGammaCorrection.InterpolateToExpanded(
     883  position: word): TExpandedPixel;
    811884var b,b2: cardinal;
    812885    rw,gw,bw: word;
    813886begin
    814   if position <= 0 then
    815     result := ec1 else
    816   if position >= 65536 then
    817     result := ec2 else
    818   begin
    819     b      := position shr 6;
    820     b2     := 1024-b;
    821     rw  := (FColor1.red * b2 + FColor2.red * b + 511) shr 2;
    822     gw := (FColor1.green * b2 + FColor2.green * b + 511) shr 2;
    823     bw := (FColor1.blue * b2 + FColor2.blue * b + 511) shr 2;
    824 
     887  b      := position shr 6;
     888  b2     := 1024-b;
     889  rw  := (FColor1.red * b2 + FColor2.red * b + 511) shr 2;
     890  gw := (FColor1.green * b2 + FColor2.green * b + 511) shr 2;
     891  bw := (FColor1.blue * b2 + FColor2.blue * b + 511) shr 2;
     892
     893  if rw >= $ff00 then
     894    result.red := 65535
     895  else
    825896    result.red := (GammaExpansionTab[rw shr 8]*NativeUInt(255 - (rw and 255)) + GammaExpansionTab[(rw shr 8)+1]*NativeUInt(rw and 255)) shr 8;
     897
     898  if gw >= $ff00 then
     899    result.green := 65535
     900  else
    826901    result.green := (GammaExpansionTab[gw shr 8]*NativeUInt(255 - (gw and 255)) + GammaExpansionTab[(gw shr 8)+1]*NativeUInt(gw and 255)) shr 8;
     902
     903  if bw >= $ff00 then
     904    result.blue := 65535
     905  else
    827906    result.blue := (GammaExpansionTab[bw shr 8]*NativeUInt(255 - (bw and 255)) + GammaExpansionTab[(bw shr 8)+1]*NativeUInt(bw and 255)) shr 8;
    828     result.alpha := (FColor1.alpha * b2 + FColor2.alpha * b + 511) shr 2;
    829   end;
    830 end;
    831 
    832 function TBGRASimpleGradientWithoutGammaCorrection.GetExpandedColorAtF(
    833   position: single): TExpandedPixel;
    834 begin
    835   if position <= 0 then
    836     result := ec1 else
    837   if position >= 1 then
    838     result := ec2 else
    839     result := GetExpandedColorAt(round(position*65536));
    840 end;
    841 
    842 function TBGRASimpleGradientWithoutGammaCorrection.GetAverageColor: TBGRAPixel;
    843 begin
    844   result := MergeBGRA(FColor1,FColor2);
    845 end;
    846 
    847 function TBGRASimpleGradientWithoutGammaCorrection.GetMonochrome: boolean;
    848 begin
    849   Result:= (FColor1 = FColor2);
     907
     908  result.alpha := (FColor1.alpha * b2 + FColor2.alpha * b + 511) shr 2;
     909end;
     910
     911constructor TBGRASimpleGradientWithoutGammaCorrection.Create(Color1,
     912  Color2: TBGRAPixel; ARepetition: TBGRAGradientRepetition);
     913begin
     914  inherited Create(Color1,Color2,ARepetition);
     915end;
     916
     917constructor TBGRASimpleGradientWithoutGammaCorrection.Create(Color1,
     918  Color2: TExpandedPixel; ARepetition: TBGRAGradientRepetition);
     919begin
     920  inherited Create(Color1,Color2,ARepetition);
    850921end;
    851922
     
    9461017{ TBGRAGradientScanner }
    9471018
    948 procedure TBGRAGradientScanner.Init(gtype: TGradientType; o1, o2: TPointF;
    949   Sinus: Boolean);
    950 begin
    951   FGradientType:= gtype;
    952   FOrigin1 := o1;
    953   FOrigin2 := o2;
     1019procedure TBGRAGradientScanner.SetTransform(AValue: TAffineMatrix);
     1020begin
     1021  if FTransform=AValue then Exit;
     1022  FTransform:=AValue;
     1023  InitTransform;
     1024end;
     1025
     1026constructor TBGRAGradientScanner.Create(AGradientType: TGradientType; AOrigin, d1: TPointF);
     1027begin
     1028  FGradient := nil;
     1029  SetGradient(BGRABlack,BGRAWhite,False);
     1030  Init(AGradientType,AOrigin,d1,AffineMatrixIdentity,False);
     1031end;
     1032
     1033constructor TBGRAGradientScanner.Create(AGradientType: TGradientType; AOrigin, d1,d2: TPointF);
     1034begin
     1035  FGradient := nil;
     1036  SetGradient(BGRABlack,BGRAWhite,False);
     1037  Init(AGradientType,AOrigin,d1,d2,AffineMatrixIdentity,False);
     1038end;
     1039
     1040constructor TBGRAGradientScanner.Create(AOrigin,
     1041  d1, d2, AFocal: TPointF; ARadiusRatio: single; AFocalRadiusRatio: single);
     1042var
     1043  m, mInv: TAffineMatrix;
     1044  focalInv: TPointF;
     1045begin
     1046  FGradient := nil;
     1047  SetGradient(BGRABlack,BGRAWhite,False);
     1048
     1049  m := AffineMatrix((d1-AOrigin).x, (d2-AOrigin).x, AOrigin.x,
     1050                    (d1-AOrigin).y, (d2-AOrigin).y, AOrigin.y);
     1051  if IsAffineMatrixInversible(m) then
     1052  begin
     1053    mInv := AffineMatrixInverse(m);
     1054    focalInv := mInv*AFocal;
     1055  end else
     1056    focalInv := PointF(0,0);
     1057
     1058  Init(PointF(0,0), ARadiusRatio, focalInv, AFocalRadiusRatio, AffineMatrixIdentity, m);
     1059end;
     1060
     1061constructor TBGRAGradientScanner.Create(AOrigin: TPointF; ARadius: single;
     1062  AFocal: TPointF; AFocalRadius: single);
     1063begin
     1064  FGradient := nil;
     1065  SetGradient(BGRABlack,BGRAWhite,False);
     1066
     1067  Init(AOrigin, ARadius, AFocal, AFocalRadius, AffineMatrixIdentity, AffineMatrixIdentity);
     1068end;
     1069
     1070procedure TBGRAGradientScanner.SetFlipGradient(AValue: boolean);
     1071begin
     1072  if FFlipGradient=AValue then Exit;
     1073  FFlipGradient:=AValue;
     1074end;
     1075
     1076function TBGRAGradientScanner.GetGradientColor(a: single): TBGRAPixel;
     1077begin
     1078  if a = EmptySingle then
     1079    result := BGRAPixelTransparent
     1080  else
     1081  begin
     1082    if FFlipGradient then a := 1-a;
     1083    if FSinus then
     1084    begin
     1085      a := a*65536;
     1086      if (a <= low(int64)) or (a >= high(int64)) then
     1087        result := FAverageColor
     1088      else
     1089        result := FGradient.GetColorAt(Sin65536(round(a) and 65535));
     1090    end else
     1091      result := FGradient.GetColorAtF(a);
     1092  end;
     1093end;
     1094
     1095function TBGRAGradientScanner.GetGradientExpandedColor(a: single): TExpandedPixel;
     1096begin
     1097  if a = EmptySingle then
     1098    QWord(result) := 0
     1099  else
     1100  begin
     1101    if FFlipGradient then a := 1-a;
     1102    if FSinus then
     1103    begin
     1104      a *= 65536;
     1105      if (a <= low(int64)) or (a >= high(int64)) then
     1106        result := FAverageExpandedColor
     1107      else
     1108        result := FGradient.GetExpandedColorAt(Sin65536(round(a) and 65535));
     1109    end else
     1110      result := FGradient.GetExpandedColorAtF(a);
     1111  end;
     1112end;
     1113
     1114procedure TBGRAGradientScanner.Init(AGradientType: TGradientType; AOrigin, d1: TPointF;
     1115  ATransform: TAffineMatrix; Sinus: Boolean);
     1116var d2: TPointF;
     1117begin
     1118  with (d1-AOrigin) do
     1119    d2 := PointF(AOrigin.x+y,AOrigin.y-x);
     1120  Init(AGradientType,AOrigin,d1,d2,ATransform,Sinus);
     1121end;
     1122
     1123procedure TBGRAGradientScanner.Init(AGradientType: TGradientType; AOrigin, d1, d2: TPointF;
     1124  ATransform: TAffineMatrix; Sinus: Boolean);
     1125begin
     1126  FGradientType:= AGradientType;
     1127  FFlipGradient:= false;
     1128  FOrigin := AOrigin;
     1129  FDir1 := d1;
     1130  FDir2 := d2;
    9541131  FSinus := Sinus;
    955 
    956   //compute vector
    957   u.x := o2.x - o1.x;
    958   u.y := o2.y - o1.y;
    959   len := sqrt(sqr(u.x) + sqr(u.y));
    960   if len <> 0 then
    961   begin
    962     u.x /= len;
    963     u.y /= len;
    964     aFactor := 65536/len;
    965     aFactorF := 1/len;
    966   end
    967   else
    968   begin
    969     aFactor := 0;
    970     aFactorF := 0;
    971   end;
    972 
    973   FVertical := (((gtype =gtLinear) or (gtype=gtReflected)) and (o1.x=o2.x)) or FGradient.Monochrome;
    974   mergedColor := FGradient.GetAverageColor;
    975   mergedExpandedColor := FGradient.GetAverageExpandedColor;
    976 end;
    977 
    978 procedure TBGRAGradientScanner.InitScanInline(x, y: integer);
    979 var p: TPointF;
    980 begin
    981   p.x := X - FOrigin1.x;
    982   p.y := Y - FOrigin1.y;
    983   FDotProduct := p.x * u.x + p.y * u.y;
    984   FDotProductPerp := p.x * u.y - p.y * u.x;
    985 end;
    986 
    987 function TBGRAGradientScanner.ScanNextInline: TBGRAPixel;
    988 var
    989   a,a2: single;
    990   ai: integer;
    991 begin
    992   if FGradientType >= gtDiamond then
    993   begin
    994     if FGradientType = gtRadial then
     1132  FTransform := ATransform;
     1133  FHiddenTransform := AffineMatrixIdentity;
     1134
     1135  FRadius := 1;
     1136  FRelativeFocal := PointF(0,0);
     1137  FFocalRadius := 0;
     1138
     1139  InitGradientType;
     1140  InitTransform;
     1141end;
     1142
     1143procedure TBGRAGradientScanner.Init(AOrigin: TPointF; ARadius: single;
     1144  AFocal: TPointF; AFocalRadius: single; ATransform: TAffineMatrix; AHiddenTransform: TAffineMatrix);
     1145var maxRadius: single;
     1146begin
     1147  FGradientType:= gtRadial;
     1148  FFlipGradient:= false;
     1149  FOrigin := AOrigin;
     1150  ARadius := abs(ARadius);
     1151  AFocalRadius := abs(AFocalRadius);
     1152  maxRadius := max(ARadius,AFocalRadius);
     1153  FDir1 := AOrigin+PointF(maxRadius,0);
     1154  FDir2 := AOrigin+PointF(0,maxRadius);
     1155  FSinus := False;
     1156  FTransform := ATransform;
     1157  FHiddenTransform := AHiddenTransform;
     1158
     1159  FRadius := ARadius/maxRadius;
     1160  FRelativeFocal := (AFocal - AOrigin)*(1/maxRadius);
     1161  FFocalRadius := AFocalRadius/maxRadius;
     1162
     1163  InitGradientType;
     1164  InitTransform;
     1165end;
     1166
     1167procedure TBGRAGradientScanner.InitGradientType;
     1168begin
     1169  case FGradientType of
     1170    gtReflected: begin
     1171      FScanNextFunc:= @ScanNextReflected;
     1172      FScanAtFunc:= @ScanAtReflected;
     1173    end;
     1174    gtDiamond: begin
     1175      FScanNextFunc:= @ScanNextDiamond;
     1176      FScanAtFunc:= @ScanAtDiamond;
     1177    end;
     1178    gtRadial: if (FRelativeFocal.x = 0) and (FRelativeFocal.y = 0) then
    9951179    begin
    996       a := sqrt(sqr(FDotProduct) + sqr(FDotProductPerp));
    997       FDotProduct += u.x;
    998       FDotProductPerp += u.y;
     1180      if (FFocalRadius = 0) and (FRadius = 1) then
     1181      begin
     1182        FScanNextFunc:= @ScanNextRadial;
     1183        FScanAtFunc:= @ScanAtRadial;
     1184      end else
     1185      begin
     1186        FScanNextFunc:= @ScanNextRadial2;
     1187        FScanAtFunc:= @ScanAtRadial2;
     1188      end;
    9991189    end else
    10001190    begin
    1001       a   := abs(FDotProduct);
    1002       a2  := abs(FDotProductPerp);
    1003       if a2 > a then a := a2;
    1004       FDotProduct += u.x;
    1005       FDotProductPerp += u.y;
     1191      FScanNextFunc:= @ScanNextRadialFocal;
     1192      FScanAtFunc:= @ScanAtRadialFocal;
     1193
     1194      FFocalDirection := FRelativeFocal;
     1195      FFocalDistance := VectLen(FFocalDirection);
     1196      if FFocalDistance > 0 then FFocalDirection *= 1/FFocalDistance;
     1197      FFocalNormal := PointF(-FFocalDirection.y,FFocalDirection.x);
     1198      FRadialDenominator := sqr(FRadius-FFocalRadius)-sqr(FFocalDistance);
     1199
     1200      //case in which the second circle is bigger and the first circle is within the second
     1201      if (FRadius < FFocalRadius) and (FFocalDistance <= FFocalRadius-FRadius) then
     1202        FRadialDeltaSign := -1
     1203      else
     1204        FRadialDeltaSign := 1;
     1205
     1206      //clipping afer the apex
     1207      if (FFocalRadius < FRadius) and (FFocalDistance > FRadius-FFocalRadius) then
     1208      begin
     1209        maxW1 := FRadius/(FRadius-FFocalRadius)*FFocalDistance;
     1210        maxW2 := MaxSingle;
     1211      end else
     1212      if (FRadius < FFocalRadius) and (FFocalDistance > FFocalRadius-FRadius) then
     1213      begin
     1214        maxW1 := MaxSingle;
     1215        maxW2 := FFocalRadius/(FFocalRadius-FRadius)*FFocalDistance;
     1216      end else
     1217      begin
     1218        maxW1 := MaxSingle;
     1219        maxW2 := MaxSingle;
     1220      end;
    10061221    end;
    1007   end else
    1008   if FGradientType = gtReflected then
    1009   begin
    1010     a := abs(FDotProduct);
    1011     FDotProduct += u.x;
    1012   end else
    1013   begin
    1014     a := FDotProduct;
    1015     FDotProduct += u.x;
    1016   end;
    1017 
    1018   if FSinus then
    1019   begin
    1020     a *= aFactor;
    1021     if a <= low(int64) then
    1022       result := FGradient.GetAverageColor
    1023     else
    1024     if a >= high(int64) then
    1025       result := FGradient.GetAverageColor
    1026     else
    1027     begin
    1028       ai := Sin65536(round(a));
    1029       result := FGradient.GetColorAt(ai);
     1222    gtAngular: begin
     1223      FScanNextFunc:= @ScanNextAngular;
     1224      FScanAtFunc:= @ScanAtAngular;
    10301225    end;
    1031   end else
    1032     result := FGradient.GetColorAtF(a*aFactorF);
    1033 end;
    1034 
    1035 function TBGRAGradientScanner.ScanNextExpandedInline: TExpandedPixel;
    1036 var
    1037   a,a2: single;
    1038   ai: integer;
    1039 begin
    1040   if FGradientType >= gtDiamond then
    1041   begin
    1042     if FGradientType = gtRadial then
    1043     begin
    1044       a := sqrt(sqr(FDotProduct) + sqr(FDotProductPerp));
    1045       FDotProduct += u.x;
    1046       FDotProductPerp += u.y;
    1047     end else
    1048     begin
    1049       a   := abs(FDotProduct);
    1050       a2  := abs(FDotProductPerp);
    1051       if a2 > a then a := a2;
    1052       FDotProduct += u.x;
    1053       FDotProductPerp += u.y;
     1226  else
     1227    {gtLinear:} begin
     1228      FScanNextFunc:= @ScanNextLinear;
     1229      FScanAtFunc:= @ScanAtLinear;
    10541230    end;
    1055   end else
    1056   if FGradientType = gtReflected then
    1057   begin
    1058     a := abs(FDotProduct);
    1059     FDotProduct += u.x;
    1060   end else
    1061   begin
    1062     a := FDotProduct;
    1063     FDotProduct += u.x;
    1064   end;
    1065 
    1066   if FSinus then
    1067   begin
    1068     a *= aFactor;
    1069     if a <= low(int64) then
    1070       result := FGradient.GetAverageExpandedColor
    1071     else
    1072     if a >= high(int64) then
    1073       result := FGradient.GetAverageExpandedColor
    1074     else
    1075     begin
    1076       ai := Sin65536(round(a));
    1077       result := FGradient.GetExpandedColorAt(ai);
    1078     end;
    1079   end else
    1080     result := FGradient.GetExpandedColorAtF(a*aFactorF);
    1081 end;
    1082 
    1083 constructor TBGRAGradientScanner.Create(c1, c2: TBGRAPixel;
    1084   gtype: TGradientType; o1, o2: TPointF; gammaColorCorrection: boolean;
    1085   Sinus: Boolean);
    1086 begin
     1231  end;
     1232end;
     1233
     1234procedure TBGRAGradientScanner.SetGradient(c1, c2: TBGRAPixel;
     1235  AGammaCorrection: boolean);
     1236begin
     1237  if Assigned(FGradient) and FGradientOwner then FreeAndNil(FGradient);
     1238
    10871239  //transparent pixels have no color so
    10881240  //take it from other color
    1089   if c1.alpha = 0 then
    1090   begin
    1091     c1.red   := c2.red;
    1092     c1.green := c2.green;
    1093     c1.blue  := c2.blue;
    1094   end
    1095   else
    1096   if c2.alpha = 0 then
    1097   begin
    1098     c2.red   := c1.red;
    1099     c2.green := c1.green;
    1100     c2.blue  := c1.blue;
    1101   end;
    1102 
    1103   if gammaColorCorrection then
    1104   begin
    1105     FGradient := TBGRASimpleGradientWithGammaCorrection.Create(c1,c2);
    1106     FGradientOwner := true;
     1241  if c1.alpha = 0 then c1 := BGRA(c2.red,c2.green,c2.blue,0);
     1242  if c2.alpha = 0 then c2 := BGRA(c1.red,c1.green,c1.blue,0);
     1243
     1244  if AGammaCorrection then
     1245    FGradient := TBGRASimpleGradientWithGammaCorrection.Create(c1,c2)
     1246  else
     1247    FGradient := TBGRASimpleGradientWithoutGammaCorrection.Create(c1,c2);
     1248  FGradientOwner := true;
     1249  InitGradient;
     1250end;
     1251
     1252procedure TBGRAGradientScanner.SetGradient(AGradient: TBGRACustomGradient;
     1253  AOwner: boolean);
     1254begin
     1255  if Assigned(FGradient) and FGradientOwner then FreeAndNil(FGradient);
     1256  FGradient := AGradient;
     1257  FGradientOwner := AOwner;
     1258  InitGradient;
     1259end;
     1260
     1261procedure TBGRAGradientScanner.InitTransform;
     1262var u,v: TPointF;
     1263begin
     1264  u := FDir1-FOrigin;
     1265  if FGradientType in[gtLinear,gtReflected] then
     1266    v := PointF(u.y, -u.x)
     1267  else
     1268    v := FDir2-FOrigin;
     1269
     1270  FMatrix := FTransform * FHiddenTransform * AffineMatrix(u.x, v.x, FOrigin.x,
     1271                                                          u.y, v.y, FOrigin.y);
     1272  if IsAffineMatrixInversible(FMatrix) then
     1273  begin
     1274    FMatrix := AffineMatrixInverse(FMatrix);
     1275    FIsAverage:= false;
    11071276  end else
    11081277  begin
    1109     FGradient := TBGRASimpleGradientWithoutGammaCorrection.Create(c1,c2);
    1110     FGradientOwner := true;
    1111   end;
    1112   Init(gtype,o1,o2,Sinus);
     1278    FMatrix := AffineMatrixIdentity;
     1279    FIsAverage:= true;
     1280  end;
     1281
     1282  case FGradientType of
     1283    gtReflected: FRepeatHoriz := (FMatrix[1,1]=0);
     1284    gtDiamond,gtAngular: FRepeatHoriz:= FIsAverage;
     1285    gtRadial: begin
     1286      if FFocalRadius = FRadius then FIsAverage:= true;
     1287      FRepeatHoriz:= FIsAverage;
     1288    end
     1289  else
     1290    {gtLinear:} FRepeatHoriz := (FMatrix[1,1]=0);
     1291  end;
     1292
     1293  if FGradient.Monochrome then
     1294  begin
     1295    FRepeatHoriz:= true;
     1296    FIsAverage:= true;
     1297  end;
     1298
     1299  FPosition := PointF(0,0);
     1300end;
     1301
     1302procedure TBGRAGradientScanner.InitGradient;
     1303begin
     1304  FAverageColor := FGradient.GetAverageColor;
     1305  FAverageExpandedColor := FGradient.GetAverageExpandedColor;
     1306end;
     1307
     1308function TBGRAGradientScanner.ComputeRadialFocal(const p: TPointF): single;
     1309var
     1310  w1,w2,h,d1,d2,delta,num: single;
     1311begin
     1312  w1 := p*FFocalDirection;
     1313  w2 := FFocalDistance-w1;
     1314  if (w1 < maxW1) and (w2 < maxW2) then
     1315  begin
     1316    //vertical position and distances
     1317    h := sqr(p*FFocalNormal);
     1318    d1 := sqr(w1)+h;
     1319    d2 := sqr(w2)+h;
     1320    //finding t
     1321    delta := sqr(FFocalRadius)*d1 + 2*FRadius*FFocalRadius*(p*(FRelativeFocal-p))+
     1322             sqr(FRadius)*d2 - sqr(VectDet(p,FRelativeFocal));
     1323    if delta >= 0 then
     1324    begin
     1325      num := -FFocalRadius*(FRadius-FFocalRadius)-(FRelativeFocal*(FRelativeFocal-p));
     1326      result := (num+FRadialDeltaSign*sqrt(delta))/FRadialDenominator;
     1327    end else
     1328      result := EmptySingle;
     1329  end else
     1330    result := EmptySingle;
     1331end;
     1332
     1333function TBGRAGradientScanner.ScanNextLinear: single;
     1334begin
     1335  result := FPosition.x;
     1336end;
     1337
     1338function TBGRAGradientScanner.ScanNextReflected: single;
     1339begin
     1340  result := abs(FPosition.x);
     1341end;
     1342
     1343function TBGRAGradientScanner.ScanNextDiamond: single;
     1344begin
     1345  result := max(abs(FPosition.x), abs(FPosition.y));
     1346end;
     1347
     1348function TBGRAGradientScanner.ScanNextRadial: single;
     1349begin
     1350  result := sqrt(sqr(FPosition.x) + sqr(FPosition.y));
     1351end;
     1352
     1353function TBGRAGradientScanner.ScanNextRadial2: single;
     1354begin
     1355  result := (sqrt(sqr(FPosition.x) + sqr(FPosition.y))-FFocalRadius)/(FRadius-FFocalRadius);
     1356end;
     1357
     1358function TBGRAGradientScanner.ScanNextRadialFocal: single;
     1359begin
     1360  result := ComputeRadialFocal(FPosition);
     1361end;
     1362
     1363function TBGRAGradientScanner.ScanNextAngular: single;
     1364begin
     1365  if FPosition.y >= 0 then
     1366    result := arctan2(FPosition.y,FPosition.x)/(2*Pi)
     1367  else
     1368    result := 1-arctan2(-FPosition.y,FPosition.x)/(2*Pi)
     1369end;
     1370
     1371function TBGRAGradientScanner.ScanAtLinear(const p: TPointF): single;
     1372begin
     1373  with (FMatrix*p) do
     1374    result := x;
     1375end;
     1376
     1377function TBGRAGradientScanner.ScanAtReflected(const p: TPointF): single;
     1378begin
     1379  with (FMatrix*p) do
     1380    result := abs(x);
     1381end;
     1382
     1383function TBGRAGradientScanner.ScanAtDiamond(const p: TPointF): single;
     1384begin
     1385  with (FMatrix*p) do
     1386    result := max(abs(x), abs(y));
     1387end;
     1388
     1389function TBGRAGradientScanner.ScanAtRadial(const p: TPointF): single;
     1390begin
     1391  with (FMatrix*p) do
     1392    result := sqrt(sqr(x) + sqr(y));
     1393end;
     1394
     1395function TBGRAGradientScanner.ScanAtRadial2(const p: TPointF): single;
     1396begin
     1397  with (FMatrix*p) do
     1398    result := (sqrt(sqr(x) + sqr(y))-FFocalRadius)/(FRadius-FFocalRadius);
     1399end;
     1400
     1401function TBGRAGradientScanner.ScanAtRadialFocal(const p: TPointF): single;
     1402begin
     1403  result := ComputeRadialFocal(FMatrix*p);
     1404end;
     1405
     1406function TBGRAGradientScanner.ScanAtAngular(const p: TPointF): single;
     1407begin
     1408  with (FMatrix*p) do
     1409  begin
     1410    if y >= 0 then
     1411      result := arctan2(y,x)/(2*Pi)
     1412    else
     1413      result := 1-arctan2(-y,x)/(2*Pi)
     1414  end;
     1415end;
     1416
     1417function TBGRAGradientScanner.ScanNextInline: TBGRAPixel;
     1418begin
     1419  if FIsAverage then
     1420    result := FAverageColor
     1421  else
     1422  begin
     1423    result := GetGradientColor(FScanNextFunc());
     1424    FPosition += PointF(FMatrix[1,1],FMatrix[2,1]);
     1425  end;
     1426end;
     1427
     1428function TBGRAGradientScanner.ScanNextExpandedInline: TExpandedPixel;
     1429begin
     1430  if FIsAverage then
     1431    result := FAverageExpandedColor
     1432  else
     1433  begin
     1434    result := GetGradientExpandedColor(FScanNextFunc());
     1435    FPosition += PointF(FMatrix[1,1],FMatrix[2,1]);
     1436  end;
     1437end;
     1438
     1439constructor TBGRAGradientScanner.Create(c1, c2: TBGRAPixel;
     1440  AGradientType: TGradientType; AOrigin, d1: TPointF; gammaColorCorrection: boolean;
     1441  Sinus: Boolean);
     1442begin
     1443  FGradient := nil;
     1444  SetGradient(c1,c2,gammaColorCorrection);
     1445  Init(AGradientType,AOrigin,d1,AffineMatrixIdentity,Sinus);
     1446end;
     1447
     1448constructor TBGRAGradientScanner.Create(c1, c2: TBGRAPixel;
     1449  AGradientType: TGradientType; AOrigin, d1, d2: TPointF; gammaColorCorrection: boolean;
     1450  Sinus: Boolean);
     1451begin
     1452  FGradient := nil;
     1453  if AGradientType in[gtLinear,gtReflected] then raise EInvalidArgument.Create('Two directions are not required for linear and reflected gradients');
     1454  SetGradient(c1,c2,gammaColorCorrection);
     1455  Init(AGradientType,AOrigin,d1,d2,AffineMatrixIdentity,Sinus);
    11131456end;
    11141457
    11151458constructor TBGRAGradientScanner.Create(gradient: TBGRACustomGradient;
    1116   gtype: TGradientType; o1, o2: TPointF; Sinus: Boolean; AGradientOwner: Boolean=False);
     1459  AGradientType: TGradientType; AOrigin, d1: TPointF; Sinus: Boolean; AGradientOwner: Boolean=False);
    11171460begin
    11181461  FGradient := gradient;
    11191462  FGradientOwner := AGradientOwner;
    1120   Init(gtype,o1,o2,Sinus);
     1463  Init(AGradientType,AOrigin,d1,AffineMatrixIdentity,Sinus);
     1464end;
     1465
     1466constructor TBGRAGradientScanner.Create(gradient: TBGRACustomGradient;
     1467  AGradientType: TGradientType; AOrigin, d1, d2: TPointF; Sinus: Boolean;
     1468  AGradientOwner: Boolean);
     1469begin
     1470  if AGradientType in[gtLinear,gtReflected] then raise EInvalidArgument.Create('Two directions are not required for linear and reflected gradients');
     1471  FGradient := gradient;
     1472  FGradientOwner := AGradientOwner;
     1473  Init(AGradientType,AOrigin,d1,d2,AffineMatrixIdentity,Sinus);
     1474end;
     1475
     1476constructor TBGRAGradientScanner.Create(gradient: TBGRACustomGradient;
     1477  AOrigin: TPointF; ARadius: single; AFocal: TPointF; AFocalRadius: single;
     1478  AGradientOwner: Boolean);
     1479begin
     1480  FGradient := gradient;
     1481  FGradientOwner := AGradientOwner;
     1482  Init(AOrigin, ARadius, AFocal, AFocalRadius, AffineMatrixIdentity, AffineMatrixIdentity);
    11211483end;
    11221484
     
    11301492procedure TBGRAGradientScanner.ScanMoveTo(X, Y: Integer);
    11311493begin
    1132   InitScanInline(X,Y);
    1133   if FVertical then
     1494  FPosition := FMatrix*PointF(x,y);
     1495  if FRepeatHoriz then
    11341496  begin
    11351497    FHorizColor := ScanNextInline;
     
    11401502function TBGRAGradientScanner.ScanNextPixel: TBGRAPixel;
    11411503begin
    1142   if FVertical then
     1504  if FRepeatHoriz then
    11431505    result := FHorizColor
    11441506  else
     
    11481510function TBGRAGradientScanner.ScanNextExpandedPixel: TExpandedPixel;
    11491511begin
    1150   if FVertical then
     1512  if FRepeatHoriz then
    11511513    result := FHorizExpandedColor
    11521514  else
     
    11551517
    11561518function TBGRAGradientScanner.ScanAt(X, Y: Single): TBGRAPixel;
    1157 var p: TPointF;
    1158     a,a2: single;
    1159     ai: integer;
    1160 begin
    1161   if len = 0 then
    1162   begin
    1163     result := mergedColor;
    1164     exit;
    1165   end;
    1166 
    1167   p.x := X - FOrigin1.x;
    1168   p.y := Y - FOrigin1.y;
    1169   case FGradientType of
    1170     gtLinear:    a := p.x * u.x + p.y * u.y;
    1171     gtReflected: a := abs(p.x * u.x + p.y * u.y);
    1172     gtDiamond:
    1173         begin
    1174           a   := abs(p.x * u.x + p.y * u.y);
    1175           a2  := abs(p.x * u.y - p.y * u.x);
    1176           if a2 > a then a := a2;
    1177         end;
    1178     gtRadial:    a := sqrt(sqr(p.x * u.x + p.y * u.y) + sqr(p.x * u.y - p.y * u.x));
    1179   end;
    1180 
    1181   if FSinus then
    1182   begin
    1183     a := a*aFactor;
    1184     if (a <= low(int64)) or (a >= high(int64)) then
    1185       result := mergedColor
    1186     else
    1187     begin
    1188       ai := Sin65536(round(a));
    1189       result := FGradient.GetColorAt(ai);
    1190     end;
    1191   end else
    1192     result := FGradient.GetColorAtF(a*aFactorF);
     1519begin
     1520  if FIsAverage then
     1521    result := FAverageColor
     1522  else
     1523    result := GetGradientColor(FScanAtFunc(PointF(X,Y)));
    11931524end;
    11941525
    11951526function TBGRAGradientScanner.ScanAtExpanded(X, Y: Single): TExpandedPixel;
    1196 var p: TPointF;
    1197     a,a2: single;
    1198     ai: integer;
    1199 begin
    1200   if len = 0 then
    1201   begin
    1202     result := mergedExpandedColor;
    1203     exit;
    1204   end;
    1205 
    1206   p.x := X - FOrigin1.x;
    1207   p.y := Y - FOrigin1.y;
    1208   case FGradientType of
    1209     gtLinear:    a := p.x * u.x + p.y * u.y;
    1210     gtReflected: a := abs(p.x * u.x + p.y * u.y);
    1211     gtDiamond:
    1212         begin
    1213           a   := abs(p.x * u.x + p.y * u.y);
    1214           a2  := abs(p.x * u.y - p.y * u.x);
    1215           if a2 > a then a := a2;
    1216         end;
    1217     gtRadial:    a := sqrt(sqr(p.x * u.x + p.y * u.y) + sqr(p.x * u.y - p.y * u.x));
    1218   end;
    1219 
    1220   if FSinus then
    1221   begin
    1222     a := a*aFactor;
    1223     if (a <= low(int64)) or (a >= high(int64)) then
    1224       result := mergedExpandedColor
    1225     else
    1226     begin
    1227       ai := Sin65536(round(a));
    1228       result := FGradient.GetExpandedColorAt(ai);
    1229     end;
    1230   end else
    1231     result := FGradient.GetExpandedColorAtF(a*aFactorF);
     1527begin
     1528  if FIsAverage then
     1529    result := FAverageExpandedColor
     1530  else
     1531    result := GetGradientExpandedColor(FScanAtFunc(PointF(X,Y)));
    12321532end;
    12331533
     
    12361536var c: TBGRAPixel;
    12371537begin
    1238   if FVertical or (len = 0) then
    1239   begin
    1240     if FVertical then c := FHorizColor
    1241       else c := mergedColor;
     1538  if FRepeatHoriz then
     1539  begin
     1540    c := FHorizColor;
    12421541    case mode of
    12431542      dmDrawWithTransparency: DrawPixelsInline(pdest,c,count);
     
    15731872  FScanAt := @FTexture.ScanAt;
    15741873  FGlobalOpacity:= AGlobalOpacity;
     1874  FOwnedScanner := nil;
     1875end;
     1876
     1877constructor TBGRAOpacityScanner.Create(ATexture: TBGRACustomScanner;
     1878  AGlobalOpacity: Byte; AOwned: boolean);
     1879begin
     1880  FTexture := ATexture;
     1881  FScanNext := @FTexture.ScanNextPixel;
     1882  FScanAt := @FTexture.ScanAt;
     1883  FGlobalOpacity:= AGlobalOpacity;
     1884  if AOwned then
     1885    FOwnedScanner := ATexture
     1886  else
     1887    FOwnedScanner := nil;
    15751888end;
    15761889
     
    15781891begin
    15791892  fillchar(FTexture,sizeof(FTexture),0);
     1893  FOwnedScanner.Free;
    15801894  inherited Destroy;
    15811895end;
  • GraphicTest/Packages/bgrabitmap/bgragrayscalemask.pas

    r494 r521  
    3636  end;
    3737
    38 procedure DownSamplePutImageGrayscale(sourceData: PByte; sourcePixelSize: NativeInt; sourceRowDelta: NativeInt; sourceWidth, sourceHeight: NativeInt; dest: TGrayscaleMask; ADestRect: TRect);
    39 procedure DownSamplePutImageGrayscale(source: TBGRACustomBitmap; dest: TGrayscaleMask; ADestRect: TRect);
     38procedure DownSamplePutImageGrayscale(sourceData: PByte; sourcePixelSize: NativeInt; sourceRowDelta: NativeInt; sourceWidth, sourceHeight: NativeInt; dest: TGrayscaleMask; ADestRect: TRect); overload;
     39procedure DownSamplePutImageGrayscale(source: TBGRACustomBitmap; dest: TGrayscaleMask; ADestRect: TRect); overload;
    4040
    4141procedure BGRAFillClearTypeGrayscaleMask(dest: TBGRACustomBitmap; x,
  • GraphicTest/Packages/bgrabitmap/bgragtkbitmap.pas

    r494 r521  
    3838    FPixBuf: Pointer;
    3939    procedure DrawTransparent(ACanvas: TCanvas; Rect: TRect);
    40     procedure DrawOpaque(ACanvas: TCanvas; Rect: TRect);
     40    procedure DrawOpaque(ACanvas: TCanvas; ARect: TRect; ASourceRect: TRect);
     41    procedure DrawOpaque(ACanvas: TCanvas; ARect: TRect);
    4142  protected
    4243    procedure ReallocData; override;
     
    4647      AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
    4748      override;
     49    procedure DrawPart(ARect: TRect; ACanvas: TCanvas; x, y: integer; Opaque: boolean); override;
    4850    procedure Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean = True); override;
    4951    procedure Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean = True); override;
    50     procedure DataDrawOpaque(ACanvas: TCanvas; Rect: TRect; AData: Pointer;
    51       ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); override;
     52    procedure DataDrawOpaque(ACanvas: TCanvas; ARect: TRect; AData: Pointer;
     53      ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); overload; override;
     54    procedure DataDrawOpaque(ACanvas: TCanvas; ARect: TRect; ADataFirstRow: Pointer;
     55      ARowStride: integer; AWidth, AHeight: integer); overload;
    5256    procedure GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer); override;
    5357  end;
     
    5559implementation
    5660
    57 uses BGRABitmapTypes, BGRADefaultBitmap, LCLType,
     61uses BGRABitmapTypes, BGRADefaultBitmap, BGRAFilterScanner, LCLType,
    5862  LCLIntf, IntfGraphics,
    5963  {$IFDEF LCLgtk2}
     
    6468  {$ENDIF}
    6569  FPImage, Dialogs;
    66 
    67 {$IFDEF LCLgtk2}
    68 type TGtkDeviceContext = TGtk2DeviceContext;
    69 {$ENDIF}
    7070
    7171procedure TBGRAGtkBitmap.ReallocData;
     
    116116  end;
    117117
     118  LoadFromBitmapIfNeeded;
     119
    118120  If not TBGRAPixel_RGBAOrder then SwapRedBlue;
    119121 
     
    130132end;
    131133
    132 procedure TBGRAGtkBitmap.DrawOpaque(ACanvas: TCanvas; Rect: TRect);
    133 begin
    134   DataDrawOpaque(ACanvas,Rect,Data,LineOrder,Width,Height);
     134procedure TBGRAGtkBitmap.DrawOpaque(ACanvas: TCanvas; ARect: TRect;
     135  ASourceRect: TRect);
     136begin
     137  DataDrawOpaque(ACanvas,ARect,Data,LineOrder,Width,Height);
     138end;
     139
     140procedure TBGRAGtkBitmap.DrawOpaque(ACanvas: TCanvas; ARect: TRect);
     141begin
     142  DrawOpaque(ACanvas, ARect, rect(0,0,Width,Height));
    135143end;
    136144
     
    166174end;
    167175
     176procedure TBGRAGtkBitmap.DrawPart(ARect: TRect; ACanvas: TCanvas; x,
     177  y: integer; Opaque: boolean);
     178var
     179  rowStride,w,h: Integer;
     180begin
     181  if Opaque then
     182  begin
     183    if LineOrder = riloTopToBottom then
     184      rowStride := Width*sizeof(TBGRAPixel)
     185    else
     186      rowStride := -Width*sizeof(TBGRAPixel);
     187    w:= ARect.Right-ARect.Left;
     188    h:= ARect.Bottom-ARect.Top;
     189    DataDrawOpaque(ACanvas, rect(x,y,x+w,y+h), Scanline[ARect.Top]+ARect.Left, rowStride, w,h);
     190  end
     191  else
     192    inherited DrawPart(ARect, ACanvas, x, y, Opaque);
     193end;
     194
    168195procedure TBGRAGtkBitmap.Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean);
    169196begin
     
    186213end;
    187214
    188 procedure TBGRAGtkBitmap.DataDrawOpaque(ACanvas: TCanvas; Rect: TRect;
     215procedure TBGRAGtkBitmap.DataDrawOpaque(ACanvas: TCanvas; ARect: TRect;
    189216  AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
    190 var ptr: TBGRAPtrBitmap;
     217var
     218  rowStride: Integer;
     219  firstRow: Pointer;
     220begin
     221  if ALineOrder = riloTopToBottom then
     222  begin
     223    rowStride := AWidth*sizeof(TBGRAPixel);
     224    firstRow := AData;
     225  end
     226  else
     227  begin
     228    rowStride := -AWidth*sizeof(TBGRAPixel);
     229    firstRow := PBGRAPixel(AData) + (AWidth*(AHeight-1));
     230  end;
     231
     232  DataDrawOpaque(ACanvas, ARect, firstRow, rowStride, AWidth, AHeight);
     233end;
     234
     235procedure TBGRAGtkBitmap.DataDrawOpaque(ACanvas: TCanvas; ARect: TRect;
     236  ADataFirstRow: Pointer; ARowStride: integer; AWidth, AHeight: integer);
     237
     238  procedure DataSwapRedBlue;
     239  var
     240    y: Integer;
     241    p: PByte;
     242  begin
     243    p := PByte(ADataFirstRow);
     244    for y := 0 to AHeight-1 do
     245    begin
     246      TBGRAFilterScannerSwapRedBlue.ComputeFilterAt(PBGRAPixel(p),PBGRAPixel(p),AWidth,False);
     247      inc(p, ARowStride);
     248    end;
     249  end;
     250
     251  procedure DrawStretched;
     252  var
     253    dataStart: Pointer;
     254    ptr: TBGRAPtrBitmap;
    191255    stretched: TBGRACustomBitmap;
    192     temp: integer;
    193     pos: TPoint;
    194     dest: HDC;
    195 begin
    196   if (AHeight = 0) or (AWidth = 0) or (Rect.Left = Rect.Right) or
    197     (Rect.Top = Rect.Bottom) then
    198     exit;
    199 
    200   if Rect.Right < Rect.Left then
    201   begin
    202     temp := Rect.Left;
    203     Rect.Left := Rect.Right;
    204     Rect.Right := temp;
    205   end;
    206 
    207   if Rect.Bottom < Rect.Top then
    208   begin
    209     temp := Rect.Top;
    210     Rect.Top := Rect.Bottom;
    211     Rect.Bottom := temp;
    212   end;
    213 
    214   if (AWidth <> Rect.Right-Rect.Left) or (AHeight <> Rect.Bottom-Rect.Top) then
    215   begin
    216     ptr := TBGRAPtrBitmap.Create(AWidth,AHeight,AData);
    217     ptr.LineOrder := ALineOrder;
    218     stretched := ptr.Resample(Rect.Right-Rect.Left,Rect.Bottom-Rect.Top);
     256  begin
     257    if ARowStride < 0 then
     258      dataStart := PByte(ADataFirstRow) + ARowStride*(Height-1)
     259    else
     260      dataStart := ADataFirstRow;
     261
     262    if ARowStride <> abs(AWidth*sizeof(TBGRAPixel)) then
     263      raise exception.Create('DataDrawOpaque not supported when using custom row stride and resample');
     264
     265    ptr := TBGRAPtrBitmap.Create(AWidth,AHeight,dataStart);
     266    if ARowStride < 0 then
     267      ptr.LineOrder := riloBottomToTop
     268    else
     269      ptr.LineOrder := riloTopToBottom;
     270    stretched := ptr.Resample(ARect.Right-ARect.Left,ARect.Bottom-ARect.Top);
    219271    ptr.free;
    220     DataDrawOpaque(ACanvas,Rect,AData,stretched.LineOrder,stretched.Width,stretched.Height);
     272    DataDrawOpaque(ACanvas,ARect,stretched.Data,stretched.LineOrder,stretched.Width,stretched.Height);
    221273    stretched.Free;
    222     exit;
    223   end;
    224 
    225   dest := ACanvas.Handle;
    226   pos := rect.TopLeft;
    227   LPtoDP(dest, pos, 1);
    228   If ALineOrder = riloBottomToTop then VerticalFlip;
    229   If not TBGRAPixel_RGBAOrder then SwapRedBlue;
    230   gdk_draw_rgb_32_image(TGtkDeviceContext(dest).Drawable,
    231     TGtkDeviceContext(Dest).GC, pos.x,pos.y,
    232     AWidth,AHeight, GDK_RGB_DITHER_NORMAL,
    233     AData, AWidth*sizeof(TBGRAPixel));
    234   If not TBGRAPixel_RGBAOrder then SwapRedBlue;
    235   If ALineOrder = riloBottomToTop then VerticalFlip;
     274  end;
     275
     276var
     277  temp: integer;
     278  pos: TPoint;
     279  dest: HDC;
     280
     281begin
     282  if (AHeight = 0) or (AWidth = 0) or (ARect.Left = ARect.Right) or
     283    (ARect.Top = ARect.Bottom) then exit;
     284
     285  if ARect.Right < ARect.Left then
     286  begin
     287    temp := ARect.Left;
     288    ARect.Left := ARect.Right;
     289    ARect.Right := temp;
     290  end;
     291
     292  if ARect.Bottom < ARect.Top then
     293  begin
     294    temp := ARect.Top;
     295    ARect.Top := ARect.Bottom;
     296    ARect.Bottom := temp;
     297  end;
     298
     299  if (AWidth <> ARect.Right-ARect.Left) or (AHeight <> ARect.Bottom-ARect.Top) then
     300    DrawStretched
     301  else
     302  begin
     303    dest := ACanvas.Handle;
     304    pos := ARect.TopLeft;
     305    LPtoDP(dest, pos, 1);
     306    if not TBGRAPixel_RGBAOrder then DataSwapRedBlue;
     307    gdk_draw_rgb_32_image(TGtkDeviceContext(dest).Drawable,
     308      TGtkDeviceContext(Dest).GC, pos.x,pos.y,
     309      AWidth,AHeight, GDK_RGB_DITHER_NORMAL,
     310      ADataFirstRow, ARowStride);
     311    if not TBGRAPixel_RGBAOrder then DataSwapRedBlue;
     312    ACanvas.Changed;
     313  end;
    236314end;
    237315
  • GraphicTest/Packages/bgrabitmap/bgralayers.pas

    r494 r521  
    22
    33{$mode objfpc}{$H+}
     4{$MODESWITCH ADVANCEDRECORDS}
    45
    56interface
    67
    78uses
    8   BGRAGraphics, Classes, SysUtils, Types, BGRABitmapTypes, BGRABitmap;
     9  BGRAGraphics, Classes, SysUtils, Types, BGRABitmapTypes, BGRABitmap,
     10  BGRAMemDirectory, BGRATransform, fgl, BGRALayerOriginal;
    911
    1012type
     
    1214  TBGRACustomLayeredBitmapClass = class of TBGRACustomLayeredBitmap;
    1315
     16  { TBGRALayerOriginalEntry }
     17
     18  TBGRALayerOriginalEntry = record
     19     Guid: TGuid;
     20     Instance: TBGRALayerCustomOriginal;
     21     class operator = (const AEntry1,AEntry2: TBGRALayerOriginalEntry): boolean;
     22  end;
     23
     24function BGRALayerOriginalEntry(AGuid: TGuid): TBGRALayerOriginalEntry;
     25function BGRALayerOriginalEntry(AInstance: TBGRALayerCustomOriginal): TBGRALayerOriginalEntry;
     26
     27type
     28  TBGRALayerOriginalList = specialize TFPGList<TBGRALayerOriginalEntry>;
     29
    1430  TBGRALayeredBitmap = class;
    1531  TBGRALayeredBitmapClass = class of TBGRALayeredBitmap;
    1632
    1733  TBGRALayeredBitmapSaveToStreamProc = procedure(AStream: TStream; ALayers: TBGRACustomLayeredBitmap);
    18   TBGRALayeredBitmapLoadFromStreamProc = function(AStream: TStream): TBGRALayeredBitmap;
     34  TBGRALayeredBitmapLoadFromStreamProc = procedure(AStream: TStream; ALayers: TBGRACustomLayeredBitmap);
     35  TBGRALayeredBitmapCheckStreamProc = function(AStream: TStream): boolean;
     36  TOriginalRenderStatus = (orsNone, orsDraft, orsPartialDraft, orsProof, orsPartialProof);
    1937
    2038  { TBGRACustomLayeredBitmap }
     
    2846    end;
    2947    FLinearBlend: boolean;
     48    FMemDirectory: TMemDirectory;
     49    FMemDirectoryOwned: boolean;
    3050    function GetDefaultBlendingOperation: TBlendOperation;
     51    function GetHasMemFiles: boolean;
    3152    function GetLinearBlend: boolean;
    3253    procedure SetLinearBlend(AValue: boolean);
     
    3455  protected
    3556    function GetNbLayers: integer; virtual; abstract;
     57    function GetMemDirectory: TMemDirectory;
    3658    function GetBlendOperation(Layer: integer): TBlendOperation; virtual; abstract;
    3759    function GetLayerVisible(layer: integer): boolean; virtual; abstract;
     
    4264    function GetLayerFrozen(layer: integer): boolean; virtual;
    4365    function GetLayerUniqueId(layer: integer): integer; virtual;
     66    function GetLayerOriginal({%H-}layer: integer): TBGRALayerCustomOriginal; virtual;
     67    function GetLayerOriginalKnown({%H-}layer: integer): boolean; virtual;
     68    function GetLayerOriginalMatrix({%H-}layer: integer): TAffineMatrix; virtual;
     69    function GetLayerOriginalGuid({%H-}layer: integer): TGuid; virtual;
     70    function GetLayerOriginalRenderStatus({%H-}layer: integer): TOriginalRenderStatus; virtual;
     71    function GetOriginalCount: integer; virtual;
     72    function GetOriginalByIndex({%H-}AIndex: integer): TBGRALayerCustomOriginal; virtual;
     73    function GetOriginalByIndexKnown({%H-}AIndex: integer): boolean; virtual;
     74    function GetTransparent: Boolean; override;
     75    function GetEmpty: boolean; override;
     76
     77    function IndexOfOriginal(AGuid: TGuid): integer; overload; virtual;
     78    function IndexOfOriginal(AOriginal: TBGRALayerCustomOriginal): integer; overload; virtual;
     79
     80    procedure SetWidth(Value: Integer); override;
     81    procedure SetHeight(Value: Integer); override;
     82    procedure SetMemDirectory(AValue: TMemDirectory);
     83    procedure SetTransparent(Value: Boolean); override;
     84
    4485    procedure SetLayerFrozen(layer: integer; AValue: boolean); virtual;
    4586    function RangeIntersect(first1,last1,first2,last2: integer): boolean;
    4687    procedure RemoveFrozenRange(index: integer);
    4788    function ContainsFrozenRange(first,last: integer): boolean;
    48     function GetEmpty: boolean; override;
    49     procedure SetWidth(Value: Integer); override;
    50     procedure SetHeight(Value: Integer); override;
    51     function GetTransparent: Boolean; override;
    52     procedure SetTransparent(Value: Boolean); override;
    5389
    5490  public
    5591    procedure SaveToFile(const filenameUTF8: string); override;
    5692    procedure SaveToStream(Stream: TStream); override;
     93    procedure SaveToStreamAs(Stream: TStream; AExtension: string);
    5794    constructor Create; override;
    5895    destructor Destroy; override;
     
    6097    function GetLayerBitmapDirectly(layer: integer): TBGRABitmap; virtual;
    6198    function GetLayerBitmapCopy(layer: integer): TBGRABitmap; virtual; abstract;
    62     function ComputeFlatImage: TBGRABitmap; overload;
    63     function ComputeFlatImage(firstLayer, lastLayer: integer): TBGRABitmap; overload;
    64     function ComputeFlatImage(ARect: TRect): TBGRABitmap; overload;
    65     function ComputeFlatImage(ARect: TRect; firstLayer, lastLayer: integer): TBGRABitmap; overload;
     99    function ComputeFlatImage(ASeparateXorMask: boolean = false): TBGRABitmap; overload;
     100    function ComputeFlatImage(firstLayer, lastLayer: integer; ASeparateXorMask: boolean = false): TBGRABitmap; overload;
     101    function ComputeFlatImage(ARect: TRect; ASeparateXorMask: boolean = false): TBGRABitmap; overload;
     102    function ComputeFlatImage(ARect: TRect; firstLayer, lastLayer: integer; ASeparateXorMask: boolean = false): TBGRABitmap; overload;
    66103    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override; overload;
    67104    procedure Draw(Canvas: TCanvas; x,y: integer); overload;
    68105    procedure Draw(Canvas: TCanvas; x,y: integer; firstLayer, lastLayer: integer); overload;
    69106    procedure Draw(Dest: TBGRABitmap; x,y: integer); overload;
    70     procedure Draw(Dest: TBGRABitmap; AX,AY: integer; firstLayer, lastLayer: integer); overload;
     107    procedure Draw(Dest: TBGRABitmap; x,y: integer; ASeparateXorMask: boolean); overload;
     108    procedure Draw(Dest: TBGRABitmap; AX,AY: integer; firstLayer, lastLayer: integer; ASeparateXorMask: boolean = false); overload;
    71109
    72110    procedure FreezeExceptOneLayer(layer: integer); overload;
     
    76114    procedure Unfreeze(layer: integer); overload;
    77115    procedure Unfreeze(firstLayer, lastLayer: integer); overload;
     116
     117    procedure NotifyLoaded; virtual;
     118    procedure NotifySaving; virtual;
    78119
    79120    property NbLayers: integer read GetNbLayers;
     
    85126    property LayerFrozen[layer: integer]: boolean read GetLayerFrozen;
    86127    property LayerUniqueId[layer: integer]: integer read GetLayerUniqueId;
     128    property LayerOriginal[layer: integer]: TBGRALayerCustomOriginal read GetLayerOriginal;
     129    property LayerOriginalKnown[layer: integer]: boolean read GetLayerOriginalKnown;
     130    property LayerOriginalGuid[layer: integer]: TGuid read GetLayerOriginalGuid;
     131    property LayerOriginalMatrix[layer: integer]: TAffineMatrix read GetLayerOriginalMatrix;
     132    property LayerOriginalRenderStatus[layer: integer]: TOriginalRenderStatus read GetLayerOriginalRenderStatus;
    87133    property LinearBlend: boolean read GetLinearBlend write SetLinearBlend; //use linear blending unless specified
    88134    property DefaultBlendingOperation: TBlendOperation read GetDefaultBlendingOperation;
    89   end;
     135    property MemDirectory: TMemDirectory read GetMemDirectory write SetMemDirectory;
     136    property MemDirectoryOwned: boolean read FMemDirectoryOwned write FMemDirectoryOwned;
     137    property HasMemFiles: boolean read GetHasMemFiles;
     138  end;
     139
     140  TEmbeddedOriginalChangeEvent = procedure (ASender: TObject; AOriginal: TBGRALayerCustomOriginal) of object;
     141  TEmbeddedOriginalEditingChangeEvent = procedure (ASender: TObject; AOriginal: TBGRALayerCustomOriginal) of object;
    90142
    91143  TBGRALayerInfo = record
     
    99151    Owner: boolean;
    100152    Frozen: boolean;
     153    OriginalMatrix: TAffineMatrix;
     154    OriginalRenderStatus: TOriginalRenderStatus;
     155    OriginalGuid: TGuid;
     156    OriginalInvalidatedBounds: TRectF;
    101157  end;
    102158
     
    107163    FNbLayers: integer;
    108164    FLayers: array of TBGRALayerInfo;
     165    FOriginalChange: TEmbeddedOriginalChangeEvent;
     166    FOriginalEditingChange: TEmbeddedOriginalEditingChangeEvent;
    109167    FWidth,FHeight: integer;
     168    FOriginals: TBGRALayerOriginalList;
     169    FOriginalEditor: TBGRAOriginalEditor;
     170    FOriginalEditorOriginal: TBGRALayerCustomOriginal;
     171    FOriginalEditorViewMatrix: TAffineMatrix;
     172    function GetOriginalGuid(AIndex: integer): TGUID;
    110173
    111174  protected
     
    119182    function GetLayerName(layer: integer): string; override;
    120183    function GetLayerFrozen(layer: integer): boolean; override;
     184    function GetLayerUniqueId(layer: integer): integer; override;
     185    function GetLayerOriginal(layer: integer): TBGRALayerCustomOriginal; override;
     186    function GetLayerOriginalKnown(layer: integer): boolean; override;
     187    function GetLayerOriginalMatrix(layer: integer): TAffineMatrix; override;
     188    function GetLayerOriginalGuid(layer: integer): TGuid; override;
     189    function GetLayerOriginalRenderStatus(layer: integer): TOriginalRenderStatus; override;
     190    function GetOriginalCount: integer; override;
     191    function GetOriginalByIndex(AIndex: integer): TBGRALayerCustomOriginal; override;
     192    function GetOriginalByIndexKnown(AIndex: integer): boolean; override;
    121193    procedure SetBlendOperation(Layer: integer; op: TBlendOperation);
    122194    procedure SetLayerVisible(layer: integer; AValue: boolean);
     
    125197    procedure SetLayerName(layer: integer; AValue: string);
    126198    procedure SetLayerFrozen(layer: integer; AValue: boolean); override;
    127     function GetLayerUniqueId(layer: integer): integer; override;
    128199    procedure SetLayerUniqueId(layer: integer; AValue: integer);
     200    procedure SetLayerOriginalMatrix(layer: integer; AValue: TAffineMatrix);
     201    procedure SetLayerOriginalGuid(layer: integer; const AValue: TGuid);
     202    procedure SetLayerOriginalRenderStatus(layer: integer; AValue: TOriginalRenderStatus);
     203
     204    procedure FindOriginal(AGuid: TGuid;
     205                out ADir: TMemDirectory;
     206                out AClass: TBGRALayerOriginalAny);
     207    procedure StoreOriginal(AOriginal: TBGRALayerCustomOriginal);
     208    procedure OriginalChange(ASender: TObject; ABounds: PRectF = nil);
     209    procedure OriginalEditingChange(ASender: TObject);
    129210
    130211  public
    131212    procedure LoadFromFile(const filenameUTF8: string); override;
    132213    procedure LoadFromStream(stream: TStream); override;
     214    procedure LoadFromResource(AFilename: string);
    133215    procedure SetSize(AWidth, AHeight: integer); virtual;
    134216    procedure Clear; override;
     217    procedure ClearOriginals;
    135218    procedure RemoveLayer(index: integer);
    136219    procedure InsertLayer(index: integer; fromIndex: integer);
     
    138221    function MoveLayerUp(index: integer): integer;
    139222    function MoveLayerDown(index: integer): integer;
     223
    140224    function AddLayer(Source: TBGRABitmap; Opacity: byte = 255): integer; overload;
    141225    function AddLayer(Source: TBGRABitmap; Position: TPoint; BlendOp: TBlendOperation; Opacity: byte = 255; Shared: boolean = false): integer; overload;
     
    158242    function AddOwnedLayer(ABitmap: TBGRABitmap; Position: TPoint; Opacity: byte = 255): integer; overload;
    159243    function AddOwnedLayer(ABitmap: TBGRABitmap; BlendOp: TBlendOperation; Opacity: byte = 255): integer; overload;
     244    function AddLayerFromOriginal(AGuid: TGuid; Opacity: byte = 255): integer; overload;
     245    function AddLayerFromOriginal(AGuid: TGuid; BlendOp: TBlendOperation; Opacity: byte = 255): integer; overload;
     246    function AddLayerFromOriginal(AGuid: TGuid; Matrix: TAffineMatrix; Opacity: byte = 255): integer; overload;
     247    function AddLayerFromOriginal(AGuid: TGuid; Matrix: TAffineMatrix; BlendOp: TBlendOperation; Opacity: byte = 255): integer; overload;
     248    function AddLayerFromOwnedOriginal(AOriginal: TBGRALayerCustomOriginal; Opacity: byte = 255): integer; overload;
     249    function AddLayerFromOwnedOriginal(AOriginal: TBGRALayerCustomOriginal; BlendOp: TBlendOperation; Opacity: byte = 255): integer; overload;
     250    function AddLayerFromOwnedOriginal(AOriginal: TBGRALayerCustomOriginal; Matrix: TAffineMatrix; Opacity: byte = 255): integer; overload;
     251    function AddLayerFromOwnedOriginal(AOriginal: TBGRALayerCustomOriginal; Matrix: TAffineMatrix; BlendOp: TBlendOperation; Opacity: byte = 255): integer; overload;
     252
     253    function AddOriginal(AOriginal: TBGRALayerCustomOriginal; AOwned: boolean = true): integer;
     254    function AddOriginalFromStream(AStream: TStream; ALateLoad: boolean = false): integer;
     255    function AddOriginalFromStorage(AStorage: TBGRAMemOriginalStorage; ALateLoad: boolean = false): integer;
     256    procedure SaveOriginalToStream(AIndex: integer; AStream: TStream); overload;
     257    procedure SaveOriginalToStream(AGuid: TGUID; AStream: TStream); overload;
     258    function RemoveOriginal(AOriginal: TBGRALayerCustomOriginal): boolean;
     259    procedure DeleteOriginal(AIndex: integer);
     260    procedure NotifyLoaded; override;
     261    procedure NotifySaving; override;
     262    procedure RenderLayerFromOriginal(layer: integer; ADraft: boolean = false; AFullSizeLayer: boolean = false); overload;
     263    procedure RenderLayerFromOriginal(layer: integer; ADraft: boolean; ARenderBounds: TRect; AFullSizeLayer: boolean = false); overload;
     264    procedure RenderLayerFromOriginal(layer: integer; ADraft: boolean; ARenderBoundsF: TRectF; AFullSizeLayer: boolean = false); overload;
     265    function RenderOriginalsIfNecessary(ADraft: boolean = false): TRect;
     266    procedure RemoveUnusedOriginals;
     267
    160268    destructor Destroy; override;
    161     constructor Create; override; overload;
    162     constructor Create(AWidth, AHeight: integer); virtual; overload;
     269    constructor Create; overload; override;
     270    constructor Create(AWidth, AHeight: integer); overload; virtual;
    163271    function GetLayerBitmapDirectly(layer: integer): TBGRABitmap; override;
    164272    function GetLayerBitmapCopy(layer: integer): TBGRABitmap; override;
     
    169277    procedure RotateCW;
    170278    procedure RotateCCW;
    171     procedure HorizontalFlip;
    172     procedure VerticalFlip;
     279    procedure HorizontalFlip; overload;
     280    procedure HorizontalFlip(ALayerIndex: integer); overload;
     281    procedure VerticalFlip; overload;
     282    procedure VerticalFlip(ALayerIndex: integer); overload;
    173283    procedure Resample(AWidth, AHeight: integer; AResampleMode: TResampleMode; AFineResampleFilter: TResampleFilter = rfLinear);
    174284    procedure SetLayerBitmap(layer: integer; ABitmap: TBGRABitmap; AOwned: boolean);
     285    procedure ApplyLayerOffset(ALayerIndex: integer; APadWithTranparentPixels: boolean);
     286
     287    function DrawEditor(ADest: TBGRABitmap; ALayerIndex: integer; X, Y: Integer; APointSize: single): TRect; overload;
     288    function DrawEditor(ADest: TBGRABitmap; ALayerIndex: integer; AMatrix: TAffineMatrix; APointSize: single): TRect; overload;
     289    function GetEditorBounds(ALayerIndex: integer; X, Y: Integer; APointSize: single): TRect; overload;
     290    function GetEditorBounds(ADestRect: TRect; ALayerIndex: integer; X, Y: Integer; APointSize: single): TRect; overload;
     291    function GetEditorBounds(ALayerIndex: integer; AMatrix: TAffineMatrix; APointSize: single): TRect; overload;
     292    function GetEditorBounds(ADestRect: TRect; ALayerIndex: integer; AMatrix: TAffineMatrix; APointSize: single): TRect; overload;
     293    procedure MouseMove(Shift: TShiftState; ImageX, ImageY: Single; out ACursor: TOriginalEditorCursor);
     294    procedure MouseDown(RightButton: boolean; Shift: TShiftState; ImageX, ImageY: Single; out ACursor: TOriginalEditorCursor);
     295    procedure MouseUp(RightButton: boolean; Shift: TShiftState; ImageX, ImageY: Single; out ACursor: TOriginalEditorCursor);
     296    procedure MouseMove(Shift: TShiftState; ImageX, ImageY: Single; out ACursor: TOriginalEditorCursor; out AHandled: boolean);
     297    procedure MouseDown(RightButton: boolean; Shift: TShiftState; ImageX, ImageY: Single; out ACursor: TOriginalEditorCursor; out AHandled: boolean);
     298    procedure MouseUp(RightButton: boolean; Shift: TShiftState; ImageX, ImageY: Single; out ACursor: TOriginalEditorCursor; out AHandled: boolean);
     299    procedure KeyDown(Shift: TShiftState; Key: TSpecialKey; out AHandled: boolean);
     300    procedure KeyUp(Shift: TShiftState; Key: TSpecialKey; out AHandled: boolean);
     301    procedure KeyPress(UTF8Key: string; out AHandled: boolean);
    175302
    176303    property Width : integer read GetWidth;
     
    184311    property LayerOffset[layer: integer]: TPoint read GetLayerOffset write SetLayerOffset;
    185312    property LayerUniqueId[layer: integer]: integer read GetLayerUniqueId write SetLayerUniqueId;
    186   end;
     313    property LayerOriginal[layer: integer]: TBGRALayerCustomOriginal read GetLayerOriginal;
     314    property LayerOriginalKnown[layer: integer]: boolean read GetLayerOriginalKnown;
     315    property LayerOriginalGuid[layer: integer]: TGuid read GetLayerOriginalGuid write SetLayerOriginalGuid;
     316    property LayerOriginalMatrix[layer: integer]: TAffineMatrix read GetLayerOriginalMatrix write SetLayerOriginalMatrix;
     317    property LayerOriginalRenderStatus[layer: integer]: TOriginalRenderStatus read GetLayerOriginalRenderStatus write SetLayerOriginalRenderStatus;
     318
     319    function IndexOfOriginal(AGuid: TGuid): integer; overload; override;
     320    function IndexOfOriginal(AOriginal: TBGRALayerCustomOriginal): integer; overload; override;
     321    property OriginalCount: integer read GetOriginalCount;
     322    property Original[AIndex: integer]: TBGRALayerCustomOriginal read GetOriginalByIndex;
     323    property OriginalGuid[AIndex: integer]: TGUID read GetOriginalGuid;
     324    property OriginalKnown[AIndex: integer]: boolean read GetOriginalByIndexKnown;
     325    property OnOriginalChange: TEmbeddedOriginalChangeEvent read FOriginalChange write FOriginalChange;
     326    property OnOriginalEditingChange: TEmbeddedOriginalEditingChangeEvent read FOriginalEditingChange write FOriginalEditingChange;
     327    property OriginalEditor: TBGRAOriginalEditor read FOriginalEditor;
     328  end;
     329
     330  TAffineMatrix = BGRABitmapTypes.TAffineMatrix;
    187331
    188332procedure RegisterLayeredBitmapWriter(AExtensionUTF8: string; AWriter: TBGRALayeredBitmapClass);
    189333procedure RegisterLayeredBitmapReader(AExtensionUTF8: string; AReader: TBGRACustomLayeredBitmapClass);
     334function TryCreateLayeredBitmapWriter(AExtensionUTF8: string): TBGRALayeredBitmap;
     335function TryCreateLayeredBitmapReader(AExtensionUTF8: string): TBGRACustomLayeredBitmap;
    190336
    191337var
    192338  LayeredBitmapSaveToStreamProc : TBGRALayeredBitmapSaveToStreamProc;
    193339  LayeredBitmapLoadFromStreamProc : TBGRALayeredBitmapLoadFromStreamProc;
     340  LayeredBitmapCheckStreamProc: TBGRALayeredBitmapCheckStreamProc;
    194341
    195342type
     
    209356implementation
    210357
    211 uses BGRAUTF8;
     358uses BGRAUTF8, BGRABlend, BGRAMultiFileType, math;
     359
     360const
     361  OriginalsDirectory = 'originals';
    212362
    213363var
     
    227377  end;
    228378
     379{ TBGRALayerOriginalEntry }
     380
     381class operator TBGRALayerOriginalEntry.=(const AEntry1,
     382  AEntry2: TBGRALayerOriginalEntry): boolean;
     383begin
     384  result := AEntry1.Guid = AEntry2.Guid;
     385end;
     386
     387function BGRALayerOriginalEntry(AGuid: TGuid): TBGRALayerOriginalEntry;
     388begin
     389  result.Guid := AGuid;
     390  result.Instance := nil;
     391end;
     392
     393function BGRALayerOriginalEntry(AInstance: TBGRALayerCustomOriginal): TBGRALayerOriginalEntry;
     394begin
     395  result.Guid := AInstance.Guid;
     396  result.Instance := AInstance;
     397end;
     398
    229399{ TBGRALayeredBitmap }
    230400
     
    237407end;
    238408
     409function TBGRALayeredBitmap.GetLayerOriginal(layer: integer): TBGRALayerCustomOriginal;
     410var
     411  idxOrig: Integer;
     412begin
     413  if (layer < 0) or (layer >= NbLayers) then
     414    raise Exception.Create('Index out of bounds')
     415  else
     416  begin
     417    if FLayers[layer].OriginalGuid = GUID_NULL then exit(nil);
     418    idxOrig := IndexOfOriginal(FLayers[layer].OriginalGuid);
     419    if idxOrig = -1 then exit(nil);
     420    result := Original[idxOrig];
     421  end;
     422end;
     423
     424function TBGRALayeredBitmap.GetLayerOriginalMatrix(layer: integer
     425  ): TAffineMatrix;
     426begin
     427  if (layer < 0) or (layer >= NbLayers) then
     428    raise Exception.Create('Index out of bounds')
     429  else
     430    result := FLayers[layer].OriginalMatrix;
     431end;
     432
     433function TBGRALayeredBitmap.GetLayerOriginalGuid(layer: integer): TGuid;
     434begin
     435  if (layer < 0) or (layer >= NbLayers) then
     436    raise Exception.Create('Index out of bounds')
     437  else
     438    result := FLayers[layer].OriginalGuid;
     439end;
     440
     441function TBGRALayeredBitmap.GetLayerOriginalRenderStatus(layer: integer
     442  ): TOriginalRenderStatus;
     443begin
     444  if (layer < 0) or (layer >= NbLayers) then
     445    raise Exception.Create('Index out of bounds')
     446  else
     447    result := FLayers[layer].OriginalRenderStatus;
     448end;
     449
    239450procedure TBGRALayeredBitmap.SetLayerUniqueId(layer: integer; AValue: integer);
    240451var i: integer;
     
    245456  begin
    246457    for i := 0 to NbLayers-1 do
    247       if (i <> layer) and (FLayers[layer].UniqueId = AValue) then
     458      if (i <> layer) and (FLayers[i].UniqueId = AValue) then
    248459        raise Exception.Create('Another layer has the same identifier');
    249460    FLayers[layer].UniqueId := AValue;
    250461  end;
     462end;
     463
     464procedure TBGRALayeredBitmap.SetLayerOriginalMatrix(layer: integer;
     465  AValue: TAffineMatrix);
     466begin
     467  if (layer < 0) or (layer >= NbLayers) then
     468    raise Exception.Create('Index out of bounds')
     469  else
     470  begin
     471    if FLayers[layer].OriginalMatrix = AValue then exit;
     472    FLayers[layer].OriginalMatrix := AValue;
     473    if FLayers[layer].OriginalGuid <> GUID_NULL then
     474    begin
     475      FLayers[layer].OriginalRenderStatus := orsNone;
     476      Unfreeze(layer);
     477    end;
     478  end;
     479end;
     480
     481procedure TBGRALayeredBitmap.SetLayerOriginalGuid(layer: integer;
     482  const AValue: TGuid);
     483begin
     484  if (layer < 0) or (layer >= NbLayers) then
     485    raise Exception.Create('Index out of bounds')
     486  else
     487  begin
     488    if FLayers[layer].OriginalGuid = AValue then exit;
     489    FLayers[layer].OriginalGuid := AValue;
     490
     491    if (AValue <> GUID_NULL) and (IndexOfOriginal(AValue) <> -1) then
     492    begin
     493      FLayers[layer].OriginalRenderStatus := orsNone;
     494      Unfreeze(layer);
     495    end;
     496  end;
     497end;
     498
     499procedure TBGRALayeredBitmap.SetLayerOriginalRenderStatus(layer: integer;
     500  AValue: TOriginalRenderStatus);
     501begin
     502  if (layer < 0) or (layer >= NbLayers) then
     503    raise Exception.Create('Index out of bounds')
     504  else
     505  begin
     506    if FLayers[layer].OriginalRenderStatus = AValue then exit;
     507    FLayers[layer].OriginalRenderStatus := AValue;
     508    Unfreeze(layer);
     509  end;
     510end;
     511
     512procedure TBGRALayeredBitmap.FindOriginal(AGuid: TGuid; out
     513  ADir: TMemDirectory; out AClass: TBGRALayerOriginalAny);
     514var
     515  c: String;
     516begin
     517  ADir := nil;
     518  AClass := nil;
     519
     520  if HasMemFiles then
     521  begin
     522    ADir := MemDirectory.FindPath(OriginalsDirectory+'/'+GUIDToString(AGuid));
     523    if ADir <> nil then
     524    begin
     525      c := ADir.RawStringByFilename['class'];
     526      AClass := FindLayerOriginalClass(c);
     527    end;
     528  end;
     529end;
     530
     531procedure TBGRALayeredBitmap.StoreOriginal(AOriginal: TBGRALayerCustomOriginal);
     532var
     533  dir, subdir: TMemDirectory;
     534  storage: TBGRAMemOriginalStorage;
     535begin
     536  if AOriginal.Guid = GUID_NULL then raise exception.Create('Original GUID undefined');
     537  dir := MemDirectory.Directory[MemDirectory.AddDirectory(OriginalsDirectory)];
     538  subdir := dir.Directory[dir.AddDirectory(GUIDToString(AOriginal.Guid))];
     539  storage := TBGRAMemOriginalStorage.Create(subdir);
     540  try
     541    AOriginal.SaveToStorage(storage);
     542    storage.RawString['class'] := AOriginal.StorageClassName;
     543  finally
     544    storage.Free;
     545  end;
     546end;
     547
     548procedure TBGRALayeredBitmap.OriginalChange(ASender: TObject; ABounds: PRectF);
     549var
     550  i: Integer;
     551  orig: TBGRALayerCustomOriginal;
     552  transfBounds: TRectF;
     553begin
     554  orig := TBGRALayerCustomOriginal(ASender);
     555  if not (Assigned(ABounds) and IsEmptyRectF(ABounds^)) then
     556  begin
     557    for i := 0 to NbLayers-1 do
     558      if LayerOriginalGuid[i] = orig.Guid then
     559      begin
     560        if ABounds = nil then
     561          LayerOriginalRenderStatus[i] := orsNone
     562        else
     563        begin
     564          transfBounds := (LayerOriginalMatrix[i]*TAffineBox.AffineBox(ABounds^)).RectBoundsF;
     565          case LayerOriginalRenderStatus[i] of
     566          orsDraft: begin
     567                      LayerOriginalRenderStatus[i] := orsPartialDraft;
     568                      FLayers[i].OriginalInvalidatedBounds := transfBounds;
     569                    end;
     570          orsProof: begin
     571                      LayerOriginalRenderStatus[i] := orsPartialProof;
     572                      FLayers[i].OriginalInvalidatedBounds := transfBounds;
     573                    end;
     574          orsPartialDraft: FLayers[i].OriginalInvalidatedBounds :=
     575                             FLayers[i].OriginalInvalidatedBounds.Union(transfBounds, true);
     576          orsPartialProof: FLayers[i].OriginalInvalidatedBounds :=
     577                             FLayers[i].OriginalInvalidatedBounds.Union(transfBounds, true);
     578          end;
     579        end;
     580      end;
     581  end;
     582  if Assigned(FOriginalChange) then
     583    FOriginalChange(self, orig);
     584end;
     585
     586procedure TBGRALayeredBitmap.OriginalEditingChange(ASender: TObject);
     587var
     588  orig: TBGRALayerCustomOriginal;
     589begin
     590  orig := TBGRALayerCustomOriginal(ASender);
     591  if Assigned(FOriginalEditingChange) then
     592    FOriginalEditingChange(self, orig);
     593end;
     594
     595function TBGRALayeredBitmap.GetOriginalCount: integer;
     596begin
     597  if Assigned(FOriginals) then
     598    result := FOriginals.Count
     599  else
     600    result := 0;
     601end;
     602
     603function TBGRALayeredBitmap.GetOriginalByIndex(AIndex: integer
     604  ): TBGRALayerCustomOriginal;
     605var
     606  dir: TMemDirectory;
     607  c: TBGRALayerOriginalAny;
     608  guid: TGuid;
     609  storage: TBGRAMemOriginalStorage;
     610begin
     611  if (AIndex < 0) or (AIndex >= OriginalCount) then
     612    raise ERangeError.Create('Index out of bounds');
     613
     614  result := FOriginals[AIndex].Instance;
     615  guid := FOriginals[AIndex].Guid;
     616
     617  // load original on the fly
     618  if (result = nil) and (guid <> GUID_NULL) then
     619  begin
     620    FindOriginal(guid, dir, c);
     621    if not Assigned(dir) then
     622      raise exception.Create('Original directory not found');
     623    if not Assigned(c) then
     624      raise exception.Create('Original class not found (it can be registered with the RegisterLayerOriginal function)');
     625
     626    result := c.Create;
     627    result.Guid := guid;
     628    storage := TBGRAMemOriginalStorage.Create(dir);
     629    try
     630      result.LoadFromStorage(storage);
     631    finally
     632      storage.Free;
     633    end;
     634    FOriginals[AIndex] := BGRALayerOriginalEntry(result);
     635    result.OnChange:= @OriginalChange;
     636    result.OnEditingChange:= @OriginalEditingChange;
     637  end;
     638end;
     639
     640function TBGRALayeredBitmap.GetLayerOriginalKnown(layer: integer): boolean;
     641var
     642  idxOrig: Integer;
     643begin
     644  if (layer < 0) or (layer >= NbLayers) then
     645    raise Exception.Create('Index out of bounds')
     646  else
     647  begin
     648    if FLayers[layer].OriginalGuid = GUID_NULL then exit(true);
     649    idxOrig := IndexOfOriginal(FLayers[layer].OriginalGuid);
     650    if idxOrig = -1 then exit(false);
     651    result := OriginalKnown[idxOrig];
     652  end;
     653end;
     654
     655function TBGRALayeredBitmap.GetOriginalByIndexKnown(AIndex: integer): boolean;
     656var
     657  dir: TMemDirectory;
     658  c: TBGRALayerOriginalAny;
     659  guid: TGuid;
     660begin
     661  if (AIndex < 0) or (AIndex >= OriginalCount) then
     662    raise ERangeError.Create('Index out of bounds');
     663
     664  if Assigned(FOriginals[AIndex].Instance) then exit(true);
     665  guid := FOriginals[AIndex].Guid;
     666  if guid = GUID_NULL then exit(true);
     667
     668  FindOriginal(guid, dir, c);
     669  result:= Assigned(dir) and Assigned(c);
     670end;
     671
     672function TBGRALayeredBitmap.GetOriginalGuid(AIndex: integer): TGUID;
     673begin
     674  if (AIndex < 0) or (AIndex >= OriginalCount) then
     675    raise ERangeError.Create('Index out of bounds');
     676
     677  result := FOriginals[AIndex].Guid;
    251678end;
    252679
     
    374801      (FLayers[layer].y <> AValue.y) then
    375802    begin
     803      if FLayers[layer].OriginalGuid <> GUID_NULL then
     804        raise exception.Create('The offset of the layer is computed from an original. You can change it by changing the layer original matrix.');
     805
    376806      FLayers[layer].x := AValue.x;
    377807      FLayers[layer].y := AValue.y;
     
    402832end;
    403833
    404 function TBGRALayeredBitmap.GetLayerBitmapDirectly(layer: integer
    405   ): TBGRABitmap;
     834function TBGRALayeredBitmap.GetLayerBitmapDirectly(layer: integer): TBGRABitmap;
    406835begin
    407836  if (layer < 0) or (layer >= NbLayers) then
    408837    result := nil
    409838  else
     839  begin
     840    if FLayers[layer].OriginalRenderStatus = orsNone then
     841      RenderLayerFromOriginal(layer, true)
     842    else if FLayers[layer].OriginalRenderStatus in [orsPartialDraft,orsPartialProof] then
     843      RenderLayerFromOriginal(layer, true, FLayers[layer].OriginalInvalidatedBounds);
    410844    Result:= FLayers[layer].Source;
     845  end;
    411846end;
    412847
    413848procedure TBGRALayeredBitmap.LoadFromFile(const filenameUTF8: string);
    414849var bmp: TBGRABitmap;
    415     index: integer;
    416850    ext: string;
    417851    temp: TBGRACustomLayeredBitmap;
    418852    i: integer;
     853    stream: TFileStreamUTF8;
    419854begin
    420855  ext := UTF8LowerCase(ExtractFileExt(filenameUTF8));
     
    432867    end;
    433868
    434   bmp := TBGRABitmap.Create(filenameUTF8, True);
    435   Clear;
    436   SetSize(bmp.Width,bmp.Height);
    437   index := AddSharedLayer(bmp);
    438   FLayers[index].Owner:= true;
     869  //when using "data" extension, simply deserialize
     870  if (ext='.dat') or (ext='.data') then
     871  begin
     872    if Assigned(LayeredBitmapLoadFromStreamProc) then
     873    begin
     874      stream := TFileStreamUTF8.Create(filenameUTF8, fmOpenRead, fmShareDenyWrite);
     875      try
     876        LayeredBitmapLoadFromStreamProc(stream, self);
     877      finally
     878        stream.Free;
     879      end;
     880    end else
     881      raise exception.Create('Enable layer deserialization by calling BGRAStreamLayers.RegisterStreamLayers');
     882  end else
     883  begin
     884    bmp := TBGRABitmap.Create(filenameUTF8, True);
     885    Clear;
     886    SetSize(bmp.Width,bmp.Height);
     887    AddOwnedLayer(bmp);
     888  end;
    439889end;
    440890
    441891procedure TBGRALayeredBitmap.LoadFromStream(stream: TStream);
    442892var bmp: TBGRABitmap;
    443    index: integer;
    444    temp: TBGRALayeredBitmap;
    445893begin
    446894  if Assigned(LayeredBitmapLoadFromStreamProc) then
    447895  begin
    448     temp := LayeredBitmapLoadFromStreamProc(Stream);
    449     if temp <> nil then
    450     begin
    451       Assign(temp);
    452       temp.Free;
     896    if not Assigned(LayeredBitmapCheckStreamProc) or
     897      LayeredBitmapCheckStreamProc(stream) then
     898    begin
     899      LayeredBitmapLoadFromStreamProc(Stream, self);
    453900      exit;
    454901    end;
    455902  end;
     903
    456904  bmp := TBGRABitmap.Create(stream);
    457905  Clear;
    458906  SetSize(bmp.Width,bmp.Height);
    459   index := AddSharedLayer(bmp);
    460   FLayers[index].Owner:= true;
     907  AddOwnedLayer(bmp);
     908end;
     909
     910procedure TBGRALayeredBitmap.LoadFromResource(AFilename: string);
     911var
     912  stream: TStream;
     913begin
     914  stream := BGRAResource.GetResourceStream(AFilename);
     915  try
     916    LoadFromStream(stream);
     917  finally
     918    stream.Free;
     919  end;
    461920end;
    462921
     
    474933  for i := NbLayers-1 downto 0 do
    475934    RemoveLayer(i);
     935  MemDirectory := nil;
     936  ClearOriginals;
     937end;
     938
     939procedure TBGRALayeredBitmap.ClearOriginals;
     940var
     941  i: Integer;
     942begin
     943  if Assigned(FOriginals) then
     944  begin
     945    for i := 0 to OriginalCount-1 do
     946      FOriginals[i].Instance.Free;
     947    FreeAndNil(FOriginals);
     948  end;
    476949end;
    477950
     
    503976
    504977procedure TBGRALayeredBitmap.Assign(ASource: TBGRACustomLayeredBitmap; ASharedLayerIds: boolean);
    505 var i,idx: integer;
    506 begin
     978var i,idx,idxOrig,idxNewOrig: integer;
     979    usedOriginals: array of record
     980       used: boolean;
     981       sourceGuid,newGuid: TGuid;
     982    end;
     983    orig: TBGRALayerCustomOriginal;
     984    stream: TMemoryStream;
     985
     986begin
     987  if ASource = nil then
     988    raise exception.Create('Unexpected nil reference');
    507989  Clear;
    508990  SetSize(ASource.Width,ASource.Height);
    509991  LinearBlend:= ASource.LinearBlend;
     992  setlength(usedOriginals, ASource.GetOriginalCount);
     993  for idxOrig := 0 to high(usedOriginals) do
     994  with usedOriginals[idxOrig] do
     995  begin
     996    used:= false;
     997    newGuid := GUID_NULL;
     998  end;
     999  for i := 0 to ASource.NbLayers-1 do
     1000  if (ASource.LayerOriginalGuid[i]<>GUID_NULL) and
     1001     (ASource.LayerOriginalKnown[i] or (ASource is TBGRALayeredBitmap)) then
     1002  begin
     1003    idxOrig := ASource.IndexOfOriginal(ASource.LayerOriginalGuid[i]);
     1004    if not usedOriginals[idxOrig].used then
     1005    begin
     1006      if ASource.LayerOriginalKnown[i] then
     1007      begin
     1008        orig := ASource.GetOriginalByIndex(idxOrig);
     1009        idxNewOrig := AddOriginal(orig, false);
     1010        usedOriginals[idxOrig].sourceGuid := orig.Guid;
     1011      end else
     1012      begin
     1013        stream := TMemoryStream.Create;
     1014        (ASource as TBGRALayeredBitmap).SaveOriginalToStream(idxOrig, stream);
     1015        stream.Position:= 0;
     1016        idxNewOrig := AddOriginalFromStream(stream,true);
     1017        stream.Free;
     1018        usedOriginals[idxOrig].sourceGuid := (ASource as TBGRALayeredBitmap).OriginalGuid[idxOrig];
     1019      end;
     1020      usedOriginals[idxOrig].newGuid := OriginalGuid[idxNewOrig];
     1021      usedOriginals[idxOrig].used := true;
     1022    end;
     1023  end;
    5101024  for i := 0 to ASource.NbLayers-1 do
    5111025  begin
     
    5141028    LayerVisible[idx] := ASource.LayerVisible[i];
    5151029    if ASharedLayerIds and (ASource is TBGRALayeredBitmap) then
    516       LayerUniqueId[idx] := TBGRALayeredBitmap(ASource).LayerUniqueId[idx];
     1030      LayerUniqueId[idx] := TBGRALayeredBitmap(ASource).LayerUniqueId[i];
     1031    for idxOrig := 0 to high(usedOriginals) do
     1032      if usedOriginals[i].sourceGuid = ASource.LayerOriginalGuid[i] then
     1033      begin
     1034        LayerOriginalGuid[idx] := usedOriginals[i].newGuid;
     1035        LayerOriginalMatrix[idx] := ASource.LayerOriginalMatrix[i];
     1036        LayerOriginalRenderStatus[idx] := ASource.LayerOriginalRenderStatus[i];
     1037      end;
    5171038  end;
    5181039end;
     
    5811102  FLayers[FNbLayers].Frozen := false;
    5821103  FLayers[FNbLayers].UniqueId := ProduceLayerUniqueId;
     1104  FLayers[FNbLayers].OriginalMatrix := AffineMatrixIdentity;
     1105  FLayers[FNbLayers].OriginalRenderStatus := orsNone;
     1106  FLayers[FNbLayers].OriginalGuid := GUID_NULL;
    5831107  if Shared then
    5841108  begin
     
    6881212end;
    6891213
     1214function TBGRALayeredBitmap.AddLayerFromOriginal(AGuid: TGuid;
     1215  Opacity: byte): integer;
     1216begin
     1217  result := AddLayerFromOriginal(AGuid, DefaultBlendingOperation, Opacity);
     1218end;
     1219
     1220function TBGRALayeredBitmap.AddLayerFromOriginal(AGuid: TGuid;
     1221  BlendOp: TBlendOperation; Opacity: byte): integer;
     1222begin
     1223  result := AddLayerFromOriginal(AGuid, AffineMatrixIdentity, BlendOp, Opacity);
     1224end;
     1225
     1226function TBGRALayeredBitmap.AddLayerFromOriginal(AGuid: TGuid;
     1227  Matrix: TAffineMatrix; Opacity: byte): integer;
     1228begin
     1229  result := AddLayerFromOriginal(AGuid, Matrix, DefaultBlendingOperation, Opacity);
     1230end;
     1231
     1232function TBGRALayeredBitmap.AddLayerFromOriginal(AGuid: TGuid;
     1233  Matrix: TAffineMatrix; BlendOp: TBlendOperation; Opacity: byte): integer;
     1234begin
     1235  result := AddOwnedLayer(TBGRABitmap.Create, BlendOp, Opacity);
     1236  LayerOriginalGuid[result] := AGuid;
     1237  LayerOriginalMatrix[result] := Matrix;
     1238  if not Assigned(LayerOriginal[result]) then
     1239    raise exception.Create('Original data or class not found');
     1240end;
     1241
     1242function TBGRALayeredBitmap.AddLayerFromOwnedOriginal(
     1243  AOriginal: TBGRALayerCustomOriginal; Opacity: byte): integer;
     1244begin
     1245  if IndexOfOriginal(AOriginal) = -1 then AddOriginal(AOriginal);
     1246  result := AddLayerFromOriginal(AOriginal.Guid, Opacity);
     1247end;
     1248
     1249function TBGRALayeredBitmap.AddLayerFromOwnedOriginal(
     1250  AOriginal: TBGRALayerCustomOriginal; BlendOp: TBlendOperation; Opacity: byte): integer;
     1251begin
     1252  if IndexOfOriginal(AOriginal) = -1 then AddOriginal(AOriginal);
     1253  result := AddLayerFromOriginal(AOriginal.Guid, BlendOp, Opacity);
     1254end;
     1255
     1256function TBGRALayeredBitmap.AddLayerFromOwnedOriginal(
     1257  AOriginal: TBGRALayerCustomOriginal; Matrix: TAffineMatrix; Opacity: byte): integer;
     1258begin
     1259  if IndexOfOriginal(AOriginal) = -1 then AddOriginal(AOriginal);
     1260  result := AddLayerFromOriginal(AOriginal.Guid, Matrix, Opacity);
     1261end;
     1262
     1263function TBGRALayeredBitmap.AddLayerFromOwnedOriginal(
     1264  AOriginal: TBGRALayerCustomOriginal; Matrix: TAffineMatrix;
     1265  BlendOp: TBlendOperation; Opacity: byte): integer;
     1266begin
     1267  if IndexOfOriginal(AOriginal) = -1 then AddOriginal(AOriginal);
     1268  result := AddLayerFromOriginal(AOriginal.Guid, Matrix, BlendOp, Opacity);
     1269end;
     1270
     1271function TBGRALayeredBitmap.AddOriginal(AOriginal: TBGRALayerCustomOriginal; AOwned: boolean): integer;
     1272var
     1273  newGuid: TGuid;
     1274begin
     1275  if AOriginal = nil then
     1276    raise exception.Create('Unexpected nil reference');;
     1277  if AOriginal.Guid = GUID_NULL then
     1278  begin
     1279    if CreateGUID(newGuid)<> 0 then
     1280    begin
     1281      if AOwned then AOriginal.Free;
     1282      raise exception.Create('Error while creating GUID');
     1283    end;
     1284    AOriginal.Guid := newGuid;
     1285  end else
     1286  begin
     1287    if IndexOfOriginal(AOriginal) <> -1 then
     1288    begin
     1289      if AOwned then AOriginal.Free;
     1290      raise exception.Create('Original already added');
     1291    end;
     1292    if IndexOfOriginal(AOriginal.Guid) <> -1 then
     1293    begin
     1294      if AOwned then AOriginal.Free;
     1295      raise exception.Create('GUID is already in use');
     1296    end;
     1297  end;
     1298  StoreOriginal(AOriginal);
     1299  if FOriginals = nil then FOriginals := TBGRALayerOriginalList.Create;
     1300  if AOwned then
     1301  begin
     1302    result := FOriginals.Add(BGRALayerOriginalEntry(AOriginal));
     1303    AOriginal.OnChange:= @OriginalChange;
     1304    AOriginal.OnEditingChange:= @OriginalEditingChange;
     1305  end
     1306  else
     1307    result := FOriginals.Add(BGRALayerOriginalEntry(AOriginal.Guid));
     1308end;
     1309
     1310function TBGRALayeredBitmap.AddOriginalFromStream(AStream: TStream;
     1311  ALateLoad: boolean): integer;
     1312var
     1313  storage: TBGRAMemOriginalStorage;
     1314begin
     1315  storage:= TBGRAMemOriginalStorage.Create;
     1316  storage.LoadFromStream(AStream);
     1317  try
     1318    result := AddOriginalFromStorage(storage, ALateLoad);
     1319  finally
     1320    storage.Free;
     1321  end;
     1322end;
     1323
     1324function TBGRALayeredBitmap.AddOriginalFromStorage(AStorage: TBGRAMemOriginalStorage; ALateLoad: boolean): integer;
     1325var
     1326  origClassName: String;
     1327  origClass: TBGRALayerOriginalAny;
     1328  orig: TBGRALayerCustomOriginal;
     1329  newGuid: TGuid;
     1330  dir, subdir: TMemDirectory;
     1331begin
     1332  result := -1;
     1333  origClassName := AStorage.RawString['class'];
     1334  if origClassName = '' then raise Exception.Create('Original class name not defined');
     1335  if ALateLoad then
     1336  begin
     1337    if CreateGUID(newGuid)<> 0 then
     1338      raise exception.Create('Error while creating GUID');
     1339    if IndexOfOriginal(newGuid)<>-1 then
     1340      raise exception.Create('Duplicate GUID');
     1341
     1342    dir := MemDirectory.Directory[MemDirectory.AddDirectory(OriginalsDirectory)];
     1343    subdir := dir.Directory[dir.AddDirectory(GUIDToString(newGuid))];
     1344    AStorage.CopyTo(subdir);
     1345
     1346    if FOriginals = nil then FOriginals := TBGRALayerOriginalList.Create;
     1347    result := FOriginals.Add(BGRALayerOriginalEntry(newGuid));
     1348  end else
     1349  begin
     1350    origClass := FindLayerOriginalClass(origClassName);
     1351    if origClass = nil then raise exception.Create('Original class not found (it can be registered with the RegisterLayerOriginal function)');
     1352    orig := origClass.Create;
     1353    try
     1354      orig.LoadFromStorage(AStorage);
     1355      result := AddOriginal(orig, true);
     1356    except on ex:exception do
     1357      begin
     1358        orig.Free;
     1359        raise exception.Create('Error loading original. '+ ex.Message);
     1360      end;
     1361    end;
     1362  end;
     1363end;
     1364
     1365procedure TBGRALayeredBitmap.SaveOriginalToStream(AIndex: integer;
     1366  AStream: TStream);
     1367var
     1368  dir: TMemDirectory;
     1369  c: TBGRALayerOriginalAny;
     1370begin
     1371  if (AIndex < 0) or (AIndex >= OriginalCount) then
     1372    raise ERangeError.Create('Index out of bounds');
     1373
     1374  if Assigned(FOriginals[AIndex].Instance) then
     1375    FOriginals[AIndex].Instance.SaveToStream(AStream)
     1376  else
     1377  begin
     1378    FindOriginal(FOriginals[AIndex].Guid, dir, c);
     1379    if dir = nil then
     1380      raise exception.Create('Originals directory not found');
     1381    dir.SaveToStream(AStream);
     1382  end;
     1383end;
     1384
     1385procedure TBGRALayeredBitmap.SaveOriginalToStream(AGuid: TGUID; AStream: TStream);
     1386var
     1387  idxOrig: Integer;
     1388begin
     1389  idxOrig := IndexOfOriginal(AGuid);
     1390  if idxOrig = -1 then raise exception.Create('Original not found');
     1391  SaveOriginalToStream(idxOrig, AStream);
     1392end;
     1393
     1394function TBGRALayeredBitmap.RemoveOriginal(AOriginal: TBGRALayerCustomOriginal): boolean;
     1395var
     1396  idx: Integer;
     1397begin
     1398  idx := IndexOfOriginal(AOriginal);
     1399  if idx = -1 then exit(false);
     1400  DeleteOriginal(idx);
     1401  result := true;
     1402end;
     1403
     1404procedure TBGRALayeredBitmap.DeleteOriginal(AIndex: integer);
     1405var
     1406  dir: TMemDirectory;
     1407  i: Integer;
     1408  guid: TGuid;
     1409begin
     1410  if (AIndex < 0) or (AIndex >= OriginalCount) then
     1411    raise ERangeError.Create('Index out of bounds');
     1412
     1413  guid := FOriginals[AIndex].Guid;
     1414  for i := 0 to NbLayers-1 do
     1415    if LayerOriginalGuid[i] = guid then
     1416    begin
     1417      LayerOriginalGuid[i] := GUID_NULL;
     1418      LayerOriginalMatrix[i] := AffineMatrixIdentity;
     1419    end;
     1420
     1421  dir := MemDirectory.Directory[MemDirectory.AddDirectory(OriginalsDirectory)];
     1422  dir.Delete(GUIDToString(guid),'');
     1423
     1424  FOriginals[AIndex].Instance.Free;
     1425  FOriginals.Delete(AIndex); //AOriginals freed
     1426end;
     1427
     1428procedure TBGRALayeredBitmap.NotifyLoaded;
     1429var
     1430  foundGuid: array of TGuid;
     1431  nbFoundGuid: integer;
     1432
     1433  procedure AddGuid(const AGuid: TGuid);
     1434  begin
     1435    foundGuid[nbFoundGuid] := AGuid;
     1436    inc(nbFoundGuid);
     1437  end;
     1438
     1439  function IndexOfGuid(AGuid: TGuid): integer;
     1440  var
     1441    i: Integer;
     1442  begin
     1443    for i := 0 to nbFoundGuid-1 do
     1444      if foundGuid[i] = AGuid then exit(i);
     1445    result := -1;
     1446  end;
     1447
     1448var
     1449  i: Integer;
     1450  dir: TMemDirectory;
     1451  newGuid: TGUID;
     1452
     1453begin
     1454  inherited NotifyLoaded;
     1455
     1456  //if there are no files in memory, we are sure that there are no originals
     1457  if not HasMemFiles then
     1458  begin
     1459    ClearOriginals;
     1460    exit;
     1461  end;
     1462
     1463  //determine list of GUID of originals
     1464  dir := MemDirectory.Directory[MemDirectory.AddDirectory(OriginalsDirectory)];
     1465  setlength(foundGuid, dir.Count);
     1466  nbFoundGuid:= 0;
     1467  for i := 0 to dir.Count-1 do
     1468    if dir.IsDirectory[i] and (dir.Entry[i].Extension = '') then
     1469    begin
     1470      if TryStringToGUID(dir.Entry[i].Name, newGuid) then
     1471        AddGuid(newGuid);
     1472    end;
     1473
     1474  //remove originals that do not exist anymore
     1475  for i := OriginalCount-1 downto 0 do
     1476    if IndexOfGuid(FOriginals[i].Guid) = -1 then
     1477      DeleteOriginal(i);
     1478
     1479  //add originals from memory directory
     1480  for i := 0 to nbFoundGuid-1 do
     1481  begin
     1482    if IndexOfOriginal(foundGuid[i]) = -1 then
     1483    begin
     1484      if FOriginals = nil then FOriginals := TBGRALayerOriginalList.Create;
     1485      FOriginals.Add(BGRALayerOriginalEntry(foundGuid[i]));
     1486    end;
     1487  end;
     1488end;
     1489
     1490procedure TBGRALayeredBitmap.NotifySaving;
     1491var
     1492  i: Integer;
     1493begin
     1494  inherited NotifySaving;
     1495
     1496  RenderOriginalsIfNecessary;
     1497
     1498  for i := 0 to OriginalCount-1 do
     1499    if Assigned(FOriginals[i].Instance) then
     1500      StoreOriginal(FOriginals[i].Instance);
     1501end;
     1502
     1503procedure TBGRALayeredBitmap.RenderLayerFromOriginal(layer: integer;
     1504  ADraft: boolean; AFullSizeLayer: boolean = false);
     1505begin
     1506  RenderLayerFromOriginal(layer, ADraft, rectF(0,0,Width,Height), AFullSizeLayer);
     1507end;
     1508
     1509procedure TBGRALayeredBitmap.RenderLayerFromOriginal(layer: integer;
     1510  ADraft: boolean; ARenderBounds: TRect; AFullSizeLayer: boolean = false);
     1511var
     1512  orig: TBGRALayerCustomOriginal;
     1513  rAll, rNewBounds, rInterRender: TRect;
     1514  newSource: TBGRABitmap;
     1515
     1516  procedure FreeSource;
     1517  begin
     1518    if FLayers[layer].Owner then
     1519      FreeAndNil(FLayers[layer].Source)
     1520    else
     1521      FLayers[layer].Source := nil;
     1522  end;
     1523
     1524begin
     1525  if (layer < 0) or (layer >= NbLayers) then
     1526    raise Exception.Create('Index out of bounds');
     1527
     1528  orig := LayerOriginal[layer];
     1529  if Assigned(orig) then
     1530  begin
     1531    rAll := rect(0,0,Width,Height);
     1532    if AFullSizeLayer then
     1533      rNewBounds := rAll
     1534    else
     1535    begin
     1536      rNewBounds := orig.GetRenderBounds(rAll,FLayers[layer].OriginalMatrix);
     1537      IntersectRect({%H-}rNewBounds, rNewBounds, rAll);
     1538    end;
     1539    IntersectRect({%H-}rInterRender, ARenderBounds, rNewBounds);
     1540    if (FLayers[layer].x = rNewBounds.Left) and
     1541      (FLayers[layer].y = rNewBounds.Top) and
     1542      (FLayers[layer].Source.Width = rNewBounds.Width) and
     1543      (FLayers[layer].Source.Height = rNewBounds.Height) then
     1544    begin
     1545      OffsetRect(rInterRender, -rNewBounds.Left, -rNewBounds.Top);
     1546      FLayers[layer].Source.FillRect(rInterRender, BGRAPixelTransparent, dmSet);
     1547      FLayers[layer].Source.ClipRect := rInterRender;
     1548      orig.Render(FLayers[layer].Source, AffineMatrixTranslation(-rNewBounds.Left,-rNewBounds.Top)*FLayers[layer].OriginalMatrix, ADraft);
     1549      FLayers[layer].Source.NoClip;
     1550    end else
     1551    begin
     1552      if rInterRender = rNewBounds then
     1553      begin
     1554        FreeSource;
     1555        newSource := TBGRABitmap.Create(rNewBounds.Width,rNewBounds.Height);
     1556        orig.Render(newSource, AffineMatrixTranslation(-rNewBounds.Left,-rNewBounds.Top)*FLayers[layer].OriginalMatrix, ADraft);
     1557      end else
     1558      begin
     1559        newSource := TBGRABitmap.Create(rNewBounds.Width,rNewBounds.Height);
     1560        newSource.PutImage(FLayers[layer].x - rNewBounds.Left, FLayers[layer].y - rNewBounds.Top, FLayers[layer].Source, dmSet);
     1561        FreeSource;
     1562        OffsetRect(rInterRender, -rNewBounds.Left, -rNewBounds.Top);
     1563        if not IsRectEmpty(rInterRender) then
     1564        begin
     1565          newSource.FillRect(rInterRender, BGRAPixelTransparent, dmSet);
     1566          newSource.ClipRect := rInterRender;
     1567          orig.Render(newSource, AffineMatrixTranslation(-rNewBounds.Left,-rNewBounds.Top)*FLayers[layer].OriginalMatrix, ADraft);
     1568          newSource.NoClip;
     1569        end;
     1570      end;
     1571      FLayers[layer].Source := newSource;
     1572      FLayers[layer].x := rNewBounds.Left;
     1573      FLayers[layer].y := rNewBounds.Top;
     1574    end;
     1575  end;
     1576  if ADraft then
     1577    FLayers[layer].OriginalRenderStatus := orsDraft
     1578  else
     1579    FLayers[layer].OriginalRenderStatus := orsProof;
     1580  FLayers[layer].OriginalInvalidatedBounds := EmptyRectF;
     1581end;
     1582
     1583procedure TBGRALayeredBitmap.RenderLayerFromOriginal(layer: integer;
     1584  ADraft: boolean; ARenderBoundsF: TRectF; AFullSizeLayer: boolean = false);
     1585var
     1586  r: TRect;
     1587begin
     1588  with ARenderBoundsF do
     1589    r := Rect(floor(Left),floor(Top),ceil(Right),ceil(Bottom));
     1590  RenderLayerFromOriginal(layer, ADraft, r, AFullSizeLayer);
     1591end;
     1592
     1593function TBGRALayeredBitmap.RenderOriginalsIfNecessary(ADraft: boolean): TRect;
     1594  procedure UnionLayerArea(ALayer: integer);
     1595  var
     1596    r: TRect;
     1597  begin
     1598    if (FLayers[ALayer].Source = nil) or
     1599      (FLayers[ALayer].Source.Width = 0) or
     1600      (FLayers[ALayer].Source.Height = 0) then exit;
     1601
     1602    r := RectWithSize(LayerOffset[ALayer].X, LayerOffset[ALayer].Y,
     1603                      FLayers[ALayer].Source.Width, FLayers[ALayer].Source.Height);
     1604    if IsRectEmpty(result) then result := r else
     1605      UnionRect(result,result,r);
     1606  end;
     1607
     1608var
     1609  i: Integer;
     1610  r: TRect;
     1611
     1612begin
     1613  result:= EmptyRect;
     1614  for i := 0 to NbLayers-1 do
     1615    case LayerOriginalRenderStatus[i] of
     1616    orsNone:
     1617         begin
     1618           UnionLayerArea(i);
     1619           RenderLayerFromOriginal(i, ADraft);
     1620           UnionLayerArea(i);
     1621         end;
     1622    orsDraft: if not ADraft then
     1623         begin
     1624           UnionLayerArea(i);
     1625           RenderLayerFromOriginal(i, ADraft);
     1626           UnionLayerArea(i);
     1627         end;
     1628    orsPartialDraft,orsPartialProof:
     1629         if not ADraft and (LayerOriginalRenderStatus[i] = orsPartialDraft) then
     1630         begin
     1631           UnionLayerArea(i);
     1632           RenderLayerFromOriginal(i, ADraft, rect(0,0,Width,Height), true);
     1633           UnionLayerArea(i);
     1634         end
     1635         else
     1636         begin
     1637           with FLayers[i].OriginalInvalidatedBounds do
     1638             r := Rect(floor(Left),floor(Top),ceil(Right),ceil(Bottom));
     1639           RenderLayerFromOriginal(i, ADraft, r, true);
     1640           if not IsRectEmpty(r) then
     1641           begin
     1642             if IsRectEmpty(result) then
     1643               result := r
     1644             else
     1645               UnionRect(result, result, r);
     1646           end;
     1647         end;
     1648    end;
     1649end;
     1650
     1651procedure TBGRALayeredBitmap.RemoveUnusedOriginals;
     1652var useCount: array of integer;
     1653  i, idxOrig: Integer;
     1654begin
     1655  if OriginalCount = 0 then exit;
     1656  setlength(useCount, OriginalCount);
     1657  for i := 0 to NbLayers-1 do
     1658  begin
     1659    idxOrig := IndexOfOriginal(LayerOriginalGuid[i]);
     1660    if idxOrig <> -1 then useCount[idxOrig] += 1;
     1661  end;
     1662  for i := high(useCount) downto 0 do
     1663    if useCount[i] = 0 then DeleteOriginal(i);
     1664end;
     1665
    6901666destructor TBGRALayeredBitmap.Destroy;
    6911667begin
     1668  FOriginalEditor.Free;
    6921669  inherited Destroy;
    6931670end;
     
    6991676  FHeight := 0;
    7001677  FNbLayers:= 0;
     1678  FOriginals := nil;
    7011679end;
    7021680
     
    7451723procedure TBGRALayeredBitmap.RotateCW;
    7461724var i: integer;
     1725  newBmp: TBGRABitmap;
     1726  newOfs: TPointF;
     1727  m: TAffineMatrix;
    7471728begin
    7481729  SetSize(Height,Width); //unfreeze
     1730  m := AffineMatrixTranslation(Width,0)*AffineMatrixRotationDeg(90);
    7491731  for i := 0 to NbLayers-1 do
    750     SetLayerBitmap(i, LayerBitmap[i].RotateCW as TBGRABitmap, True);
     1732  begin
     1733    newOfs:= m*PointF(FLayers[i].x,FLayers[i].y+FLayers[i].Source.Height);
     1734    newBmp := FLayers[i].Source.RotateCW as TBGRABitmap;
     1735    if FLayers[i].Owner then FreeAndNil(FLayers[i].Source);
     1736    FLayers[i].Source := newBmp;
     1737    FLayers[i].Owner := true;
     1738    FLayers[i].x := round(newOfs.x);
     1739    FLayers[i].y := round(newOfs.y);
     1740    FLayers[i].OriginalMatrix := m*FLayers[i].OriginalMatrix;
     1741  end;
    7511742end;
    7521743
    7531744procedure TBGRALayeredBitmap.RotateCCW;
    7541745var i: integer;
     1746  newBmp: TBGRABitmap;
     1747  newOfs: TPointF;
     1748  m: TAffineMatrix;
    7551749begin
    7561750  SetSize(Height,Width); //unfreeze
     1751  m := AffineMatrixTranslation(0,Height)*AffineMatrixRotationDeg(-90);
    7571752  for i := 0 to NbLayers-1 do
    758     SetLayerBitmap(i, LayerBitmap[i].RotateCCW as TBGRABitmap, True);
     1753  begin
     1754    newOfs:= m*PointF(FLayers[i].x+FLayers[i].Source.Width,FLayers[i].y);
     1755    newBmp := FLayers[i].Source.RotateCCW as TBGRABitmap;
     1756    if FLayers[i].Owner then FreeAndNil(FLayers[i].Source);
     1757    FLayers[i].Source := newBmp;
     1758    FLayers[i].Owner := true;
     1759    FLayers[i].x := round(newOfs.x);
     1760    FLayers[i].y := round(newOfs.y);
     1761    FLayers[i].OriginalMatrix := m*FLayers[i].OriginalMatrix;
     1762  end;
    7591763end;
    7601764
     
    7641768  Unfreeze;
    7651769  for i := 0 to NbLayers-1 do
    766   begin
    767     if FLayers[i].Owner then
    768       FLayers[i].Source.HorizontalFlip
    769     else
    770     begin
    771       FLayers[i].Source := FLayers[i].Source.Duplicate(True) as TBGRABitmap;
    772       FLayers[i].Source.HorizontalFlip;
    773       FLayers[i].Owner := true;
    774     end;
    775   end;
     1770    HorizontalFlip(i);
     1771end;
     1772
     1773procedure TBGRALayeredBitmap.HorizontalFlip(ALayerIndex: integer);
     1774begin
     1775  if (ALayerIndex < 0) or (ALayerIndex >= NbLayers) then
     1776    raise ERangeError.Create('Index out of bounds');
     1777  Unfreeze(ALayerIndex);
     1778  if FLayers[ALayerIndex].Owner then
     1779    FLayers[ALayerIndex].Source.HorizontalFlip
     1780  else
     1781  begin
     1782    FLayers[ALayerIndex].Source := FLayers[ALayerIndex].Source.Duplicate(True) as TBGRABitmap;
     1783    FLayers[ALayerIndex].Source.HorizontalFlip;
     1784    FLayers[ALayerIndex].Owner := true;
     1785  end;
     1786  FLayers[ALayerIndex].x := Width-FLayers[ALayerIndex].x-FLayers[ALayerIndex].Source.Width;
     1787  FLayers[ALayerIndex].OriginalMatrix := AffineMatrixTranslation(+Width/2,0)*AffineMatrixScale(-1,1)*AffineMatrixTranslation(-Width/2,0)*FLayers[ALayerIndex].OriginalMatrix;
    7761788end;
    7771789
     
    7811793  Unfreeze;
    7821794  for i := 0 to NbLayers-1 do
    783   begin
    784     if FLayers[i].Owner then
    785       FLayers[i].Source.VerticalFlip
    786     else
    787     begin
    788       FLayers[i].Source := FLayers[i].Source.Duplicate(True) as TBGRABitmap;
    789       FLayers[i].Source.VerticalFlip;
    790       FLayers[i].Owner := true;
    791     end;
    792   end;
     1795    VerticalFlip(i);
     1796end;
     1797
     1798procedure TBGRALayeredBitmap.VerticalFlip(ALayerIndex: integer);
     1799begin
     1800  if (ALayerIndex < 0) or (ALayerIndex >= NbLayers) then
     1801    raise ERangeError.Create('Index out of bounds');
     1802  Unfreeze(ALayerIndex);
     1803  if FLayers[ALayerIndex].Owner then
     1804    FLayers[ALayerIndex].Source.VerticalFlip
     1805  else
     1806  begin
     1807    FLayers[ALayerIndex].Source := FLayers[ALayerIndex].Source.Duplicate(True) as TBGRABitmap;
     1808    FLayers[ALayerIndex].Source.VerticalFlip;
     1809    FLayers[ALayerIndex].Owner := true;
     1810  end;
     1811  FLayers[ALayerIndex].y := Height-FLayers[ALayerIndex].y-FLayers[ALayerIndex].Source.Height;
     1812  FLayers[ALayerIndex].OriginalMatrix := AffineMatrixTranslation(0,+Height/2)*AffineMatrixScale(1,-1)*AffineMatrixTranslation(0,-Height/2)*FLayers[ALayerIndex].OriginalMatrix;
    7931813end;
    7941814
    7951815procedure TBGRALayeredBitmap.Resample(AWidth, AHeight: integer;
    7961816  AResampleMode: TResampleMode; AFineResampleFilter: TResampleFilter);
    797 var i: integer;
     1817var i, prevWidth, prevHeight: integer;
    7981818    resampled: TBGRABitmap;
    7991819    oldFilter : TResampleFilter;
     
    8011821  if (AWidth < 0) or (AHeight < 0) then
    8021822    raise exception.Create('Invalid size');
     1823  prevWidth := Width;
     1824  if prevWidth < 1 then prevWidth := AWidth;
     1825  prevHeight := Height;
     1826  if prevHeight < 1 then prevHeight := AHeight;
    8031827  SetSize(AWidth, AHeight); //unfreeze
    8041828  for i := 0 to NbLayers-1 do
     1829  if (FLayers[i].OriginalGuid <> GUID_NULL) and LayerOriginalKnown[i] then
     1830    LayerOriginalMatrix[i] := AffineMatrixScale(AWidth/prevWidth,AHeight/prevHeight)*LayerOriginalMatrix[i]
     1831  else
    8051832  begin
    8061833    oldFilter := LayerBitmap[i].ResampleFilter;
     
    8101837    SetLayerBitmap(i, resampled, True);
    8111838  end;
     1839  if AResampleMode = rmFineResample then RenderOriginalsIfNecessary;
    8121840end;
    8131841
     
    8241852    FLayers[layer].Source := ABitmap;
    8251853    FLayers[layer].Owner := AOwned;
    826   end;
     1854    FLayers[layer].OriginalGuid := GUID_NULL;
     1855    FLayers[layer].OriginalMatrix := AffineMatrixIdentity;
     1856  end;
     1857end;
     1858
     1859procedure TBGRALayeredBitmap.ApplyLayerOffset(ALayerIndex: integer;
     1860  APadWithTranparentPixels: boolean);
     1861var
     1862  r: TRect;
     1863  newBmp: TBGRABitmap;
     1864begin
     1865  if APadWithTranparentPixels then
     1866  begin
     1867    if (LayerOffset[ALayerIndex].X=0) and (LayerOffset[ALayerIndex].Y=0) and
     1868       (LayerBitmap[ALayerIndex].Width=Width) and (LayerBitmap[ALayerIndex].Height=Height) then exit;
     1869    newBmp := TBGRABitmap.Create(Width,Height);
     1870    newBmp.PutImage(LayerOffset[ALayerIndex].X, LayerOffset[ALayerIndex].Y, LayerBitmap[ALayerIndex], dmSet);
     1871    if FLayers[ALayerIndex].Owner then FLayers[ALayerIndex].Source.Free;
     1872    FLayers[ALayerIndex].Source := newBmp;
     1873    FLayers[ALayerIndex].Owner := true;
     1874    FLayers[ALayerIndex].x := 0;
     1875    FLayers[ALayerIndex].y := 0;
     1876  end else
     1877  begin
     1878    if (LayerOffset[ALayerIndex].X>=0) and (LayerOffset[ALayerIndex].Y>=0) and
     1879       (LayerOffset[ALayerIndex].X+LayerBitmap[ALayerIndex].Width <= Width) and
     1880       (LayerOffset[ALayerIndex].Y+LayerBitmap[ALayerIndex].Height <= Height) then exit;
     1881    r := RectWithSize(LayerOffset[ALayerIndex].X, LayerOffset[ALayerIndex].Y,
     1882                      LayerBitmap[ALayerIndex].Width, LayerBitmap[ALayerIndex].Height);
     1883    IntersectRect(r, r, rect(0,0,Width,Height));
     1884    newBmp := TBGRABitmap.Create(r.Width,r.Height);
     1885    newBmp.PutImage(LayerOffset[ALayerIndex].X - r.Left, LayerOffset[ALayerIndex].Y - r.Top, LayerBitmap[ALayerIndex], dmSet);
     1886    if FLayers[ALayerIndex].Owner then FLayers[ALayerIndex].Source.Free;
     1887    FLayers[ALayerIndex].Source := newBmp;
     1888    FLayers[ALayerIndex].Owner := true;
     1889    FLayers[ALayerIndex].x := r.Left;
     1890    FLayers[ALayerIndex].y := r.Top;
     1891  end;
     1892end;
     1893
     1894function TBGRALayeredBitmap.DrawEditor(ADest: TBGRABitmap;
     1895  ALayerIndex: integer; X, Y: Integer; APointSize: single): TRect;
     1896begin
     1897  result := DrawEditor(ADest, ALayerIndex, AffineMatrixTranslation(X,Y), APointSize);
     1898end;
     1899
     1900function TBGRALayeredBitmap.DrawEditor(ADest: TBGRABitmap; ALayerIndex: integer;
     1901  AMatrix: TAffineMatrix; APointSize: single): TRect;
     1902var
     1903  orig: TBGRALayerCustomOriginal;
     1904begin
     1905  orig := LayerOriginal[ALayerIndex];
     1906
     1907  if orig <> FOriginalEditorOriginal then
     1908  begin
     1909    FreeAndNil(FOriginalEditor);
     1910    FOriginalEditorOriginal := orig;
     1911  end;
     1912
     1913  if Assigned(orig) then
     1914  begin
     1915    if FOriginalEditor = nil then
     1916    begin
     1917      FOriginalEditor := orig.CreateEditor;
     1918    end;
     1919    FOriginalEditor.Clear;
     1920    orig.ConfigureEditor(FOriginalEditor);
     1921    FOriginalEditorViewMatrix := AffineMatrixTranslation(-0.5,-0.5)*AMatrix*AffineMatrixTranslation(0.5,0.5);
     1922    FOriginalEditor.Matrix := AffineMatrixTranslation(-0.5,-0.5)*AMatrix*LayerOriginalMatrix[ALayerIndex]*AffineMatrixTranslation(0.5,0.5);
     1923    FOriginalEditor.PointSize := APointSize;
     1924    result := FOriginalEditor.Render(ADest, rect(0,0,ADest.Width,ADest.Height));
     1925  end else
     1926    result := EmptyRect;
     1927end;
     1928
     1929function TBGRALayeredBitmap.GetEditorBounds(ALayerIndex: integer; X,
     1930  Y: Integer; APointSize: single): TRect;
     1931begin
     1932  result := GetEditorBounds(ALayerIndex, AffineMatrixTranslation(X,Y), APointSize);
     1933end;
     1934
     1935function TBGRALayeredBitmap.GetEditorBounds(ADestRect: TRect;
     1936  ALayerIndex: integer; X, Y: Integer; APointSize: single): TRect;
     1937begin
     1938  result := GetEditorBounds(ADestRect, ALayerIndex, AffineMatrixTranslation(X,Y), APointSize);
     1939end;
     1940
     1941function TBGRALayeredBitmap.GetEditorBounds(ALayerIndex: integer;
     1942  AMatrix: TAffineMatrix; APointSize: single): TRect;
     1943begin
     1944  result := GetEditorBounds(rect(-maxLongint,-maxLongint,maxLongint,maxLongint), ALayerIndex, AMatrix, APointSize);
     1945end;
     1946
     1947function TBGRALayeredBitmap.GetEditorBounds(ADestRect: TRect; ALayerIndex: integer;
     1948  AMatrix: TAffineMatrix; APointSize: single): TRect;
     1949var
     1950  orig: TBGRALayerCustomOriginal;
     1951begin
     1952  orig := LayerOriginal[ALayerIndex];
     1953
     1954  if orig <> FOriginalEditorOriginal then
     1955  begin
     1956    FreeAndNil(FOriginalEditor);
     1957    FOriginalEditorOriginal := orig;
     1958  end;
     1959
     1960  if Assigned(orig) then
     1961  begin
     1962    if FOriginalEditor = nil then
     1963    begin
     1964      FOriginalEditor := orig.CreateEditor;
     1965      if FOriginalEditor = nil then
     1966        raise exception.Create('Unexpected nil value');
     1967    end;
     1968    FOriginalEditor.Clear;
     1969    orig.ConfigureEditor(FOriginalEditor);
     1970    FOriginalEditorViewMatrix := AffineMatrixTranslation(-0.5,-0.5)*AMatrix*AffineMatrixTranslation(0.5,0.5);
     1971    FOriginalEditor.Matrix := AffineMatrixTranslation(-0.5,-0.5)*AMatrix*LayerOriginalMatrix[ALayerIndex]*AffineMatrixTranslation(0.5,0.5);
     1972    FOriginalEditor.PointSize := APointSize;
     1973    result := FOriginalEditor.GetRenderBounds(ADestRect);
     1974  end else
     1975    result := EmptyRect;
     1976end;
     1977
     1978procedure TBGRALayeredBitmap.MouseMove(Shift: TShiftState; ImageX, ImageY: Single; out
     1979  ACursor: TOriginalEditorCursor);
     1980var
     1981  handled: boolean;
     1982begin
     1983  MouseMove(Shift, ImageX,ImageY, ACursor, handled);
     1984end;
     1985
     1986procedure TBGRALayeredBitmap.MouseDown(RightButton: boolean;
     1987  Shift: TShiftState; ImageX, ImageY: Single; out ACursor: TOriginalEditorCursor);
     1988var
     1989  handled: boolean;
     1990begin
     1991  MouseDown(RightButton, Shift, ImageX,ImageY, ACursor, handled);
     1992end;
     1993
     1994procedure TBGRALayeredBitmap.MouseUp(RightButton: boolean; Shift: TShiftState;
     1995  ImageX, ImageY: Single; out ACursor: TOriginalEditorCursor);
     1996var
     1997  handled: boolean;
     1998begin
     1999  MouseUp(RightButton, Shift, ImageX,ImageY, ACursor, handled);
     2000end;
     2001
     2002procedure TBGRALayeredBitmap.MouseMove(Shift: TShiftState; ImageX, ImageY: Single; out
     2003  ACursor: TOriginalEditorCursor; out AHandled: boolean);
     2004var
     2005  viewPt: TPointF;
     2006begin
     2007  if Assigned(FOriginalEditor) then
     2008  begin
     2009    viewPt := FOriginalEditorViewMatrix*PointF(ImageX,ImageY);
     2010    FOriginalEditor.MouseMove(Shift, viewPt.X, viewPt.Y, ACursor, AHandled);
     2011  end
     2012  else
     2013  begin
     2014    ACursor:= oecDefault;
     2015    AHandled:= false;
     2016  end;
     2017end;
     2018
     2019procedure TBGRALayeredBitmap.MouseDown(RightButton: boolean;
     2020  Shift: TShiftState; ImageX, ImageY: Single; out ACursor: TOriginalEditorCursor; out
     2021  AHandled: boolean);
     2022var
     2023  viewPt: TPointF;
     2024begin
     2025  if Assigned(FOriginalEditor) then
     2026  begin
     2027    viewPt := FOriginalEditorViewMatrix*PointF(ImageX,ImageY);
     2028    FOriginalEditor.MouseDown(RightButton, Shift, viewPt.X, viewPt.Y, ACursor, AHandled);
     2029  end
     2030  else
     2031  begin
     2032    ACursor:= oecDefault;
     2033    AHandled:= false;
     2034  end;
     2035end;
     2036
     2037procedure TBGRALayeredBitmap.MouseUp(RightButton: boolean; Shift: TShiftState;
     2038  ImageX, ImageY: Single; out ACursor: TOriginalEditorCursor; out AHandled: boolean);
     2039var
     2040  viewPt: TPointF;
     2041begin
     2042  if Assigned(FOriginalEditor) then
     2043  begin
     2044    viewPt := FOriginalEditorViewMatrix*PointF(ImageX,ImageY);
     2045    FOriginalEditor.MouseUp(RightButton, Shift, viewPt.X,viewPt.Y, ACursor, AHandled);
     2046  end
     2047  else
     2048  begin
     2049    ACursor:= oecDefault;
     2050    AHandled:= false;
     2051  end;
     2052end;
     2053
     2054procedure TBGRALayeredBitmap.KeyDown(Shift: TShiftState; Key: TSpecialKey; out
     2055  AHandled: boolean);
     2056begin
     2057  if Assigned(FOriginalEditor) then
     2058    FOriginalEditor.KeyDown(Shift, Key, AHandled)
     2059  else
     2060    AHandled := false;
     2061end;
     2062
     2063procedure TBGRALayeredBitmap.KeyUp(Shift: TShiftState; Key: TSpecialKey; out
     2064  AHandled: boolean);
     2065begin
     2066  if Assigned(FOriginalEditor) then
     2067    FOriginalEditor.KeyUp(Shift, Key, AHandled)
     2068  else
     2069    AHandled := false;
     2070end;
     2071
     2072procedure TBGRALayeredBitmap.KeyPress(UTF8Key: string; out AHandled: boolean);
     2073begin
     2074  if Assigned(FOriginalEditor) then
     2075    FOriginalEditor.KeyPress(UTF8Key, AHandled)
     2076  else
     2077    AHandled := false;
     2078end;
     2079
     2080function TBGRALayeredBitmap.IndexOfOriginal(AGuid: TGuid): integer;
     2081var
     2082  i: Integer;
     2083begin
     2084  for i := 0 to OriginalCount-1 do
     2085    if FOriginals[i].Guid = AGuid then
     2086    begin
     2087      result := i;
     2088      exit;
     2089    end;
     2090  result := -1
     2091end;
     2092
     2093function TBGRALayeredBitmap.IndexOfOriginal(AOriginal: TBGRALayerCustomOriginal): integer;
     2094begin
     2095  if Assigned(FOriginals) then
     2096    result := FOriginals.IndexOf(BGRALayerOriginalEntry(AOriginal))
     2097  else
     2098    result := -1;
    8272099end;
    8282100
     
    8342106end;
    8352107
     2108function TBGRACustomLayeredBitmap.GetMemDirectory: TMemDirectory;
     2109begin
     2110  if FMemDirectory = nil then
     2111  begin
     2112    FMemDirectory:= TMemDirectory.Create;
     2113    FMemDirectoryOwned := true;
     2114  end;
     2115  result := FMemDirectory;
     2116end;
     2117
    8362118function TBGRACustomLayeredBitmap.GetDefaultBlendingOperation: TBlendOperation;
    8372119begin
    8382120  result := boTransparent;
     2121end;
     2122
     2123function TBGRACustomLayeredBitmap.GetHasMemFiles: boolean;
     2124begin
     2125  result := assigned(FMemDirectory) and (FMemDirectory.Count > 0);
     2126end;
     2127
     2128function TBGRACustomLayeredBitmap.GetLayerOriginalGuid(layer: integer): TGuid;
     2129begin
     2130  result := GUID_NULL;
     2131end;
     2132
     2133function TBGRACustomLayeredBitmap.GetLayerOriginalRenderStatus(layer: integer): TOriginalRenderStatus;
     2134begin
     2135  result := orsProof;
     2136end;
     2137
     2138function TBGRACustomLayeredBitmap.GetOriginalCount: integer;
     2139begin
     2140  result := 0;
     2141end;
     2142
     2143function TBGRACustomLayeredBitmap.GetOriginalByIndex(AIndex: integer): TBGRALayerCustomOriginal;
     2144begin
     2145  result := nil;
     2146  raise exception.Create('Not implemented');
     2147end;
     2148
     2149function TBGRACustomLayeredBitmap.GetOriginalByIndexKnown(AIndex: integer): boolean;
     2150begin
     2151  result := true;
     2152end;
     2153
     2154function TBGRACustomLayeredBitmap.GetLayerOriginal(layer: integer): TBGRALayerCustomOriginal;
     2155begin
     2156  result := nil;
     2157end;
     2158
     2159function TBGRACustomLayeredBitmap.GetLayerOriginalKnown(layer: integer): boolean;
     2160begin
     2161  result := true;
     2162end;
     2163
     2164function TBGRACustomLayeredBitmap.GetLayerOriginalMatrix(layer: integer): TAffineMatrix;
     2165begin
     2166  result := AffineMatrixIdentity;
    8392167end;
    8402168
     
    8432171  Unfreeze;
    8442172  FLinearBlend := AValue;
     2173end;
     2174
     2175procedure TBGRACustomLayeredBitmap.SetMemDirectory(AValue: TMemDirectory);
     2176begin
     2177  if AValue = FMemDirectory then exit;
     2178  if FMemDirectoryOwned then FMemDirectory.Free;
     2179  FMemDirectory := AValue;
     2180  FMemDirectoryOwned := false;
    8452181end;
    8462182
     
    9352271end;
    9362272
     2273function TBGRACustomLayeredBitmap.IndexOfOriginal(AGuid: TGuid): integer;
     2274begin
     2275  result := -1;
     2276end;
     2277
     2278function TBGRACustomLayeredBitmap.IndexOfOriginal(
     2279  AOriginal: TBGRALayerCustomOriginal): integer;
     2280begin
     2281  result := -1;
     2282end;
     2283
    9372284procedure TBGRACustomLayeredBitmap.SetWidth(Value: Integer);
    9382285begin
     
    9602307    temp: TBGRALayeredBitmap;
    9612308    i: integer;
     2309    stream: TFileStreamUTF8;
    9622310begin
    9632311  ext := UTF8LowerCase(ExtractFileExt(filenameUTF8));
     
    9752323    end;
    9762324
     2325  //when using "data" extension, simply serialize
     2326  if (ext='.dat') or (ext='.data') then
     2327  begin
     2328    if Assigned(LayeredBitmapLoadFromStreamProc) then
     2329    begin
     2330      stream := TFileStreamUTF8.Create(filenameUTF8, fmCreate);
     2331      try
     2332        LayeredBitmapSaveToStreamProc(stream, self);
     2333      finally
     2334        stream.Free;
     2335      end;
     2336    end else
     2337      raise exception.Create('Enable layer serialization by calling BGRAStreamLayers.RegisterStreamLayers');
     2338  end else
     2339  begin
     2340    bmp := ComputeFlatImage;
     2341    try
     2342      bmp.SaveToFileUTF8(filenameUTF8);
     2343    finally
     2344      bmp.Free;
     2345    end;
     2346  end;
     2347end;
     2348
     2349procedure TBGRACustomLayeredBitmap.SaveToStream(Stream: TStream);
     2350begin
     2351  if Assigned(LayeredBitmapSaveToStreamProc) then
     2352    LayeredBitmapSaveToStreamProc(Stream, self)
     2353  else
     2354    raise exception.Create('Call BGRAStreamLayers.RegisterStreamLayers first');
     2355end;
     2356
     2357procedure TBGRACustomLayeredBitmap.SaveToStreamAs(Stream: TStream;
     2358  AExtension: string);
     2359var bmp: TBGRABitmap;
     2360    ext: string;
     2361    format: TBGRAImageFormat;
     2362    temp: TBGRALayeredBitmap;
     2363    i: integer;
     2364begin
     2365  ext := UTF8LowerCase(AExtension);
     2366  if ext[1] <> '.' then ext := '.'+ext;
     2367
     2368  for i := 0 to high(LayeredBitmapWriters) do
     2369    if '.'+LayeredBitmapWriters[i].extension = ext then
     2370    begin
     2371      temp := LayeredBitmapWriters[i].theClass.Create;
     2372      try
     2373        temp.Assign(self);
     2374        temp.SaveToStream(Stream);
     2375      finally
     2376        temp.Free;
     2377      end;
     2378      exit;
     2379    end;
     2380
     2381  format := SuggestImageFormat(ext);
    9772382  bmp := ComputeFlatImage;
    9782383  try
    979     bmp.SaveToFileUTF8(filenameUTF8);
     2384    bmp.SaveToStreamAs(Stream, format);
    9802385  finally
    9812386    bmp.Free;
     
    9832388end;
    9842389
    985 procedure TBGRACustomLayeredBitmap.SaveToStream(Stream: TStream);
    986 begin
    987   if Assigned(LayeredBitmapSaveToStreamProc) then
    988     LayeredBitmapSaveToStreamProc(Stream, self)
    989   else
    990     raise exception.Create('Call BGRAStreamLayers.RegisterStreamLayers first');
    991 end;
    992 
    9932390constructor TBGRACustomLayeredBitmap.Create;
    9942391begin
    9952392  FFrozenRange := nil;
    9962393  FLinearBlend:= True;
     2394  FMemDirectory := nil;
     2395  FMemDirectoryOwned:= false;
    9972396end;
    9982397
     
    10102409end;
    10112410
    1012 function TBGRACustomLayeredBitmap.ComputeFlatImage: TBGRABitmap;
    1013 begin
    1014   result := ComputeFlatImage(rect(0,0,Width,Height), 0, NbLayers - 1);
     2411function TBGRACustomLayeredBitmap.ComputeFlatImage(ASeparateXorMask: boolean): TBGRABitmap;
     2412begin
     2413  result := ComputeFlatImage(rect(0,0,Width,Height), 0, NbLayers - 1, ASeparateXorMask);
    10152414end;
    10162415
    10172416function TBGRACustomLayeredBitmap.ComputeFlatImage(firstLayer,
    1018   lastLayer: integer): TBGRABitmap;
    1019 begin
    1020   result := ComputeFlatImage(rect(0,0,Width,Height), firstLayer,LastLayer);
    1021 end;
    1022 
    1023 function TBGRACustomLayeredBitmap.ComputeFlatImage(ARect: TRect): TBGRABitmap;
    1024 begin
    1025   result := ComputeFlatImage(ARect,0, NbLayers - 1);
     2417  lastLayer: integer; ASeparateXorMask: boolean): TBGRABitmap;
     2418begin
     2419  result := ComputeFlatImage(rect(0,0,Width,Height), firstLayer,LastLayer,ASeparateXorMask);
     2420end;
     2421
     2422function TBGRACustomLayeredBitmap.ComputeFlatImage(ARect: TRect;
     2423  ASeparateXorMask: boolean): TBGRABitmap;
     2424begin
     2425  result := ComputeFlatImage(ARect,0, NbLayers - 1, ASeparateXorMask);
    10262426end;
    10272427
     
    10312431end;
    10322432
    1033 function TBGRACustomLayeredBitmap.ComputeFlatImage(ARect: TRect; firstLayer, lastLayer: integer): TBGRABitmap;
     2433function TBGRACustomLayeredBitmap.ComputeFlatImage(ARect: TRect; firstLayer, lastLayer: integer; ASeparateXorMask: boolean): TBGRABitmap;
    10342434var
    10352435  tempLayer: TBGRABitmap;
     
    10382438  op: TBlendOperation;
    10392439begin
     2440  if (firstLayer < 0) or (lastLayer > NbLayers-1) then
     2441    raise ERangeError.Create('Layer index out of bounds');
    10402442  If (ARect.Right <= ARect.Left) or (ARect.Bottom <= ARect.Top) then
    10412443  begin
     
    10762478      begin
    10772479        op := BlendOperation[i];
     2480        //XOR mask
     2481        if (op = boXor) and ASeparateXorMask then
     2482        begin
     2483          result.NeedXorMask;
     2484          result.XorMask.BlendImageOver(x-ARect.Left,y-ARect.Top, tempLayer, op, LayerOpacity[i], LinearBlend);
     2485        end else
    10782486        //first layer is simply the background
    10792487        if i = firstLayer then
     
    10932501    inc(i);
    10942502  end;
     2503  if result.XorMask <> nil then
     2504    AlphaFillInline(result.XorMask.Data, 0, result.XorMask.NbPixels);
    10952505end;
    10962506
     
    11272537end;
    11282538
    1129 procedure TBGRACustomLayeredBitmap.Draw(Dest: TBGRABitmap; AX, AY: integer; firstLayer, lastLayer: integer);
     2539procedure TBGRACustomLayeredBitmap.Draw(Dest: TBGRABitmap; x, y: integer;
     2540  ASeparateXorMask: boolean);
     2541begin
     2542  Draw(Dest,x,y,0,NbLayers-1,ASeparateXorMask);
     2543end;
     2544
     2545procedure TBGRACustomLayeredBitmap.Draw(Dest: TBGRABitmap; AX, AY: integer; firstLayer, lastLayer: integer; ASeparateXorMask: boolean);
    11302546var
    11312547  temp: TBGRABitmap;
     
    11432559    if LayerVisible[i] and not (BlendOperation[i] in[boTransparent,boLinearBlend]) then
    11442560    begin
    1145       temp := ComputeFlatImage(rect(NewClipRect.Left-AX,NewClipRect.Top-AY,NewClipRect.Right-AX,NewClipRect.Bottom-AY));
     2561      temp := ComputeFlatImage(rect(NewClipRect.Left-AX,NewClipRect.Top-AY,NewClipRect.Right-AX,NewClipRect.Bottom-AY), ASeparateXorMask);
    11462562      if self.LinearBlend then
    11472563        Dest.PutImage(NewClipRect.Left,NewClipRect.Top,temp,dmLinearBlend)
     
    11702586    end;
    11712587    if LayerVisible[i] then
    1172     with LayerOffset[i] do
    11732588    begin
    11742589      tempLayer := GetLayerBitmapDirectly(i);
     
    11812596      end;
    11822597      if tempLayer <> nil then
     2598      with LayerOffset[i] do
    11832599      begin
    11842600        if (BlendOperation[i] = boTransparent) and not self.LinearBlend then //here it is specified not to use linear blending
    1185           Dest.PutImage(AX+x,AY+y,GetLayerBitmapDirectly(i),dmDrawWithTransparency, LayerOpacity[i])
     2601          Dest.PutImage(AX+x,AY+y,tempLayer,dmDrawWithTransparency, LayerOpacity[i])
    11862602        else
    1187           Dest.PutImage(AX+x,AY+y,GetLayerBitmapDirectly(i),dmLinearBlend, LayerOpacity[i]);
     2603          Dest.PutImage(AX+x,AY+y,tempLayer,dmLinearBlend, LayerOpacity[i]);
    11882604        if mustFreeCopy then tempLayer.Free;
    11892605      end;
     
    12942710end;
    12952711
     2712procedure TBGRACustomLayeredBitmap.NotifyLoaded;
     2713begin
     2714  //nothing
     2715end;
     2716
     2717procedure TBGRACustomLayeredBitmap.NotifySaving;
     2718begin
     2719  //nothing
     2720end;
     2721
    12962722procedure RegisterLayeredBitmapReader(AExtensionUTF8: string; AReader: TBGRACustomLayeredBitmapClass);
    12972723begin
     
    13022728    theClass := AReader;
    13032729  end;
     2730end;
     2731
     2732function TryCreateLayeredBitmapWriter(AExtensionUTF8: string): TBGRALayeredBitmap;
     2733var
     2734  i: Integer;
     2735begin
     2736  AExtensionUTF8:= UTF8LowerCase(AExtensionUTF8);
     2737  if (AExtensionUTF8 = '') or (AExtensionUTF8[1] <> '.') then
     2738    AExtensionUTF8:= '.'+AExtensionUTF8;
     2739  for i := 0 to high(LayeredBitmapWriters) do
     2740    if '.'+LayeredBitmapWriters[i].extension = AExtensionUTF8 then
     2741    begin
     2742      result := LayeredBitmapWriters[i].theClass.Create;
     2743      exit;
     2744    end;
     2745  result := nil;
     2746end;
     2747
     2748function TryCreateLayeredBitmapReader(AExtensionUTF8: string): TBGRACustomLayeredBitmap;
     2749var
     2750  i: Integer;
     2751begin
     2752  AExtensionUTF8:= UTF8LowerCase(AExtensionUTF8);
     2753  if (AExtensionUTF8 = '') or (AExtensionUTF8[1] <> '.') then
     2754    AExtensionUTF8:= '.'+AExtensionUTF8;
     2755  for i := 0 to high(LayeredBitmapReaders) do
     2756    if '.'+LayeredBitmapReaders[i].extension = AExtensionUTF8 then
     2757    begin
     2758      result := LayeredBitmapReaders[i].theClass.Create;
     2759      exit;
     2760    end;
     2761  result := nil;
    13042762end;
    13052763
  • GraphicTest/Packages/bgrabitmap/bgralazresource.pas

    r494 r521  
    2525    constructor Create(AContainer: TMultiFileContainer; AName: utf8string; AValueType: utf8string; AContent: TStream);
    2626    destructor Destroy; override;
    27     function CopyTo(ADestination: TStream): integer; override;
     27    function CopyTo(ADestination: TStream): int64; override;
    2828  end;
    2929
     
    3939    constructor Create(AContainer: TMultiFileContainer; AName: utf8string; ABinaryContent: TStream);
    4040    destructor Destroy; override;
    41     function CopyTo(ADestination: TStream): integer; override;
     41    function CopyTo(ADestination: TStream): int64; override;
    4242  end;
    4343
     
    9191end;
    9292
    93 function TFormDataEntry.CopyTo(ADestination: TStream): integer;
     93function TFormDataEntry.CopyTo(ADestination: TStream): int64;
    9494begin
    9595  RequireTextContent;
     
    149149end;
    150150
    151 function TLazResourceEntry.CopyTo(ADestination: TStream): integer;
     151function TLazResourceEntry.CopyTo(ADestination: TStream): int64;
    152152begin
    153153  if FContent.Size = 0 then
  • GraphicTest/Packages/bgrabitmap/bgralclbitmap.pas

    r494 r521  
    2121      ): TBGRAPtrBitmap; override;
    2222    procedure AssignRasterImage(ARaster: TRasterImage); virtual;
     23    procedure ExtractXorMask;
    2324  public
    2425    procedure Assign(Source: TPersistent); override;
     26    procedure LoadFromResource(AFilename: string; AOptions: TBGRALoadingOptions); overload; override;
    2527    procedure DataDrawTransparent(ACanvas: TCanvas; Rect: TRect;
    2628      AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); override;
    27     procedure DataDrawOpaque(ACanvas: TCanvas; Rect: TRect; AData: Pointer;
     29    procedure DataDrawOpaque(ACanvas: TCanvas; ARect: TRect; AData: Pointer;
    2830      ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); override;
    2931    procedure GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer); override;
    30     procedure LoadFromDevice({%H-}DC: System.THandle); override;
    31     procedure LoadFromDevice({%H-}DC: System.THandle; {%H-}ARect: TRect); override;
     32    procedure LoadFromDevice({%H-}DC: HDC); override;
     33    procedure LoadFromDevice({%H-}DC: HDC; {%H-}ARect: TRect); override;
    3234    procedure TakeScreenshotOfPrimaryMonitor; override;
    3335    procedure TakeScreenshot({%H-}ARect: TRect); override;
     
    5456implementation
    5557
    56 uses BGRAText, LCLType, LCLIntf, FPimage;
     58uses Types, BGRAText, LCLType, LCLIntf, FPimage;
    5759
    5860type
    5961  TCopyPixelProc = procedure (psrc: PByte; pdest: PBGRAPixel; count: NativeInt; sourcePixelSize: PtrInt; defaultOpacity: byte);
     62
     63procedure ApplyMask1bit(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; {%H-}sourcePixelSize: PtrInt; {%H-}defaultOpacity: byte);
     64var currentBit: byte;
     65begin
     66  currentBit := 1;
     67  while count > 0 do
     68  begin
     69    if psrc^ and currentBit <> 0 then pdest^.alpha := 0;
     70    inc(pdest);
     71    if currentBit = 128 then
     72    begin
     73      currentBit := 1;
     74      inc(psrc);
     75    end else
     76      currentBit := currentBit shl 1;
     77    dec(count);
     78  end;
     79end;
     80
     81procedure ApplyMask1bitRev(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; {%H-}sourcePixelSize: PtrInt; {%H-}defaultOpacity: byte);
     82var currentBit: byte;
     83begin
     84  currentBit := 128;
     85  while count > 0 do
     86  begin
     87    if psrc^ and currentBit <> 0 then pdest^.alpha := 0;
     88    inc(pdest);
     89    if currentBit = 1 then
     90    begin
     91      currentBit := 128;
     92      inc(psrc);
     93    end else
     94      currentBit := currentBit shr 1;
     95    dec(count);
     96  end;
     97end;
     98
     99procedure CopyFromBW_SetAlpha(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; {%H-}sourcePixelSize: PtrInt; defaultOpacity: byte);
     100var currentBit: byte;
     101begin
     102  currentBit := 1;
     103  while count > 0 do
     104  begin
     105    if psrc^ and currentBit <> 0 then
     106      pdest^ := BGRAWhite
     107    else
     108      pdest^ := BGRABlack;
     109    pdest^.alpha := DefaultOpacity;
     110    inc(pdest);
     111    if currentBit = 128 then
     112    begin
     113      currentBit := 1;
     114      inc(psrc);
     115    end else
     116      currentBit := currentBit shl 1;
     117    dec(count);
     118  end;
     119end;
     120
     121procedure CopyFromBW_SetAlphaBitRev(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; {%H-}sourcePixelSize: PtrInt; defaultOpacity: byte);
     122var currentBit: byte;
     123begin
     124  currentBit := 128;
     125  while count > 0 do
     126  begin
     127    if psrc^ and currentBit <> 0 then
     128      pdest^ := BGRAWhite
     129    else
     130      pdest^ := BGRABlack;
     131    pdest^.alpha := DefaultOpacity;
     132    inc(pdest);
     133    if currentBit = 1 then
     134    begin
     135      currentBit := 128;
     136      inc(psrc);
     137    end else
     138      currentBit := currentBit shr 1;
     139    dec(count);
     140  end;
     141end;
    60142
    61143procedure CopyFrom24Bit(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; sourcePixelSize: PtrInt; defaultOpacity: byte);
     
    255337end;
    256338
    257 { Load raw image data. It must be 32bit or 24 bits per pixel}
    258 function LoadFromRawImageImplementation(ADestination: TBGRADefaultBitmap; ARawImage: TRawImage;
    259   DefaultOpacity: byte; AlwaysReplaceAlpha: boolean; RaiseErrorOnInvalidPixelFormat: boolean): boolean;
    260 var
     339procedure DoCopyProc(ADestination: TBGRACustomBitmap; ACopyProc: TCopyPixelProc; AData: PByte; ABytesPerLine, ABitsPerPixel: integer; ALineOrder: TRawImageLineOrder; ADefaultOpacity: byte);
     340var
     341  n: integer;
    261342  psource_byte, pdest_byte,
    262343  psource_first, pdest_first: PByte;
    263344  psource_delta, pdest_delta: integer;
    264 
    265   n: integer;
     345begin
     346  if (ALineOrder = ADestination.LineOrder) and
     347    (ABytesPerLine = (ABitsPerPixel shr 3) * cardinal(ADestination.Width)) then
     348    ACopyProc(AData, ADestination.Data, ADestination.NbPixels, ABitsPerPixel shr 3, ADefaultOpacity)
     349  else
     350  begin
     351    if ALineOrder = riloTopToBottom then
     352    begin
     353      psource_first := AData;
     354      psource_delta := ABytesPerLine;
     355    end else
     356    begin
     357      psource_first := AData + (ADestination.Height-1) * ABytesPerLine;
     358      psource_delta := -ABytesPerLine;
     359    end;
     360
     361    if ADestination.LineOrder = riloTopToBottom then
     362    begin
     363      pdest_first := PByte(ADestination.Data);
     364      pdest_delta := ADestination.Width*sizeof(TBGRAPixel);
     365    end else
     366    begin
     367      pdest_first := PByte(ADestination.Data) + (ADestination.Height-1)*ADestination.Width*sizeof(TBGRAPixel);
     368      pdest_delta := -ADestination.Width*sizeof(TBGRAPixel);
     369    end;
     370
     371    psource_byte := psource_first;
     372    pdest_byte := pdest_first;
     373    for n := ADestination.Height-1 downto 0 do
     374    begin
     375      ACopyProc(psource_byte, PBGRAPixel(pdest_byte), ADestination.Width, ABitsPerPixel shr 3, ADefaultOpacity);
     376      inc(psource_byte, psource_delta);
     377      inc(pdest_byte, pdest_delta);
     378    end;
     379  end;
     380end;
     381
     382procedure ApplyRawImageMask(ADestination: TBGRACustomBitmap; const ARawImage: TRawImage);
     383var
     384  copyProc: TCopyPixelProc;
     385begin
     386  if (ARawImage.Description.MaskBitsPerPixel = 1) and (ARawImage.Mask <> nil) then
     387  begin
     388    if ARawImage.Description.BitOrder = riboBitsInOrder then
     389      copyProc := @ApplyMask1bit
     390    else
     391      copyProc := @ApplyMask1bitRev;
     392    DoCopyProc(ADestination, copyProc, ARawImage.Mask, ARawImage.Description.MaskBytesPerLine, ARawImage.Description.MaskBitsPerPixel, ARawImage.Description.LineOrder, 0);
     393    ADestination.InvalidateBitmap;
     394  end;
     395end;
     396
     397{ Load raw image data. It must be 32bit, 24 bits or 1bit per pixel}
     398function LoadFromRawImageImplementation(ADestination: TBGRADefaultBitmap; const ARawImage: TRawImage;
     399  DefaultOpacity: byte; AlwaysReplaceAlpha: boolean; RaiseErrorOnInvalidPixelFormat: boolean): boolean;
     400var
    266401  mustSwapRedBlue: boolean;
    267402  copyProc: TCopyPixelProc;
     
    287422  end;
    288423
    289   if ((ARawImage.Description.BitsPerPixel and 7) <> 0) then
    290   begin
    291     result := FormatError(IntToStr(ARawImage.Description.Depth) + 'bit found but multiple of 8bit expected');
    292     exit;
    293   end;
    294 
    295   if (ARawImage.Description.BitsPerPixel < 24) then
    296   begin
    297     result := FormatError(IntToStr(ARawImage.Description.Depth) + 'bit found but at least 24bit expected');
    298     exit;
    299   end;
    300 
    301   nbColorChannels := 0;
    302   if (ARawImage.Description.RedPrec > 0)  then inc(nbColorChannels);
    303   if (ARawImage.Description.GreenPrec > 0)  then inc(nbColorChannels);
    304   if (ARawImage.Description.BluePrec > 0)  then inc(nbColorChannels);
    305 
    306   if (nbColorChannels < 3) then
    307   begin
    308     result := FormatError('One or more color channel is missing (RGB expected)');
    309     exit;
    310   end;
    311 
    312   //channels are in ARGB order
    313   if (ARawImage.Description.BitsPerPixel >= 32) and
    314      (ARawImage.Description.AlphaPrec = 8) and
    315     (((ARawImage.Description.AlphaShift = 0) and
    316     (ARawImage.Description.RedShift = 8) and
    317     (ARawImage.Description.GreenShift = 16) and
    318     (ARawImage.Description.BlueShift = 24) and
    319     (ARawImage.Description.ByteOrder = riboLSBFirst)) or
    320     ((ARawImage.Description.AlphaShift = ARawImage.Description.BitsPerPixel - 8) and
    321     (ARawImage.Description.RedShift = ARawImage.Description.BitsPerPixel - 16) and
    322     (ARawImage.Description.GreenShift = ARawImage.Description.BitsPerPixel - 24) and
    323     (ARawImage.Description.BlueShift = ARawImage.Description.BitsPerPixel - 32) and
    324     (ARawImage.Description.ByteOrder = riboMSBFirst))) then
    325     begin
    326       if AlwaysReplaceAlpha then
    327         copyProc := @CopyFromARGB_SetAlpha
    328       else if DefaultOpacity = 0 then
    329         copyProc := @CopyFromARGB_KeepAlpha
     424  if ARawImage.Description.BitsPerPixel = 1 then
     425  begin
     426    if ARawImage.Description.BitOrder = riboBitsInOrder then
     427      copyProc := @CopyFromBW_SetAlpha
     428    else
     429      copyProc := @CopyFromBW_SetAlphaBitRev;
     430    DefaultOpacity := 255;
     431  end else
     432  begin
     433    if ((ARawImage.Description.BitsPerPixel and 7) <> 0) then
     434    begin
     435      result := FormatError(IntToStr(ARawImage.Description.Depth) + 'bit found but multiple of 8bit expected');
     436      exit;
     437    end;
     438
     439    if (ARawImage.Description.BitsPerPixel < 24) then
     440    begin
     441      result := FormatError(IntToStr(ARawImage.Description.Depth) + 'bit found but at least 24bit expected');
     442      exit;
     443    end;
     444
     445    nbColorChannels := 0;
     446    if (ARawImage.Description.RedPrec > 0)  then inc(nbColorChannels);
     447    if (ARawImage.Description.GreenPrec > 0)  then inc(nbColorChannels);
     448    if (ARawImage.Description.BluePrec > 0)  then inc(nbColorChannels);
     449
     450    if (nbColorChannels < 3) then
     451    begin
     452      result := FormatError('One or more color channel is missing (RGB expected)');
     453      exit;
     454    end;
     455
     456    //channels are in ARGB order
     457    if (ARawImage.Description.BitsPerPixel >= 32) and
     458       (ARawImage.Description.AlphaPrec = 8) and
     459      (((ARawImage.Description.AlphaShift = 0) and
     460      (ARawImage.Description.RedShift = 8) and
     461      (ARawImage.Description.GreenShift = 16) and
     462      (ARawImage.Description.BlueShift = 24) and
     463      (ARawImage.Description.ByteOrder = riboLSBFirst)) or
     464      ((ARawImage.Description.AlphaShift = ARawImage.Description.BitsPerPixel - 8) and
     465      (ARawImage.Description.RedShift = ARawImage.Description.BitsPerPixel - 16) and
     466      (ARawImage.Description.GreenShift = ARawImage.Description.BitsPerPixel - 24) and
     467      (ARawImage.Description.BlueShift = ARawImage.Description.BitsPerPixel - 32) and
     468      (ARawImage.Description.ByteOrder = riboMSBFirst))) then
     469      begin
     470        if AlwaysReplaceAlpha then
     471          copyProc := @CopyFromARGB_SetAlpha
     472        else if DefaultOpacity = 0 then
     473          copyProc := @CopyFromARGB_KeepAlpha
     474        else
     475          copyProc := @CopyFromARGB_ReplaceZeroAlpha;
     476      end
     477    else //channels are in ARGB order but alpha is not used
     478    if (ARawImage.Description.BitsPerPixel >= 32) and
     479       (ARawImage.Description.AlphaPrec = 0) and
     480      (((ARawImage.Description.RedShift = 8) and
     481      (ARawImage.Description.GreenShift = 16) and
     482      (ARawImage.Description.BlueShift = 24) and
     483      (ARawImage.Description.ByteOrder = riboLSBFirst)) or
     484      ((ARawImage.Description.RedShift = ARawImage.Description.BitsPerPixel - 16) and
     485      (ARawImage.Description.GreenShift = ARawImage.Description.BitsPerPixel - 24) and
     486      (ARawImage.Description.BlueShift = ARawImage.Description.BitsPerPixel - 32) and
     487      (ARawImage.Description.ByteOrder = riboMSBFirst))) then
     488      begin
     489        DefaultOpacity := 255;
     490        copyProc := @CopyFromARGB_SetAlpha;
     491      end
     492    else
     493    begin
     494      //channels are in RGB order (alpha channel may follow)
     495      if (ARawImage.Description.BitsPerPixel >= 24) and
     496         (((ARawImage.Description.RedShift = 0) and
     497           (ARawImage.Description.GreenShift = 8) and
     498           (ARawImage.Description.BlueShift = 16) and
     499           (ARawImage.Description.ByteOrder = riboLSBFirst)) or
     500          ((ARawImage.Description.RedShift = ARawImage.Description.BitsPerPixel - 8) and
     501           (ARawImage.Description.GreenShift = ARawImage.Description.BitsPerPixel - 16) and
     502           (ARawImage.Description.BlueShift = ARawImage.Description.BitsPerPixel - 24) and
     503           (ARawImage.Description.ByteOrder = riboMSBFirst))) then
     504      begin
     505        mustSwapRedBlue:= not TBGRAPixel_RGBAOrder;
     506      end
    330507      else
    331         copyProc := @CopyFromARGB_ReplaceZeroAlpha;
    332     end
    333   else //channels are in ARGB order but alpha is not used
    334   if (ARawImage.Description.BitsPerPixel >= 32) and
    335      (ARawImage.Description.AlphaPrec = 0) and
    336     (((ARawImage.Description.RedShift = 8) and
    337     (ARawImage.Description.GreenShift = 16) and
    338     (ARawImage.Description.BlueShift = 24) and
    339     (ARawImage.Description.ByteOrder = riboLSBFirst)) or
    340     ((ARawImage.Description.RedShift = ARawImage.Description.BitsPerPixel - 16) and
    341     (ARawImage.Description.GreenShift = ARawImage.Description.BitsPerPixel - 24) and
    342     (ARawImage.Description.BlueShift = ARawImage.Description.BitsPerPixel - 32) and
    343     (ARawImage.Description.ByteOrder = riboMSBFirst))) then
    344     begin
    345       DefaultOpacity := 255;
    346       copyProc := @CopyFromARGB_SetAlpha;
    347     end
    348   else
    349   begin
    350     //channels are in RGB order (alpha channel may follow)
    351     if (ARawImage.Description.BitsPerPixel >= 24) and
    352        (((ARawImage.Description.RedShift = 0) and
    353          (ARawImage.Description.GreenShift = 8) and
    354          (ARawImage.Description.BlueShift = 16) and
    355          (ARawImage.Description.ByteOrder = riboLSBFirst)) or
    356         ((ARawImage.Description.RedShift = ARawImage.Description.BitsPerPixel - 8) and
    357          (ARawImage.Description.GreenShift = ARawImage.Description.BitsPerPixel - 16) and
    358          (ARawImage.Description.BlueShift = ARawImage.Description.BitsPerPixel - 24) and
    359          (ARawImage.Description.ByteOrder = riboMSBFirst))) then
    360     begin
    361       mustSwapRedBlue:= not TBGRAPixel_RGBAOrder;
    362     end
    363     else
    364     //channels are in BGR order (alpha channel may follow)
    365     if (ARawImage.Description.BitsPerPixel >= 24) and
    366        (((ARawImage.Description.BlueShift = 0) and
    367          (ARawImage.Description.GreenShift = 8) and
    368          (ARawImage.Description.RedShift = 16) and
    369          (ARawImage.Description.ByteOrder = riboLSBFirst)) or
    370         ((ARawImage.Description.BlueShift = ARawImage.Description.BitsPerPixel - 8) and
    371          (ARawImage.Description.GreenShift = ARawImage.Description.BitsPerPixel - 16) and
    372          (ARawImage.Description.RedShift = ARawImage.Description.BitsPerPixel - 24) and
    373          (ARawImage.Description.ByteOrder = riboMSBFirst))) then
    374     begin
    375       mustSwapRedBlue:= TBGRAPixel_RGBAOrder;
    376     end
    377     else
    378     begin
    379       result := FormatError('BitsPerPixel: ' + IntToStr(ARawImage.Description.BitsPerPixel) + ', '
    380         + 'RedShit: ' + IntToStr(ARawImage.Description.RedShift) + ', Prec: ' + IntToStr(ARawImage.Description.RedPrec)+ ', '
    381         + 'GreenShit: ' + IntToStr(ARawImage.Description.GreenShift) + ', Prec: ' + IntToStr(ARawImage.Description.GreenPrec)+ ', '
    382         + 'BlueShift: ' + IntToStr(ARawImage.Description.BlueShift) + ', Prec: ' + IntToStr(ARawImage.Description.BluePrec)+ ', '
    383         + 'AlphaShift: ' + IntToStr(ARawImage.Description.AlphaShift) + ', Prec: ' + IntToStr(ARawImage.Description.AlphaPrec) );
    384       exit;
    385     end;
    386 
    387     if not mustSwapRedBlue then
    388     begin
    389       if ARawImage.Description.BitsPerPixel = 24 then
    390         copyProc := @CopyFrom24Bit
     508      //channels are in BGR order (alpha channel may follow)
     509      if (ARawImage.Description.BitsPerPixel >= 24) and
     510         (((ARawImage.Description.BlueShift = 0) and
     511           (ARawImage.Description.GreenShift = 8) and
     512           (ARawImage.Description.RedShift = 16) and
     513           (ARawImage.Description.ByteOrder = riboLSBFirst)) or
     514          ((ARawImage.Description.BlueShift = ARawImage.Description.BitsPerPixel - 8) and
     515           (ARawImage.Description.GreenShift = ARawImage.Description.BitsPerPixel - 16) and
     516           (ARawImage.Description.RedShift = ARawImage.Description.BitsPerPixel - 24) and
     517           (ARawImage.Description.ByteOrder = riboMSBFirst))) then
     518      begin
     519        mustSwapRedBlue:= TBGRAPixel_RGBAOrder;
     520      end
    391521      else
    392       if AlwaysReplaceAlpha or (ARawImage.Description.AlphaPrec = 0) then
    393         copyProc := @CopyFrom32Bit_SetAlpha
    394       else if DefaultOpacity = 0 then
    395         copyProc := @CopyFrom32Bit_KeepAlpha
    396       else
    397         copyProc := @CopyFrom32Bit_ReplaceZeroAlpha;
    398     end else
    399     begin
    400       if ARawImage.Description.BitsPerPixel = 24 then
    401         copyProc := @CopyFrom24Bit_SwapRedBlue
    402       else
    403       if AlwaysReplaceAlpha or (ARawImage.Description.AlphaPrec = 0) then
    404         copyProc := @CopyFrom32Bit_SwapRedBlue_SetAlpha
    405       else if DefaultOpacity = 0 then
    406         copyProc := @CopyFrom32Bit_SwapRedBlue_KeepAlpha
    407       else
    408         copyProc := @CopyFrom32Bit_SwapRedBlue_ReplaceZeroAlpha;
    409     end;
    410   end;
    411 
    412   if (ARawImage.Description.LineOrder = ADestination.LineOrder) and
    413     (ARawImage.Description.BytesPerLine = (ARawImage.Description.BitsPerPixel shr 3) * cardinal(ADestination.Width)) then
    414     copyProc(ARawImage.Data, ADestination.Data, ADestination.NbPixels, ARawImage.Description.BitsPerPixel shr 3, DefaultOpacity)
    415   else
    416   begin
    417     if ARawImage.Description.LineOrder = riloTopToBottom then
    418     begin
    419       psource_first := ARawImage.Data;
    420       psource_delta := ARawImage.Description.BytesPerLine;
    421     end else
    422     begin
    423       psource_first := ARawImage.Data + (ARawImage.Description.Height-1) * ARawImage.Description.BytesPerLine;
    424       psource_delta := -ARawImage.Description.BytesPerLine;
    425     end;
    426 
    427     if ADestination.LineOrder = riloTopToBottom then
    428     begin
    429       pdest_first := PByte(ADestination.Data);
    430       pdest_delta := ADestination.Width*sizeof(TBGRAPixel);
    431     end else
    432     begin
    433       pdest_first := PByte(ADestination.Data) + (ADestination.Height-1)*ADestination.Width*sizeof(TBGRAPixel);
    434       pdest_delta := -ADestination.Width*sizeof(TBGRAPixel);
    435     end;
    436 
    437     psource_byte := psource_first;
    438     pdest_byte := pdest_first;
    439     for n := ADestination.Height-1 downto 0 do
    440     begin
    441       copyProc(psource_byte, PBGRAPixel(pdest_byte), ADestination.Width, ARawImage.Description.BitsPerPixel shr 3, DefaultOpacity);
    442       inc(psource_byte, psource_delta);
    443       inc(pdest_byte, pdest_delta);
    444     end;
    445   end;
    446 
     522      begin
     523        result := FormatError('BitsPerPixel: ' + IntToStr(ARawImage.Description.BitsPerPixel) + ', '
     524          + 'RedShit: ' + IntToStr(ARawImage.Description.RedShift) + ', Prec: ' + IntToStr(ARawImage.Description.RedPrec)+ ', '
     525          + 'GreenShit: ' + IntToStr(ARawImage.Description.GreenShift) + ', Prec: ' + IntToStr(ARawImage.Description.GreenPrec)+ ', '
     526          + 'BlueShift: ' + IntToStr(ARawImage.Description.BlueShift) + ', Prec: ' + IntToStr(ARawImage.Description.BluePrec)+ ', '
     527          + 'AlphaShift: ' + IntToStr(ARawImage.Description.AlphaShift) + ', Prec: ' + IntToStr(ARawImage.Description.AlphaPrec) );
     528        exit;
     529      end;
     530
     531      if not mustSwapRedBlue then
     532      begin
     533        if ARawImage.Description.BitsPerPixel = 24 then
     534          copyProc := @CopyFrom24Bit
     535        else
     536        if AlwaysReplaceAlpha or (ARawImage.Description.AlphaPrec = 0) then
     537          copyProc := @CopyFrom32Bit_SetAlpha
     538        else if DefaultOpacity = 0 then
     539          copyProc := @CopyFrom32Bit_KeepAlpha
     540        else
     541          copyProc := @CopyFrom32Bit_ReplaceZeroAlpha;
     542      end else
     543      begin
     544        if ARawImage.Description.BitsPerPixel = 24 then
     545          copyProc := @CopyFrom24Bit_SwapRedBlue
     546        else
     547        if AlwaysReplaceAlpha or (ARawImage.Description.AlphaPrec = 0) then
     548          copyProc := @CopyFrom32Bit_SwapRedBlue_SetAlpha
     549        else if DefaultOpacity = 0 then
     550          copyProc := @CopyFrom32Bit_SwapRedBlue_KeepAlpha
     551        else
     552          copyProc := @CopyFrom32Bit_SwapRedBlue_ReplaceZeroAlpha;
     553      end;
     554    end;
     555  end;
     556
     557  DoCopyProc(ADestination, copyProc, ARawImage.Data, ARawImage.Description.BytesPerLine, ARawImage.Description.BitsPerPixel, ARawImage.Description.LineOrder, DefaultOpacity);
    447558  ADestination.InvalidateBitmap;
     559
     560  ApplyRawImageMask(ADestination, ARawImage);
    448561  result := true;
    449562end;
     
    635748begin
    636749  if FBitmap <> nil then
     750  begin
    637751    LoadFromRawImage(FBitmap.RawImage, FCanvasOpacity);
     752    if FAlphaCorrectionNeeded then DoAlphaCorrection;
     753  end;
    638754end;
    639755
     
    666782  FBitmap.Canvas.AntialiasingMode := amOff;
    667783  FBitmapModified := False;
     784  FAlphaCorrectionNeeded:= false;
    668785end;
    669786
     
    681798  end else
    682799    inherited Assign(Source);
     800
     801  if Source is TCursorImage then
     802  begin
     803    HotSpot := TCursorImage(Source).HotSpot;
     804    ExtractXorMask;
     805  end
     806  else if Source is TIcon then
     807  begin
     808    HotSpot := Point(0,0);
     809    ExtractXorMask;
     810  end;
     811end;
     812
     813procedure TBGRALCLBitmap.LoadFromResource(AFilename: string;
     814  AOptions: TBGRALoadingOptions);
     815var
     816  icon: TCustomIcon;
     817  ext: String;
     818begin
     819  if BGRAResource.IsWinResource(AFilename) then
     820  begin
     821    ext:= Uppercase(ExtractFileExt(AFilename));
     822    if (ext = '.ICO') or (ext = '.CUR') then
     823    begin
     824      if ext= '.ICO' then icon := TIcon.Create
     825      else icon := TCursorImage.Create;
     826      try
     827        icon.LoadFromResourceName(HInstance, ChangeFileExt(AFilename,''));
     828        icon.Current:= icon.GetBestIndexForSize(Size(65536,65536));
     829        self.AssignRasterImage(icon);
     830      finally
     831        icon.Free;
     832      end;
     833      exit;
     834    end;
     835  end;
     836
     837  inherited LoadFromResource(AFilename, AOptions);
    683838end;
    684839
     
    688843  DiscardBitmapChange;
    689844  SetSize(ARaster.Width, ARaster.Height);
    690   if not LoadFromRawImage(ARaster.RawImage,0,False,False) then
    691   if ARaster is TBitmap then
     845  if LoadFromRawImage(ARaster.RawImage,0,False,False) then
     846  begin
     847    If Empty then
     848    begin
     849      AlphaFill(255); // if bitmap seems to be empty, assume
     850                      // it is an opaque bitmap without alpha channel
     851      ApplyRawImageMask(self, ARaster.RawImage);
     852    end;
     853  end else
     854  if (ARaster is TBitmap) or (ARaster is TCustomIcon) then
    692855  begin //try to convert
    693856    TempBmp := TBitmap.Create;
     
    696859    TempBmp.Canvas.Draw(0,0,ARaster);
    697860    try
    698       LoadFromRawImage(TempBmp.RawImage,0,False,true);
     861      LoadFromRawImage(TempBmp.RawImage,255,False,true);
     862      ApplyRawImageMask(self, ARaster.RawImage);
    699863    finally
    700864      TempBmp.Free;
     
    702866  end else
    703867    raise Exception.Create('Unable to convert image to 24 bit');
    704   If Empty then AlphaFill(255); // if bitmap seems to be empty, assume
    705                                 // it is an opaque bitmap without alpha channel
     868end;
     869
     870procedure TBGRALCLBitmap.ExtractXorMask;
     871var
     872  y, x: Integer;
     873  p: PBGRAPixel;
     874begin
     875  DiscardXorMask;
     876  for y := 0 to Height-1 do
     877  begin
     878    p := ScanLine[y];
     879    for x := 0 to Width-1 do
     880    begin
     881      if (p^.alpha = 0) and (PDWord(p)^<>0) then
     882      begin
     883        NeedXorMask;
     884        XorMask.SetPixel(x,y, p^);
     885      end;
     886      inc(p);
     887    end;
     888  end;
    706889end;
    707890
     
    712895end;
    713896
    714 procedure TBGRALCLBitmap.DataDrawOpaque(ACanvas: TCanvas; Rect: TRect;
     897procedure TBGRALCLBitmap.DataDrawOpaque(ACanvas: TCanvas; ARect: TRect;
    715898  AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
    716899begin
    717   DataDrawOpaqueImplementation(ACanvas, Rect, AData, ALineOrder, AWidth, AHeight);
     900  DataDrawOpaqueImplementation(ACanvas, ARect, AData, ALineOrder, AWidth, AHeight);
    718901end;
    719902
     
    725908end;
    726909
    727 procedure TBGRALCLBitmap.LoadFromDevice(DC: System.THandle);
     910procedure TBGRALCLBitmap.LoadFromDevice(DC: HDC);
    728911var
    729912  rawImage: TRawImage;
     
    747930end;
    748931
    749 procedure TBGRALCLBitmap.LoadFromDevice(DC: System.THandle; ARect: TRect);
     932procedure TBGRALCLBitmap.LoadFromDevice(DC: HDC; ARect: TRect);
    750933var
    751934  rawImage: TRawImage;
  • GraphicTest/Packages/bgrabitmap/bgramatrix3d.pas

    r494 r521  
    434434
    435435operator*(constref A: TMatrix3D; var M: TPoint3D_128): TPoint3D_128;
    436 {$IFDEF BGRASSE_AVAILABLE}var oldMt: single; {$ENDIF}
     436{$IFDEF BGRASSE_AVAILABLE}var oldMt: single; resultAddr: pointer;{$ENDIF}
    437437begin
    438438  {$IFDEF BGRASSE_AVAILABLE}
     
    441441    oldMt := M.t;
    442442    M.t := SingleConst1;
     443    resultAddr := @result;
     444    {$IFDEF cpux86_64}
    443445    if UseSSE3 then
    444446    asm
    445       mov eax, A
    446       movups xmm5, [eax]
    447       movups xmm6, [eax+16]
    448       movups xmm7, [eax+32]
    449 
    450       mov eax, M
    451       movups xmm0, [eax]
    452 
    453       mov eax, result
     447      mov rax, A
     448      movups xmm5, [rax]
     449      movups xmm6, [rax+16]
     450      movups xmm7, [rax+32]
     451
     452      mov rax, M
     453      movups xmm0, [rax]
     454
     455      mov rax, resultAddr
    454456
    455457      movaps xmm4,xmm0
     
    457459      haddps xmm4,xmm4
    458460      haddps xmm4,xmm4
    459       movss [eax], xmm4
     461      movss [rax], xmm4
    460462
    461463      movaps xmm4,xmm0
     
    463465      haddps xmm4,xmm4
    464466      haddps xmm4,xmm4
    465       movss [eax+4], xmm4
     467      movss [rax+4], xmm4
    466468
    467469      mulps xmm0,xmm7
    468470      haddps xmm0,xmm0
    469471      haddps xmm0,xmm0
    470       movss [eax+8], xmm0
     472      movss [rax+8], xmm0
    471473    end else
    472474    asm
    473       mov eax, A
    474       movups xmm5, [eax]
    475       movups xmm6, [eax+16]
    476       movups xmm7, [eax+32]
    477 
    478       mov eax, M
    479       movups xmm0, [eax]
    480 
    481       mov eax, result
     475      mov rax, A
     476      movups xmm5, [rax]
     477      movups xmm6, [rax+16]
     478      movups xmm7, [rax+32]
     479
     480      mov rax, M
     481      movups xmm0, [rax]
     482
     483      mov rax, resultAddr
    482484
    483485      movaps xmm4,xmm0
     
    492494      addps xmm4, xmm3
    493495
    494       movss [eax], xmm4
     496      movss [rax], xmm4
    495497
    496498      movaps xmm4,xmm0
     
    505507      addps xmm4, xmm3
    506508
    507       movss [eax+4], xmm4
     509      movss [rax+4], xmm4
    508510
    509511      mulps xmm0,xmm7
     
    517519      addps xmm0, xmm3
    518520
     521      movss [rax+8], xmm0
     522    end;
     523    {$ELSE}
     524    if UseSSE3 then
     525    asm
     526      mov eax, A
     527      movups xmm5, [eax]
     528      movups xmm6, [eax+16]
     529      movups xmm7, [eax+32]
     530
     531      mov eax, M
     532      movups xmm0, [eax]
     533
     534      mov eax, resultAddr
     535
     536      movaps xmm4,xmm0
     537      mulps xmm4,xmm5
     538      haddps xmm4,xmm4
     539      haddps xmm4,xmm4
     540      movss [eax], xmm4
     541
     542      movaps xmm4,xmm0
     543      mulps xmm4,xmm6
     544      haddps xmm4,xmm4
     545      haddps xmm4,xmm4
     546      movss [eax+4], xmm4
     547
     548      mulps xmm0,xmm7
     549      haddps xmm0,xmm0
     550      haddps xmm0,xmm0
     551      movss [eax+8], xmm0
     552    end else
     553    asm
     554      mov eax, A
     555      movups xmm5, [eax]
     556      movups xmm6, [eax+16]
     557      movups xmm7, [eax+32]
     558
     559      mov eax, M
     560      movups xmm0, [eax]
     561
     562      mov eax, resultAddr
     563
     564      movaps xmm4,xmm0
     565      mulps xmm4,xmm5
     566      //mix1
     567      movaps xmm3, xmm4
     568      shufps xmm3, xmm3, $4e
     569      addps xmm4, xmm3
     570      //mix2
     571      movaps xmm3, xmm4
     572      shufps xmm3, xmm3, $11
     573      addps xmm4, xmm3
     574
     575      movss [eax], xmm4
     576
     577      movaps xmm4,xmm0
     578      mulps xmm4,xmm6
     579      //mix1
     580      movaps xmm3, xmm4
     581      shufps xmm3, xmm3, $4e
     582      addps xmm4, xmm3
     583      //mix2
     584      movaps xmm3, xmm4
     585      shufps xmm3, xmm3, $11
     586      addps xmm4, xmm3
     587
     588      movss [eax+4], xmm4
     589
     590      mulps xmm0,xmm7
     591      //mix1
     592      movaps xmm3, xmm0
     593      shufps xmm3, xmm3, $4e
     594      addps xmm0, xmm3
     595      //mix2
     596      movaps xmm3, xmm0
     597      shufps xmm3, xmm3, $11
     598      addps xmm0, xmm3
     599
    519600      movss [eax+8], xmm0
    520601    end;
     602    {$ENDIF}
    521603    M.t := oldMt;
    522604    result.t := 0;
  • GraphicTest/Packages/bgrabitmap/bgramultifiletype.pas

    r494 r521  
    22
    33{$mode objfpc}{$H+}
     4{$MODESWITCH ADVANCEDRECORDS}
    45
    56interface
     
    78uses
    89  Classes, SysUtils, fgl;
     10
     11type
     12
     13  { TEntryFilename }
     14
     15  TEntryFilename = record
     16  private
     17    FExtension: utf8string;
     18    FName: utf8string;
     19    function GetFilename: utf8string;
     20    function GetIsEmpty: boolean;
     21    procedure SetExtension(AValue: utf8string);
     22    procedure SetFilename(AValue: utf8string);
     23    procedure SetName(AValue: utf8string);
     24  public
     25    class operator =(const AValue1,AValue2: TEntryFilename): boolean;
     26    property Filename: utf8string read GetFilename write SetFilename;
     27    property Name: utf8string read FName write SetName;
     28    property Extension: utf8string read FExtension write SetExtension;
     29    property IsEmpty: boolean read GetIsEmpty;
     30  end;
     31
     32function EntryFilename(AName,AExtension: string): TEntryFilename; overload;
     33function EntryFilename(AFilename: string): TEntryFilename; overload;
    934
    1035type
     
    2247  public
    2348    constructor Create(AContainer: TMultiFileContainer);
    24     function CopyTo({%H-}ADestination: TStream): integer; virtual;
     49    function CopyTo({%H-}ADestination: TStream): int64; virtual;
    2550    property Name: utf8string read GetName write SetName;
    2651    property Extension: utf8string read GetExtension;
     
    3863  protected
    3964    procedure Init; virtual;
    40     function AddEntry(AEntry: TMultiFileEntry): integer;
     65    function AddEntry(AEntry: TMultiFileEntry; AIndex: integer = -1): integer;
    4166    function GetCount: integer;
    4267    function GetEntry(AIndex: integer): TMultiFileEntry;
    4368    function CreateEntry(AName: utf8string; AExtension: utf8string; AContent: TStream): TMultiFileEntry; virtual; abstract;
     69    function GetRawString(AIndex: integer): RawByteString;
     70    function GetRawStringByFilename(AFilename: string): RawByteString;
     71    procedure SetRawString(AIndex: integer; AValue: RawByteString);
     72    procedure SetRawStringByFilename(AFilename: string; AValue: RawByteString);
    4473  public
    45     constructor Create;
    46     constructor Create(AFilename: utf8string);
    47     constructor Create(AStream: TStream);
    48     constructor Create(AStream: TStream; AStartPos: Int64);
    49     function Add(AName: utf8string; AExtension: utf8string; AContent: TStream; AOverwrite: boolean = false; AOwnStream: boolean = true): integer;
    50     function Add(AName: utf8string; AExtension: utf8string; AContent: utf8String; AOverwrite: boolean = false): integer;
     74    constructor Create; overload;
     75    constructor Create(AFilename: utf8string); overload;
     76    constructor Create(AStream: TStream); overload;
     77    constructor Create(AStream: TStream; AStartPos: Int64); overload;
     78    function Add(AName: utf8string; AExtension: utf8string; AContent: TStream; AOverwrite: boolean = false; AOwnStream: boolean = true): integer; overload;
     79    function Add(AName: utf8string; AExtension: utf8string; AContent: RawByteString; AOverwrite: boolean = false): integer; overload;
     80    function Add(AFilename: TEntryFilename; AContent: TStream; AOverwrite: boolean = false; AOwnStream: boolean = true): integer; overload;
     81    function Add(AFilename: TEntryFilename; AContent: RawByteString; AOverwrite: boolean = false): integer; overload;
    5182    procedure Clear; virtual;
    5283    destructor Destroy; override;
    5384    procedure LoadFromFile(AFilename: utf8string);
    5485    procedure LoadFromStream(AStream: TStream); virtual; abstract;
     86    procedure LoadFromResource(AFilename: string); virtual;
    5587    procedure SaveToFile(AFilename: utf8string);
    5688    procedure SaveToStream(ADestination: TStream); virtual; abstract;
    5789    procedure Remove(AEntry: TMultiFileEntry); virtual;
    58     procedure Delete(AIndex: integer); virtual; overload;
    59     function Delete(AName: utf8string; AExtension: utf8string;ACaseSensitive: boolean = True): boolean; overload;
    60     function IndexOf(AEntry: TMultiFileEntry): integer;
    61     function IndexOf(AName: utf8string; AExtenstion: utf8string; ACaseSensitive: boolean = True): integer; virtual;
     90    procedure Delete(AIndex: integer); overload; virtual;
     91    function Delete(AName: utf8string; AExtension: utf8string; ACaseSensitive: boolean = True): boolean; overload;
     92    function Delete(AFilename: TEntryFilename; ACaseSensitive: boolean = True): boolean; overload;
     93    function IndexOf(AEntry: TMultiFileEntry): integer; overload;
     94    function IndexOf(AName: utf8string; AExtenstion: utf8string; ACaseSensitive: boolean = True): integer; overload; virtual;
     95    function IndexOf(AFilename: TEntryFilename; ACaseSensitive: boolean = True): integer; overload;
    6296    property Count: integer read GetCount;
    6397    property Entry[AIndex: integer]: TMultiFileEntry read GetEntry;
     98    property RawString[AIndex: integer]: RawByteString read GetRawString write SetRawString;
     99    property RawStringByFilename[AFilename: string]: RawByteString read GetRawStringByFilename write SetRawStringByFilename;
    64100  end;
    65101
    66102implementation
    67103
    68 uses BGRAUTF8;
     104uses BGRAUTF8, strutils, BGRABitmapTypes;
     105
     106{ TEntryFilename }
     107
     108function TEntryFilename.GetFilename: utf8string;
     109begin
     110  if Extension = '' then
     111    result := Name
     112  else
     113    result := Name+'.'+Extension;
     114end;
     115
     116function TEntryFilename.GetIsEmpty: boolean;
     117begin
     118  result := (FName='') and (FExtension = '');
     119end;
     120
     121procedure TEntryFilename.SetExtension(AValue: utf8string);
     122var
     123  i: Integer;
     124begin
     125  if FExtension=AValue then Exit;
     126  for i := 1 to length(AValue) do
     127    if AValue[i] in ['.','/'] then
     128      raise Exception.Create('Invalid extension');
     129  FExtension:=AValue;
     130end;
     131
     132procedure TEntryFilename.SetFilename(AValue: utf8string);
     133var
     134  idxDot: SizeInt;
     135begin
     136  idxDot := RPos('.',AValue);
     137  if idxDot = 0 then
     138  begin
     139    Name := AValue;
     140    Extension := '';
     141  end
     142  else
     143  begin
     144    Name := copy(AValue,1,idxDot-1);
     145    Extension := copy(AValue,idxDot+1,length(AValue)-idxDot);
     146  end;
     147end;
     148
     149procedure TEntryFilename.SetName(AValue: utf8string);
     150var
     151  i: Integer;
     152begin
     153  if FName=AValue then Exit;
     154  for i := 1 to length(AValue) do
     155    if AValue[i] = '/' then
     156      raise Exception.Create('Invalid name');
     157  FName:=AValue;
     158end;
     159
     160function EntryFilename(AName, AExtension: string): TEntryFilename;
     161begin
     162  result.Name := AName;
     163  result.Extension:= AExtension;
     164end;
     165
     166function EntryFilename(AFilename: string): TEntryFilename;
     167begin
     168  result.Filename:= AFilename;
     169end;
     170
     171class operator TEntryFilename.=(const AValue1, AValue2: TEntryFilename): boolean;
     172begin
     173  result := (AValue1.Name = AValue2.Name) and (AValue1.Extension = AValue2.Extension);
     174end;
    69175
    70176{ TMultiFileEntry }
     
    85191end;
    86192
    87 function TMultiFileEntry.CopyTo(ADestination: TStream): integer;
     193function TMultiFileEntry.CopyTo(ADestination: TStream): int64;
    88194begin
    89195  result := 0;
     
    94200function TMultiFileContainer.GetCount: integer;
    95201begin
    96   result := FEntries.Count;
     202  if Assigned(FEntries) then
     203    result := FEntries.Count
     204  else
     205    result := 0;
    97206end;
    98207
     
    102211end;
    103212
     213function TMultiFileContainer.GetRawString(AIndex: integer): RawByteString;
     214var s: TStringStream;
     215begin
     216  s := TStringStream.Create('');
     217  try
     218    Entry[AIndex].CopyTo(s);
     219    result := s.DataString;
     220  finally
     221    s.Free;
     222  end;
     223end;
     224
     225function TMultiFileContainer.GetRawStringByFilename(AFilename: string
     226  ): RawByteString;
     227var
     228  idx: Integer;
     229begin
     230  idx := IndexOf(EntryFilename(AFilename));
     231  if idx = -1 then
     232    result := ''
     233  else
     234    result := GetRawString(idx);
     235end;
     236
     237procedure TMultiFileContainer.SetRawString(AIndex: integer;
     238  AValue: RawByteString);
     239begin
     240  with Entry[AIndex] do
     241    Add(Name, Extension, AValue, true);
     242end;
     243
     244procedure TMultiFileContainer.SetRawStringByFilename(AFilename: string;
     245  AValue: RawByteString);
     246var
     247  f: TEntryFilename;
     248begin
     249  f := EntryFilename(AFilename);
     250  Add(f.Name,f.Extension,AValue,true);
     251end;
     252
    104253procedure TMultiFileContainer.Init;
    105254begin
     
    107256end;
    108257
    109 function TMultiFileContainer.AddEntry(AEntry: TMultiFileEntry): integer;
    110 begin
    111   result := FEntries.Add(AEntry);
     258function TMultiFileContainer.AddEntry(AEntry: TMultiFileEntry; AIndex: integer): integer;
     259begin
     260  if not Assigned(FEntries) then
     261    raise exception.Create('Entry list not created');
     262  if (AIndex >= 0) and (AIndex < FEntries.Count) then
     263  begin
     264    FEntries.Insert(AIndex, AEntry);
     265    result := AIndex;
     266  end
     267  else
     268    result := FEntries.Add(AEntry);
    112269end;
    113270
     
    160317    newEntry := CreateEntry(AName, AExtension, AContent);
    161318  if Assigned(newEntry) then
    162     result := AddEntry(newEntry)
     319    result := AddEntry(newEntry, index)
    163320  else
    164321    raise exception.Create('Unable to create entry');
     
    166323
    167324function TMultiFileContainer.Add(AName: utf8string; AExtension: utf8string;
    168   AContent: utf8String; AOverwrite: boolean): integer;
     325  AContent: RawByteString; AOverwrite: boolean): integer;
    169326var stream: TMemoryStream;
    170327begin
    171328  stream := TMemoryStream.Create;
    172   stream.Write(AContent[1],length(AContent));
     329  if length(AContent) > 0 then stream.Write(AContent[1],length(AContent));
    173330  result := Add(AName,AExtension,stream,AOverwrite);
     331end;
     332
     333function TMultiFileContainer.Add(AFilename: TEntryFilename; AContent: TStream;
     334  AOverwrite: boolean; AOwnStream: boolean): integer;
     335begin
     336  result := Add(AFilename.Name,AFilename.Extension, AContent, AOverwrite, AOwnStream);
     337end;
     338
     339function TMultiFileContainer.Add(AFilename: TEntryFilename;
     340  AContent: RawByteString; AOverwrite: boolean): integer;
     341begin
     342  result := Add(AFilename.Name,AFilename.Extension, AContent, AOverwrite);
    174343end;
    175344
     
    187356  LoadFromStream(stream);
    188357  stream.Free;
     358end;
     359
     360procedure TMultiFileContainer.LoadFromResource(AFilename: string);
     361var
     362  stream: TStream;
     363begin
     364  stream := BGRAResource.GetResourceStream(AFilename);
     365  try
     366    LoadFromStream(stream);
     367  finally
     368    stream.Free;
     369  end;
    189370end;
    190371
     
    230411    result := true;
    231412  end;
     413end;
     414
     415function TMultiFileContainer.Delete(AFilename: TEntryFilename;
     416  ACaseSensitive: boolean): boolean;
     417begin
     418  result := Delete(AFilename.Name,AFilename.Extension,ACaseSensitive);
    232419end;
    233420
     
    259446end;
    260447
     448function TMultiFileContainer.IndexOf(AFilename: TEntryFilename;
     449  ACaseSensitive: boolean): integer;
     450begin
     451  result := IndexOf(AFilename.Name,AFilename.Extension,ACaseSensitive);
     452end;
     453
    261454procedure TMultiFileContainer.Clear;
    262455var
  • GraphicTest/Packages/bgrabitmap/bgranoguibitmap.pas

    r494 r521  
    4040    procedure TakeScreenshot({%H-}ARect: TRect); override; //not available
    4141    procedure TakeScreenshotOfPrimaryMonitor; override; //not available
    42     procedure LoadFromDevice({%H-}DC: System.THandle); override; //not available
    43     procedure LoadFromDevice({%H-}DC: System.THandle; {%H-}ARect: TRect); override; //not available
     42    procedure LoadFromDevice({%H-}DC: HDC); override; //not available
     43    procedure LoadFromDevice({%H-}DC: HDC; {%H-}ARect: TRect); override; //not available
    4444    property Canvas: TBGRACanvas read GetPseudoCanvas;
    4545  end;
     
    149149end;
    150150
    151 procedure TBGRANoGUIBitmap.LoadFromDevice(DC: System.THandle);
     151procedure TBGRANoGUIBitmap.LoadFromDevice(DC: HDC);
    152152begin
    153153  NotAvailable;
    154154end;
    155155
    156 procedure TBGRANoGUIBitmap.LoadFromDevice(DC: System.THandle; ARect: TRect);
     156procedure TBGRANoGUIBitmap.LoadFromDevice(DC: HDC; ARect: TRect);
    157157begin
    158158  NotAvailable;
  • GraphicTest/Packages/bgrabitmap/bgraopengl.pas

    r494 r521  
    99  Classes, SysUtils, FPimage, BGRAGraphics,
    1010  BGRAOpenGLType, BGRASpriteGL, BGRACanvasGL, GL, GLext, GLU, BGRABitmapTypes,
    11   BGRAFontGL, BGRASSE;
     11  BGRAFontGL, BGRASSE, BGRAMatrix3D;
    1212
    1313type
     
    4343    property Width: integer read GetWidth;
    4444    property Height: integer read GetHeight;
     45  end;
     46
     47  { TBGLFrameBuffer }
     48
     49  TBGLFrameBuffer = class(TBGLCustomFrameBuffer)
     50  protected
     51    FHeight: integer;
     52    FMatrix: TAffineMatrix;
     53    FProjectionMatrix: TMatrix4D;
     54    FTexture: IBGLTexture;
     55    FFrameBufferId, FRenderBufferId: GLuint;
     56    FWidth: integer;
     57    FSettingMatrices: boolean;
     58    function GetTexture: IBGLTexture; override;
     59    function GetHandle: pointer; override;
     60    function GetHeight: integer; override;
     61    function GetMatrix: TAffineMatrix; override;
     62    function GetProjectionMatrix: TMatrix4D; override;
     63    function GetWidth: integer; override;
     64    procedure SetMatrix(AValue: TAffineMatrix); override;
     65    procedure SetProjectionMatrix(AValue: TMatrix4D); override;
     66  public
     67    constructor Create(AWidth,AHeight: integer);
     68    function MakeTextureAndFree: IBGLTexture; override;
     69    destructor Destroy; override;
    4570  end;
    4671
     
    120145implementation
    121146
    122 uses BGRATransform{$IFDEF BGRABITMAP_USE_LCL}, BGRAText, BGRATextFX{$ENDIF}
    123     ,BGRAMatrix3D;
     147uses BGRABlurGL, BGRATransform{$IFDEF BGRABITMAP_USE_LCL}, BGRAText, BGRATextFX{$ENDIF};
    124148
    125149type
     
    210234    procedure ToggleFlipY; override;
    211235    procedure Bind(ATextureNumber: integer); override;
     236    function FilterBlurMotion(ARadius: single; ABlurType: TRadialBlurType; ADirection: TPointF): IBGLTexture; override;
     237    function FilterBlurRadial(ARadius: single; ABlurType: TRadialBlurType): IBGLTexture; override;
    212238
    213239  end;
     
    247273    procedure InternalStartPolygon(const pt: TPointF); override;
    248274    procedure InternalStartTriangleFan(const pt: TPointF); override;
    249     procedure InternalContinueShape(const pt: TPointF); override;
    250 
    251     procedure InternalContinueShape(const pt: TPoint3D); override;
    252     procedure InternalContinueShape(const pt: TPoint3D_128); override;
    253     procedure InternalContinueShape(const pt, normal: TPoint3D_128); override;
     275    procedure InternalContinueShape(const pt: TPointF); overload; override;
     276
     277    procedure InternalContinueShape(const pt: TPoint3D); overload; override;
     278    procedure InternalContinueShape(const pt: TPoint3D_128); overload; override;
     279    procedure InternalContinueShape(const pt, normal: TPoint3D_128); overload; override;
    254280
    255281    procedure InternalEndShape; override;
     
    268294    function GetBlendMode: TOpenGLBlendMode; override;
    269295    procedure SetBlendMode(AValue: TOpenGLBlendMode); override;
     296
     297    procedure SetActiveFrameBuffer(AValue: TBGLCustomFrameBuffer); override;
    270298  public
    271299    destructor Destroy; override;
     
    274302    procedure EndZBuffer; override;
    275303    procedure WaitForGPU(AOption: TWaitForGPUOption); override;
     304    function GetImage(x, y, w, h: integer): TBGRACustomBitmap; override;
     305    function CreateFrameBuffer(AWidth, AHeight: integer): TBGLCustomFrameBuffer; override;
    276306  end;
    277307
     
    307337    function GetUniformVariable(AProgram: DWord; AName: string): DWord; override;
    308338    function GetAttribVariable(AProgram: DWord; AName: string): DWord; override;
    309     procedure SetUniformSingle(AVariable: DWord; const AValue; ACount: integer); override;
    310     procedure SetUniformInteger(AVariable: DWord; const AValue; ACount: integer); override;
     339    procedure SetUniformSingle(AVariable: DWord; const AValue; AElementCount, AComponentCount: integer); override;
     340    procedure SetUniformInteger(AVariable: DWord; const AValue; AElementCount, AComponentCount: integer); override;
    311341    procedure BindAttribute(AAttribute: TAttributeVariable); override;
    312342    procedure UnbindAttribute(AAttribute: TAttributeVariable); override;
    313343  end;
     344
     345{ TBGLFrameBuffer }
     346
     347procedure TBGLFrameBuffer.SetMatrix(AValue: TAffineMatrix);
     348begin
     349  if FSettingMatrices then Exit;
     350  FSettingMatrices := true;
     351  FMatrix:=AValue;
     352  if FCanvas <> nil then
     353    TBGLCustomCanvas(FCanvas).Matrix := AValue;
     354  FSettingMatrices := false;
     355end;
     356
     357function TBGLFrameBuffer.GetMatrix: TAffineMatrix;
     358begin
     359  result := FMatrix;
     360end;
     361
     362function TBGLFrameBuffer.GetTexture: IBGLTexture;
     363begin
     364  result := FTexture.FlipY;
     365end;
     366
     367function TBGLFrameBuffer.GetHandle: pointer;
     368begin
     369  result := @FFrameBufferId;
     370end;
     371
     372function TBGLFrameBuffer.GetHeight: integer;
     373begin
     374  result := FHeight;
     375end;
     376
     377function TBGLFrameBuffer.GetProjectionMatrix: TMatrix4D;
     378begin
     379  result := FProjectionMatrix;
     380end;
     381
     382function TBGLFrameBuffer.GetWidth: integer;
     383begin
     384  result := FWidth;
     385end;
     386
     387procedure TBGLFrameBuffer.SetProjectionMatrix(AValue: TMatrix4D);
     388begin
     389  if FSettingMatrices then Exit;
     390  FSettingMatrices := true;
     391  FProjectionMatrix:= AValue;
     392  if FCanvas <> nil then
     393    TBGLCustomCanvas(FCanvas).ProjectionMatrix := AValue;
     394  FSettingMatrices := false;
     395end;
     396
     397constructor TBGLFrameBuffer.Create(AWidth, AHeight: integer);
     398var frameBufferStatus: GLenum;
     399begin
     400  if not Load_GL_version_3_0 then
     401      raise exception.Create('Cannot load OpenGL 3.0');
     402
     403  FWidth := AWidth;
     404  FHeight := AHeight;
     405
     406  FTexture := BGLTextureFactory.Create(nil,AWidth,AHeight,AWidth,AHeight);
     407
     408  //depth and stencil
     409  glGenRenderbuffers(1, @FRenderBufferId);
     410  glBindRenderbuffer(GL_RENDERBUFFER, FRenderBufferId);
     411  glRenderbufferStorage(GL_RENDERBUFFER, GL_DEPTH24_STENCIL8, AWidth,AHeight);
     412  glBindRenderbuffer(GL_RENDERBUFFER, 0);
     413
     414  glGenFramebuffers(1, @FFrameBufferId);
     415  glBindFramebuffer(GL_FRAMEBUFFER, FFrameBufferId);
     416
     417  glFramebufferTexture2D(GL_FRAMEBUFFER, GL_COLOR_ATTACHMENT0, GL_TEXTURE_2D, PGLuint(FTexture.Handle)^, 0);
     418  glFramebufferRenderbuffer(GL_FRAMEBUFFER, GL_DEPTH_STENCIL_ATTACHMENT, GL_RENDERBUFFER, FFrameBufferId);
     419
     420  frameBufferStatus:= glCheckFramebufferStatus(GL_FRAMEBUFFER);
     421  glBindFramebuffer(GL_FRAMEBUFFER, 0);
     422
     423  if frameBufferStatus <> GL_FRAMEBUFFER_COMPLETE then
     424  begin
     425    glDeleteFramebuffers(1, @FFrameBufferId);
     426    glDeleteRenderbuffers(1, @FRenderBufferId);
     427    FTexture := nil;
     428    raise exception.Create('Error ' + inttostr(frameBufferStatus) + ' while initializing frame buffer');
     429  end;
     430
     431  UseOrthoProjection;
     432  Matrix := AffineMatrixIdentity;
     433end;
     434
     435function TBGLFrameBuffer.MakeTextureAndFree: IBGLTexture;
     436begin
     437  result := FTexture;
     438  FTexture := nil;
     439  Free;
     440end;
     441
     442destructor TBGLFrameBuffer.Destroy;
     443begin
     444  glDeleteFramebuffers(1, @FFrameBufferId);
     445  glDeleteRenderbuffers(1, @FRenderBufferId);
     446  FTexture := nil;
     447
     448  inherited Destroy;
     449end;
    314450
    315451procedure ApplyBlendMode(ABlendMode: TOpenGLBlendMode);
     
    776912
    777913procedure TBGLLighting.SetUniformSingle(AVariable: DWord;
    778   const AValue; ACount: integer);
     914  const AValue; AElementCount, AComponentCount: integer);
    779915begin
    780916  NeedOpenGL2_0;
    781   glUniform1fv(AVariable, ACount, @AValue);
     917  case AComponentCount of
     918    1: glUniform1fv(AVariable, AElementCount, @AValue);
     919    2: glUniform2fv(AVariable, AElementCount, @AValue);
     920    3: glUniform3fv(AVariable, AElementCount, @AValue);
     921    4: glUniform4fv(AVariable, AElementCount, @AValue);
     922    9: glUniformMatrix3fv(AVariable, AElementCount, GL_FALSE, @AValue);
     923    16: glUniformMatrix4fv(AVariable, AElementCount, GL_FALSE, @AValue);
     924  else
     925    raise exception.Create('Unexpected number of components');
     926  end;
    782927end;
    783928
    784929procedure TBGLLighting.SetUniformInteger(AVariable: DWord;
    785   const AValue; ACount: integer);
     930  const AValue; AElementCount, AComponentCount: integer);
    786931begin
    787932  NeedOpenGL2_0;
    788   glUniform1iv(AVariable, ACount, @AValue);
     933  case AComponentCount of
     934    1: glUniform1iv(AVariable, AElementCount, @AValue);
     935    2: glUniform2iv(AVariable, AElementCount, @AValue);
     936    3: glUniform3iv(AVariable, AElementCount, @AValue);
     937    4: glUniform4iv(AVariable, AElementCount, @AValue);
     938  else
     939    raise exception.Create('Unexpected number of components');
     940  end;
    789941end;
    790942
     
    8491001function TBGLCanvas.GetMatrix: TAffineMatrix;
    8501002begin
    851   result := FMatrix;
     1003  if ActiveFrameBuffer <> nil then
     1004    result := ActiveFrameBuffer.Matrix
     1005  else
     1006    result := FMatrix;
    8521007end;
    8531008
     
    8581013  m := AffineMatrixToMatrix4D(AValue);
    8591014  glLoadMatrixf(@m);
    860   FMatrix := AValue;
     1015
     1016  if ActiveFrameBuffer <> nil then
     1017    ActiveFrameBuffer.Matrix := AValue
     1018  else
     1019    FMatrix := AValue;
    8611020end;
    8621021
    8631022function TBGLCanvas.GetProjectionMatrix: TMatrix4D;
    8641023begin
    865   result := FProjectionMatrix;
     1024  if ActiveFrameBuffer <> nil then
     1025    result := ActiveFrameBuffer.ProjectionMatrix
     1026  else
     1027    result := FProjectionMatrix;
    8661028end;
    8671029
    8681030procedure TBGLCanvas.SetProjectionMatrix(const AValue: TMatrix4D);
    8691031begin
    870   FProjectionMatrix := AValue;
    8711032  glMatrixMode(GL_PROJECTION);
    8721033  glLoadMatrixf(@AValue);
    8731034  glMatrixMode(GL_MODELVIEW);
     1035
     1036  if ActiveFrameBuffer <> nil then
     1037    ActiveFrameBuffer.ProjectionMatrix := AValue
     1038  else
     1039    FProjectionMatrix := AValue;
    8741040end;
    8751041
     
    10151181end;
    10161182
     1183function TBGLCanvas.GetImage(x, y, w, h: integer): TBGRACustomBitmap;
     1184begin
     1185  NeedOpenGL2_0;
     1186  result := BGRABitmapFactory.Create(w,h);
     1187  if TBGRAPixel_RGBAOrder then
     1188    glReadPixels(x,self.Height-y-h, w,h, GL_RGBA, GL_UNSIGNED_BYTE, result.Data)
     1189  else
     1190    glReadPixels(x,self.Height-y-h, w,h, GL_BGRA, GL_UNSIGNED_BYTE, result.Data);
     1191end;
     1192
     1193function TBGLCanvas.CreateFrameBuffer(AWidth, AHeight: integer): TBGLCustomFrameBuffer;
     1194begin
     1195  Result:= TBGLFrameBuffer.Create(AWidth,AHeight);
     1196end;
     1197
    10171198procedure TBGLCanvas.EnableScissor(AValue: TRect);
    10181199begin
     
    10341215begin
    10351216  FBlendMode := AValue;
     1217end;
     1218
     1219procedure TBGLCanvas.SetActiveFrameBuffer(AValue: TBGLCustomFrameBuffer);
     1220var
     1221  m: TMatrix4D;
     1222begin
     1223  if AValue = ActiveFrameBuffer then exit;
     1224  inherited SetActiveFrameBuffer(AValue);
     1225  if AValue = nil then
     1226    glBindFramebuffer(GL_FRAMEBUFFER, 0)
     1227  else
     1228    glBindFramebuffer(GL_FRAMEBUFFER, PGLuint(AValue.Handle)^);
     1229
     1230  glViewPort(0,0,Width,Height);
     1231
     1232  glMatrixMode(GL_PROJECTION);
     1233  m := ProjectionMatrix;
     1234  glLoadMatrixf(@m);
     1235
     1236  glMatrixMode(GL_MODELVIEW);
     1237  m := AffineMatrixToMatrix4D(Matrix);
     1238  glLoadMatrixf(@m);
    10361239end;
    10371240
     
    13771580procedure TBGLTexture.ToggleFlipY;
    13781581begin
    1379   FFlipX := not FFlipY;
     1582  FFlipY := not FFlipY;
    13801583end;
    13811584
     
    13951598end;
    13961599
     1600function TBGLTexture.FilterBlurMotion(ARadius: single; ABlurType: TRadialBlurType; ADirection: TPointF): IBGLTexture;
     1601var shader: TBGLCustomShader;
     1602  blurName: string;
     1603begin
     1604  blurName := 'TBGLBlurShader(' + RadialBlurTypeToStr[ABlurType] + ')';
     1605  shader := BGLCanvas.Lighting.Shader[blurName];
     1606  if shader = nil then
     1607  begin
     1608    shader := TBGLBlurShader.Create(BGLCanvas, ABlurType);
     1609    BGLCanvas.Lighting.Shader[blurName] := shader;
     1610  end;
     1611  with (shader as TBGLBlurShader) do
     1612  begin
     1613    Radius := ARadius;
     1614    Direction := ADirection;
     1615    result := FilterBlurMotion(self);
     1616  end;
     1617end;
     1618
     1619function TBGLTexture.FilterBlurRadial(ARadius: single; ABlurType: TRadialBlurType): IBGLTexture;
     1620var shader: TBGLCustomShader;
     1621  blurName: String;
     1622begin
     1623  blurName := 'TBGLBlurShader(' + RadialBlurTypeToStr[ABlurType] + ')';
     1624  shader := BGLCanvas.Lighting.Shader[blurName];
     1625  if shader = nil then
     1626  begin
     1627    shader := TBGLBlurShader.Create(BGLCanvas, ABlurType);
     1628    BGLCanvas.Lighting.Shader[blurName] := shader;
     1629  end;
     1630  with (shader as TBGLBlurShader) do
     1631  begin
     1632    Radius := ARadius;
     1633    result := FilterBlurRadial(self);
     1634  end;
     1635end;
     1636
    13971637procedure TBGLTexture.Init(ATexture: TBGLTextureHandle; AWidth,
    13981638  AHeight: integer; AOwned: boolean);
  • GraphicTest/Packages/bgrabitmap/bgraopengl3d.pas

    r494 r521  
    149149  end;
    150150
     151  { TUniformVariableMatrix4D }
     152
     153  TUniformVariableMatrix4D = object(TUniformVariable)
     154  private
     155    FValue: TMatrix4D;
     156    procedure SetValue(const AValue: TMatrix4D);
     157  public
     158    procedure Update;
     159    property Value: TMatrix4D read FValue write SetValue;
     160  end;
     161
    151162  { TAttributeVariableSingle }
    152163
     
    201212    function GetUniformVariableInteger(AName: string): TUniformVariableInteger;
    202213    function GetUniformVariablePoint(AName: string): TUniformVariablePoint;
     214    function GetUniformVariableMatrix4D(AName: string): TUniformVariableMatrix4D;
    203215    function GetAttributeVariableInteger(AName: string): TAttributeVariableInteger;
    204216    function GetAttributeVariablePoint(AName: string): TAttributeVariablePoint;
     
    206218    function GetAttributeVariablePointF(AName: string): TAttributeVariablePointF;
    207219    function GetAttributeVariablePoint3D(AName: string): TAttributeVariablePoint3D;
    208     procedure SetUniformSingle(AVariable: DWord; const AValue; ACount: integer);
    209     procedure SetUniformInteger(AVariable: DWord; const AValue; ACount: integer);
     220    procedure SetUniformSingle(AVariable: DWord; const AValue; AElementCount: integer; AComponentCount: integer);
     221    procedure SetUniformInteger(AVariable: DWord; const AValue; AElementCount: integer; AComponentCount: integer);
    210222    procedure CheckUsage(AUsing: boolean);
    211223    procedure StartUse; override;
    212224    procedure EndUse; override;
     225    property Canvas: TBGLCustomCanvas read FCanvas;
    213226  public
    214227    constructor Create(ACanvas: TBGLCustomCanvas; AVertexShaderSource: string;
    215228        AFragmentShaderSource: string; AVaryingVariables: string = '';
    216         AVersion: string = '110');
     229        AVersion: string = '120');
    217230    destructor Destroy; override;
    218231    property UniformSingle[AName: string]: TUniformVariableSingle read GetUniformVariableSingle;
     
    221234    property UniformInteger[AName: string]: TUniformVariableInteger read GetUniformVariableInteger;
    222235    property UniformPoint[AName: string]: TUniformVariablePoint read GetUniformVariablePoint;
     236    property UniformMatrix4D[AName: string]: TUniformVariableMatrix4D read GetUniformVariableMatrix4D;
    223237    property AttributeSingle[AName: string]: TAttributeVariableSingle read GetAttributeVariableSingle;
    224238    property AttributePointF[AName: string]: TAttributeVariablePointF read GetAttributeVariablePointF;
     
    260274end;
    261275
     276{ TUniformVariableMatrix4D }
     277
     278procedure TUniformVariableMatrix4D.SetValue(const AValue: TMatrix4D);
     279begin
     280  if CompareMem(@AValue, @FValue, sizeof(FValue)) then Exit;
     281  FValue:=AValue;
     282  if FProgram.IsUsed then Update;
     283end;
     284
     285procedure TUniformVariableMatrix4D.Update;
     286begin
     287  FProgram.SetUniformSingle(FVariable, FValue, 1, 16);
     288end;
     289
    262290{ TShaderWithTexture }
    263291
     
    351379procedure TUniformVariablePoint.Update;
    352380begin
    353   FProgram.SetUniformInteger(FVariable, FValue, 2);
     381  FProgram.SetUniformInteger(FVariable, FValue, 1, 2);
    354382end;
    355383
     
    365393procedure TUniformVariableInteger.Update;
    366394begin
    367   FProgram.SetUniformInteger(FVariable, FValue, 1);
     395  FProgram.SetUniformInteger(FVariable, FValue, 1, 1);
    368396end;
    369397
     
    379407procedure TUniformVariablePoint3D.Update;
    380408begin
    381   FProgram.SetUniformSingle(FVariable, FValue, 3);
     409  FProgram.SetUniformSingle(FVariable, FValue, 1, 3);
    382410end;
    383411
     
    393421procedure TUniformVariablePointF.Update;
    394422begin
    395   FProgram.SetUniformSingle(FVariable, FValue, 2);
     423  FProgram.SetUniformSingle(FVariable, FValue, 1, 2);
    396424end;
    397425
     
    407435procedure TUniformVariableSingle.Update;
    408436begin
    409   FProgram.SetUniformSingle(FVariable, FValue, 1);
     437  FProgram.SetUniformSingle(FVariable, FValue, 1, 1);
    410438end;
    411439
     
    460488end;
    461489
     490function TBGLShader3D.GetUniformVariableMatrix4D(AName: string): TUniformVariableMatrix4D;
     491begin
     492  {$push}{$hints off}
     493  fillchar(result,sizeof(result),0);
     494  result.Init(self, FCanvas.Lighting.GetUniformVariable(FProgram, AName));
     495  {$pop}
     496end;
     497
    462498procedure TBGLShader3D.CheckUsage(AUsing: boolean);
    463499begin
     
    509545end;
    510546
    511 procedure TBGLShader3D.SetUniformSingle(AVariable: DWord; const AValue; ACount: integer);
     547procedure TBGLShader3D.SetUniformSingle(AVariable: DWord; const AValue; AElementCount: integer; AComponentCount: integer);
    512548begin
    513549  CheckUsage(True);
    514   FCanvas.Lighting.SetUniformSingle(AVariable, AValue, ACount);
    515 end;
    516 
    517 procedure TBGLShader3D.SetUniformInteger(AVariable: DWord; const AValue; ACount: integer);
     550  FCanvas.Lighting.SetUniformSingle(AVariable, AValue, AElementCount, AComponentCount);
     551end;
     552
     553procedure TBGLShader3D.SetUniformInteger(AVariable: DWord; const AValue; AElementCount: integer; AComponentCount: integer);
    518554begin
    519555  CheckUsage(True);
    520   FCanvas.Lighting.SetUniformInteger(AVariable, AValue, ACount);
     556  FCanvas.Lighting.SetUniformInteger(AVariable, AValue, AElementCount, AComponentCount);
    521557end;
    522558
     
    527563  FCanvas := ACanvas;
    528564  FLighting := FCanvas.Lighting;
    529   FVertexShaderSource:= '#define version ' + AVersion + #10 + AVaryingVariables + #10 + AVertexShaderSource;
    530   FFragmentShaderSource:= '#define version ' + AVersion + #10 + AVaryingVariables + #10 + AFragmentShaderSource;
     565  FVertexShaderSource:= '#version ' + AVersion + #10 + AVaryingVariables + #10 + AVertexShaderSource;
     566  FFragmentShaderSource:= '#version ' + AVersion + #10 + AVaryingVariables + #10 + AFragmentShaderSource;
    531567  FVertexShader := 0;
    532568  FFragmentShader := 0;
  • GraphicTest/Packages/bgrabitmap/bgraopengltype.pas

    r494 r521  
    142142    procedure TextRect(ARect: TRectF; const Text : UTF8String; AHorizAlign: TAlignment; AVertAlign: TTextLayout; AColor: TBGRAPixel); overload;
    143143    function TextWidth(const Text: UTF8String): single; virtual; abstract;
    144     function TextHeight(const Text: UTF8String): single; virtual; abstract; overload;
    145     function TextHeight(const Text: UTF8String; AWidth: single): single; virtual; abstract; overload;
     144    function TextHeight(const Text: UTF8String): single; overload; virtual; abstract;
     145    function TextHeight(const Text: UTF8String; AWidth: single): single; overload; virtual; abstract;
    146146    procedure SetGradientColors(ATopLeft, ATopRight, ABottomRight, ABottomLeft: TBGRAPixel); virtual; abstract;
    147147
     
    184184    procedure ToggleFlipY;
    185185    procedure ToggleMask;
     186    function FilterBlurMotion(ARadius: single; ABlurType: TRadialBlurType; ADirection: TPointF): IBGLTexture;
     187    function FilterBlurRadial(ARadius: single; ABlurType: TRadialBlurType): IBGLTexture;
    186188    procedure SetFrame(AIndex: integer);
    187189    procedure FreeMemory;
     
    212214    procedure DrawAffine(x,y: single; const AMatrix: TAffineMatrix; AAlpha: byte = 255); overload;
    213215    procedure DrawAffine(x,y: single; const AMatrix: TAffineMatrix; AColor: TBGRAPixel); overload;
    214     procedure DrawTriangle(const APoints: array of TPointF; const ATexCoords: array of TPointF);
    215     procedure DrawTriangle(const APoints: array of TPointF; const ATexCoords: array of TPointF; const AColors: array of TColorF);
    216     procedure DrawTriangle(const APoints: array of TPointF; const APointsZ: array of Single; const ATexCoords: array of TPointF);
    217     procedure DrawTriangle(const APoints: array of TPointF; const APointsZ: array of Single; const ATexCoords: array of TPointF; const AColors: array of TColorF);
    218     procedure DrawTriangle(const APoints3D: array of TPoint3D_128; const ATexCoords: array of TPointF);
    219     procedure DrawTriangle(const APoints3D: array of TPoint3D_128; const ATexCoords: array of TPointF; const AColors: array of TColorF);
    220     procedure DrawTriangle(const APoints3D: array of TPoint3D_128; const ANormals3D: array of TPoint3D_128; const ATexCoords: array of TPointF);
    221     procedure DrawTriangle(const APoints3D: array of TPoint3D_128; const ANormals3D: array of TPoint3D_128; const ATexCoords: array of TPointF; const AColors: array of TColorF);
    222     procedure DrawQuad(const APoints: array of TPointF; const ATexCoords: array of TPointF);
    223     procedure DrawQuad(const APoints: array of TPointF; const ATexCoords: array of TPointF; const AColors: array of TColorF);
    224     procedure DrawQuad(const APoints: array of TPointF; const APointsZ: array of Single; const ATexCoords: array of TPointF);
    225     procedure DrawQuad(const APoints: array of TPointF; const APointsZ: array of Single; const ATexCoords: array of TPointF; const AColors: array of TColorF);
    226     procedure DrawQuad(const APoints3D: array of TPoint3D_128; const ATexCoords: array of TPointF);
    227     procedure DrawQuad(const APoints3D: array of TPoint3D_128; const ATexCoords: array of TPointF; const AColors: array of TColorF);
    228     procedure DrawQuad(const APoints3D: array of TPoint3D_128; const ANormals3D: array of TPoint3D_128; const ATexCoords: array of TPointF);
    229     procedure DrawQuad(const APoints3D: array of TPoint3D_128; const ANormals3D: array of TPoint3D_128; const ATexCoords: array of TPointF; const AColors: array of TColorF);
     216    procedure DrawTriangle(const APoints: array of TPointF; const ATexCoords: array of TPointF); overload;
     217    procedure DrawTriangle(const APoints: array of TPointF; const ATexCoords: array of TPointF; const AColors: array of TColorF); overload;
     218    procedure DrawTriangle(const APoints: array of TPointF; const APointsZ: array of Single; const ATexCoords: array of TPointF); overload;
     219    procedure DrawTriangle(const APoints: array of TPointF; const APointsZ: array of Single; const ATexCoords: array of TPointF; const AColors: array of TColorF); overload;
     220    procedure DrawTriangle(const APoints3D: array of TPoint3D_128; const ATexCoords: array of TPointF); overload;
     221    procedure DrawTriangle(const APoints3D: array of TPoint3D_128; const ATexCoords: array of TPointF; const AColors: array of TColorF); overload;
     222    procedure DrawTriangle(const APoints3D: array of TPoint3D_128; const ANormals3D: array of TPoint3D_128; const ATexCoords: array of TPointF); overload;
     223    procedure DrawTriangle(const APoints3D: array of TPoint3D_128; const ANormals3D: array of TPoint3D_128; const ATexCoords: array of TPointF; const AColors: array of TColorF); overload;
     224    procedure DrawQuad(const APoints: array of TPointF; const ATexCoords: array of TPointF); overload;
     225    procedure DrawQuad(const APoints: array of TPointF; const ATexCoords: array of TPointF; const AColors: array of TColorF); overload;
     226    procedure DrawQuad(const APoints: array of TPointF; const APointsZ: array of Single; const ATexCoords: array of TPointF); overload;
     227    procedure DrawQuad(const APoints: array of TPointF; const APointsZ: array of Single; const ATexCoords: array of TPointF; const AColors: array of TColorF); overload;
     228    procedure DrawQuad(const APoints3D: array of TPoint3D_128; const ATexCoords: array of TPointF); overload;
     229    procedure DrawQuad(const APoints3D: array of TPoint3D_128; const ATexCoords: array of TPointF; const AColors: array of TColorF); overload;
     230    procedure DrawQuad(const APoints3D: array of TPoint3D_128; const ANormals3D: array of TPoint3D_128; const ATexCoords: array of TPointF); overload;
     231    procedure DrawQuad(const APoints3D: array of TPoint3D_128; const ANormals3D: array of TPoint3D_128; const ATexCoords: array of TPointF; const AColors: array of TColorF); overload;
    230232
    231233    property Width: integer read GetWidth;
     
    266268    procedure NoClip; override;
    267269    destructor Destroy; override;
    268     procedure SwapRedBlue; override; overload;
     270    procedure SwapRedBlue; overload; override;
    269271    function Resample(newWidth, newHeight: integer; mode: TResampleMode=rmFineResample): TBGRACustomBitmap; override;
    270     procedure ApplyGlobalOpacity(alpha: byte); override; overload;
    271     procedure ReplaceColor(before, after: TColor); override; overload;
    272     procedure ReplaceColor(before, after: TBGRAPixel); override; overload;
    273     procedure ReplaceTransparent(after: TBGRAPixel); override; overload;
     272    procedure ApplyGlobalOpacity(alpha: byte); overload; override;
     273    procedure ReplaceColor(before, after: TColor); overload; override;
     274    procedure ReplaceColor(before, after: TBGRAPixel); overload; override;
     275    procedure ReplaceTransparent(after: TBGRAPixel); overload; override;
    274276    procedure SetClipRect(const AValue: TRect); override;
    275277    procedure SetSize(AWidth, AHeight: integer); override;
     
    363365    procedure ToggleFlipY; virtual; abstract;
    364366    procedure ToggleMask; virtual;
     367    function FilterBlurMotion({%H-}ARadius: single; {%H-}ABlurType: TRadialBlurType; {%H-}ADirection: TPointF): IBGLTexture; virtual;
     368    function FilterBlurRadial({%H-}ARadius: single; {%H-}ABlurType: TRadialBlurType): IBGLTexture; virtual;
    365369
    366370    procedure SetFrameSize(x,y: integer);
     
    395399    procedure DrawAffine(x,y: single; const AMatrix: TAffineMatrix; AAlpha: byte = 255); overload;
    396400    procedure DrawAffine(x,y: single; const AMatrix: TAffineMatrix; AColor: TBGRAPixel); overload;
    397     procedure DrawTriangle(const APoints: array of TPointF; const ATexCoords: array of TPointF);
    398     procedure DrawTriangle(const APoints: array of TPointF; const ATexCoords: array of TPointF; const AColors: array of TColorF);
    399     procedure DrawTriangle(const APoints: array of TPointF; const APointsZ: array of Single; const ATexCoords: array of TPointF);
    400     procedure DrawTriangle(const APoints: array of TPointF; const APointsZ: array of Single; const ATexCoords: array of TPointF; const AColors: array of TColorF);
    401     procedure DrawTriangle(const APoints3D: array of TPoint3D_128; const ATexCoords: array of TPointF);
    402     procedure DrawTriangle(const APoints3D: array of TPoint3D_128; const ATexCoords: array of TPointF; const AColors: array of TColorF);
    403     procedure DrawTriangle(const APoints3D: array of TPoint3D_128; const ANormals3D: array of TPoint3D_128; const ATexCoords: array of TPointF);
    404     procedure DrawTriangle(const APoints3D: array of TPoint3D_128; const ANormals3D: array of TPoint3D_128; const ATexCoords: array of TPointF; const AColors: array of TColorF);
    405     procedure DrawQuad(const APoints: array of TPointF; const ATexCoords: array of TPointF);
    406     procedure DrawQuad(const APoints: array of TPointF; const ATexCoords: array of TPointF; const AColors: array of TColorF);
    407     procedure DrawQuad(const APoints: array of TPointF; const APointsZ: array of Single; const ATexCoords: array of TPointF);
    408     procedure DrawQuad(const APoints: array of TPointF; const APointsZ: array of Single; const ATexCoords: array of TPointF; const AColors: array of TColorF);
    409     procedure DrawQuad(const APoints3D: array of TPoint3D_128; const ATexCoords: array of TPointF);
    410     procedure DrawQuad(const APoints3D: array of TPoint3D_128; const ATexCoords: array of TPointF; const AColors: array of TColorF);
    411     procedure DrawQuad(const APoints3D: array of TPoint3D_128; const ANormals3D: array of TPoint3D_128; const ATexCoords: array of TPointF);
    412     procedure DrawQuad(const APoints3D: array of TPoint3D_128; const ANormals3D: array of TPoint3D_128; const ATexCoords: array of TPointF; const AColors: array of TColorF);
     401    procedure DrawTriangle(const APoints: array of TPointF; const ATexCoords: array of TPointF); overload;
     402    procedure DrawTriangle(const APoints: array of TPointF; const ATexCoords: array of TPointF; const AColors: array of TColorF); overload;
     403    procedure DrawTriangle(const APoints: array of TPointF; const APointsZ: array of Single; const ATexCoords: array of TPointF); overload;
     404    procedure DrawTriangle(const APoints: array of TPointF; const APointsZ: array of Single; const ATexCoords: array of TPointF; const AColors: array of TColorF); overload;
     405    procedure DrawTriangle(const APoints3D: array of TPoint3D_128; const ATexCoords: array of TPointF); overload;
     406    procedure DrawTriangle(const APoints3D: array of TPoint3D_128; const ATexCoords: array of TPointF; const AColors: array of TColorF); overload;
     407    procedure DrawTriangle(const APoints3D: array of TPoint3D_128; const ANormals3D: array of TPoint3D_128; const ATexCoords: array of TPointF); overload;
     408    procedure DrawTriangle(const APoints3D: array of TPoint3D_128; const ANormals3D: array of TPoint3D_128; const ATexCoords: array of TPointF; const AColors: array of TColorF); overload;
     409    procedure DrawQuad(const APoints: array of TPointF; const ATexCoords: array of TPointF); overload;
     410    procedure DrawQuad(const APoints: array of TPointF; const ATexCoords: array of TPointF; const AColors: array of TColorF); overload;
     411    procedure DrawQuad(const APoints: array of TPointF; const APointsZ: array of Single; const ATexCoords: array of TPointF); overload;
     412    procedure DrawQuad(const APoints: array of TPointF; const APointsZ: array of Single; const ATexCoords: array of TPointF; const AColors: array of TColorF); overload;
     413    procedure DrawQuad(const APoints3D: array of TPoint3D_128; const ATexCoords: array of TPointF); overload;
     414    procedure DrawQuad(const APoints3D: array of TPoint3D_128; const ATexCoords: array of TPointF; const AColors: array of TColorF); overload;
     415    procedure DrawQuad(const APoints3D: array of TPoint3D_128; const ANormals3D: array of TPoint3D_128; const ATexCoords: array of TPointF); overload;
     416    procedure DrawQuad(const APoints3D: array of TPoint3D_128; const ANormals3D: array of TPoint3D_128; const ATexCoords: array of TPointF; const AColors: array of TColorF); overload;
    413417
    414418    property Width: integer read GetWidth;
     
    427431  end;
    428432
     433  { TBGLCustomFrameBuffer }
     434
     435  TBGLCustomFrameBuffer = class
     436  protected
     437    FCanvas: pointer;
     438    function GetTexture: IBGLTexture; virtual; abstract;
     439    function GetHandle: pointer; virtual; abstract;
     440    function GetMatrix: TAffineMatrix; virtual; abstract;
     441    function GetHeight: integer; virtual; abstract;
     442    function GetProjectionMatrix: TMatrix4D; virtual; abstract;
     443    function GetWidth: integer; virtual; abstract;
     444    procedure SetMatrix(AValue: TAffineMatrix); virtual; abstract;
     445    procedure SetProjectionMatrix(AValue: TMatrix4D); virtual; abstract;
     446
     447  public
     448    procedure UseOrthoProjection; overload; virtual;
     449    procedure UseOrthoProjection(AMinX,AMinY,AMaxX,AMaxY: single); overload; virtual;
     450    function MakeTextureAndFree: IBGLTexture; virtual;
     451
     452    procedure SetCanvas(ACanvas: Pointer); //for internal use
     453    property Matrix: TAffineMatrix read GetMatrix write SetMatrix;
     454    property ProjectionMatrix: TMatrix4D read GetProjectionMatrix write SetProjectionMatrix;
     455    property Width: integer read GetWidth;
     456    property Height: integer read GetHeight;
     457    property Handle: pointer read GetHandle;
     458    property Texture: IBGLTexture read GetTexture;
     459  end;
     460
    429461type
    430462  TBGLBitmapAny = class of TBGLCustomBitmap;
     
    441473
    442474uses BGRAFilterScanner;
     475
     476procedure TBGLCustomFrameBuffer.UseOrthoProjection;
     477begin
     478  ProjectionMatrix := OrthoProjectionToOpenGL(0,0,Width,Height);
     479end;
     480
     481procedure TBGLCustomFrameBuffer.UseOrthoProjection(AMinX, AMinY, AMaxX, AMaxY: single);
     482begin
     483  ProjectionMatrix := OrthoProjectionToOpenGL(AMinX,AMinY,AMaxX,AMaxY);
     484end;
     485
     486function TBGLCustomFrameBuffer.MakeTextureAndFree: IBGLTexture;
     487begin
     488  result := nil;
     489  raise exception.create('Not implemented');
     490end;
     491
     492procedure TBGLCustomFrameBuffer.SetCanvas(ACanvas: Pointer);
     493begin
     494  FCanvas := ACanvas;
     495end;
    443496
    444497function OrthoProjectionToOpenGL(AMinX, AMinY, AMaxX, AMaxY: Single): TMatrix4D;
     
    595648end;
    596649
     650function TBGLCustomTexture.FilterBlurMotion(ARadius: single; ABlurType: TRadialBlurType;
     651  ADirection: TPointF): IBGLTexture;
     652begin
     653  result := nil;
     654  raise exception.Create('Not implemented');
     655end;
     656
     657function TBGLCustomTexture.FilterBlurRadial(ARadius: single; ABlurType: TRadialBlurType): IBGLTexture;
     658begin
     659  result := nil;
     660  raise exception.Create('Not implemented');
     661end;
     662
    597663procedure TBGLCustomTexture.Update(ARGBAData: PDWord; AllocatedWidth,
    598664  AllocatedHeight, ActualWidth, ActualHeight: integer; RGBAOrder: boolean);
     
    757823    begin
    758824      if not TBGRAPixel_RGBAOrder and not SupportsBGRAOrder then SwapRedBlue;
     825      if LineOrder = riloBottomToTop then VerticalFlip;
    759826      InitFromData(PDWord(Data), Width,Height, Width,Height, TBGRAPixel_RGBAOrder or not SupportsBGRAOrder);
     827      if LineOrder = riloBottomToTop then VerticalFlip;
    760828      if not TBGRAPixel_RGBAOrder and not SupportsBGRAOrder then SwapRedBlue;
    761829    end;
     
    10041072  AAlpha: byte);
    10051073begin
     1074  {$PUSH}{$OPTIMIZATION OFF}
    10061075  DoDrawAffine(Origin,HAxis,VAxis, BGRA(255,255,255,AAlpha));
     1076  {$POP}
    10071077end;
    10081078
     
    10101080  AColor: TBGRAPixel);
    10111081begin
     1082  {$PUSH}{$OPTIMIZATION OFF}
    10121083  DoDrawAffine(Origin,HAxis,VAxis, AColor);
     1084  {$POP}
    10131085end;
    10141086
  • GraphicTest/Packages/bgrabitmap/bgraopenraster.pas

    r494 r521  
    3737    procedure SetMemoryStreamAsString(AFilename: string; AContent: string);
    3838    function GetMemoryStreamAsString(AFilename: string): string;
    39     procedure UnzipFromStream(AStream: TStream);
     39    procedure UnzipFromStream(AStream: TStream; AFileList: TStrings = nil);
    4040    procedure UnzipFromFile(AFilenameUTF8: string);
    4141    procedure ZipToFile(AFilenameUTF8: string);
    4242    procedure ZipToStream(AStream: TStream);
    4343    procedure CopyThumbnailToMemoryStream(AMaxWidth, AMaxHeight: integer);
    44     procedure AnalyzeZip;
    45     procedure PrepareZipToSave;
     44    procedure AnalyzeZip; virtual;
     45    procedure PrepareZipToSave; virtual;
    4646    function GetMimeType: string; override;
    4747
    4848  public
    49     constructor Create; override; overload;
    50     constructor Create(AWidth, AHeight: integer); override; overload;
     49    constructor Create; overload; override;
     50    constructor Create(AWidth, AHeight: integer); overload; override;
    5151    procedure Clear; override;
    5252    function CheckMimeType(AStream: TStream): boolean;
     53    procedure LoadFlatImageFromStream(AStream: TStream;
     54              out ANbLayers: integer;
     55              out ABitmap: TBGRABitmap);
    5356    procedure LoadFromStream(AStream: TStream); override;
    5457    procedure LoadFromFile(const filenameUTF8: string); override;
     
    8790  UnzipperExt;
    8891
     92const
     93  MergedImageFilename = 'mergedimage.png';
     94  LayerStackFilename = 'stack.xml';
     95
    8996function IsZipStream(stream: TStream): boolean;
    9097var
     
    140147  oldPos := stream.Position;
    141148  {$PUSH}{$HINTS OFF}
    142   BytesRead := Stream.Read(magic,sizeof(magic));
     149  BytesRead := Stream.Read({%H-}magic,sizeof(magic));
    143150  {$POP}
    144151  stream.Position:= OldPos;
     
    163170  layeredImage := TBGRAOpenRasterDocument.Create;
    164171  try
    165     layeredImage.LoadFromStream(Stream);
    166     flat := layeredImage.ComputeFlatImage;
    167     try
     172    layeredImage.LoadFlatImageFromStream(Stream, FNbLayers, flat);
     173    if Assigned(flat) then
     174    begin
     175      FWidth := flat.Width;
     176      FHeight := flat.Height;
     177    end else
     178    begin
     179      layeredImage.LoadFromStream(Stream);
     180      flat := layeredImage.ComputeFlatImage;
    168181      FWidth:= layeredImage.Width;
    169182      FHeight:= layeredImage.Height;
    170183      FNbLayers:= layeredImage.NbLayers;
     184    end;
     185    try
    171186      if Img is TBGRACustomBitmap then
    172187        TBGRACustomBitmap(img).Assign(flat)
     
    181196      flat.free;
    182197    end;
    183     layeredImage.Free;
     198    FreeAndNil(layeredImage);
    184199  except
    185200    on ex: Exception do
     
    203218  gammastr: string;
    204219begin
     220  inherited Clear;
     221
    205222  if MimeType <> OpenRasterMimeType then
    206223    raise Exception.Create('Invalid mime type');
    207224
    208   StackStream := GetMemoryStream('stack.xml');
     225  StackStream := GetMemoryStream(LayerStackFilename);
    209226  if StackStream = nil then
    210227    raise Exception.Create('Layer stack not found');
     
    225242      attr := imagenode.Attributes[i];
    226243      if lowercase(attr.NodeName) = 'w' then
    227         w := strToInt(attr.NodeValue) else
     244        w := strToInt(string(attr.NodeValue)) else
    228245      if lowercase(attr.NodeName) = 'h' then
    229         h := strToInt(attr.NodeValue) else
     246        h := strToInt(string(attr.NodeValue)) else
    230247      if lowercase(attr.NodeName) = 'gamma-correction' then
    231248        linearBlend := (attr.NodeValue = 'no') or (attr.NodeValue = '0');
     
    265282          end else
    266283          if lowercase(attr.NodeName) = 'gamma-correction' then
    267             gammastr := attr.NodeValue else
     284            gammastr := string(attr.NodeValue) else
    268285          if lowercase(attr.NodeName) = 'visibility' then
    269286            LayerVisible[idx] := (attr.NodeValue = 'visible') or (attr.NodeValue = 'yes') or (attr.NodeValue = '1') else
     
    283300          if lowercase(attr.NodeName) = 'composite-op' then
    284301          begin
    285             opstr := StringReplace(lowercase(attr.NodeValue),'_','-',[rfReplaceAll]);
     302            opstr := StringReplace(lowercase(string(attr.NodeValue)),'_','-',[rfReplaceAll]);
    286303            if (pos(':',opstr) = 0) and (opstr <> 'xor') then opstr := 'svg:'+opstr;
    287304            //parse composite op
     
    373390  imageNode := TDOMElement(StackXML.CreateElement('image'));
    374391  StackXML.AppendChild(imageNode);
    375   imageNode.SetAttribute('w',inttostr(Width));
    376   imageNode.SetAttribute('h',inttostr(Height));
     392  imageNode.SetAttribute('w',widestring(inttostr(Width)));
     393  imageNode.SetAttribute('h',widestring(inttostr(Height)));
    377394  if LinearBlend then
    378395    imageNode.SetAttribute('gamma-correction','no')
     
    395412      layerNode.SetAttribute('name', UTF8Decode(LayerName[i]));
    396413      str(LayerOpacity[i]/255:0:3,strval);
    397       layerNode.SetAttribute('opacity',strval);
    398       layerNode.SetAttribute('src',layerFilename);
     414      layerNode.SetAttribute('opacity',widestring(strval));
     415      layerNode.SetAttribute('src',widestring(layerFilename));
    399416      if LayerVisible[i] then
    400417        layerNode.SetAttribute('visibility','visible')
    401418      else
    402419        layerNode.SetAttribute('visibility','hidden');
    403       layerNode.SetAttribute('x',inttostr(LayerOffset[i].x));
    404       layerNode.SetAttribute('y',inttostr(LayerOffset[i].y));
     420      layerNode.SetAttribute('x',widestring(inttostr(LayerOffset[i].x)));
     421      layerNode.SetAttribute('y',widestring(inttostr(LayerOffset[i].y)));
    405422      strval := '';
    406423      case BlendOperation[i] of
     
    428445        else strval := 'svg:src-over';
    429446      end;
    430       layerNode.SetAttribute('composite-op',strval);
     447      layerNode.SetAttribute('composite-op',widestring(strval));
    431448      if BlendOperation[i] <> boTransparent then //in 'transparent' case, linear blending depends on general setting
    432449      begin
     
    434451             boSubtract,boExclusion,boNegation] then
    435452          strval := 'yes' else strval := 'no';
    436         layerNode.SetAttribute('gamma-correction',strval);
     453        layerNode.SetAttribute('gamma-correction',widestring(strval));
    437454      end;
    438455    end;
     
    458475  PrepareZipToSave;
    459476  ZipToFile(filenameUTF8);
     477  ClearFiles;
    460478end;
    461479
     
    464482  PrepareZipToSave;
    465483  ZipToStream(AStream);
     484  ClearFiles;
    466485end;
    467486
     
    593612end;
    594613
    595 procedure TBGRAOpenRasterDocument.UnzipFromStream(AStream: TStream);
     614procedure TBGRAOpenRasterDocument.UnzipFromStream(AStream: TStream;
     615          AFileList: TStrings = nil);
    596616var unzip: TUnZipper;
    597617begin
    598   Clear;
     618  ClearFiles;
    599619  unzip := TUnZipper.Create;
    600620  try
     
    604624    unzip.OnCloseInputStream := @ZipOnCloseInputStream;
    605625    FZipInputStream := AStream;
    606     unzip.UnZipAllFiles;
     626    if Assigned(AFileList) then
     627    begin
     628      if AFileList.Count > 0 then
     629        unzip.UnZipFiles(AFileList);
     630    end else
     631      unzip.UnZipAllFiles;
    607632  finally
    608633    FZipInputStream := nil;
     
    614639var unzip: TUnZipper;
    615640begin
    616   Clear;
     641  ClearFiles;
    617642  unzip := TUnZipper.Create;
    618643  try
     
    661686  if (Width = 0) or (Height = 0) then exit;
    662687  thumbnail := ComputeFlatImage;
    663   CopyBitmapToMemoryStream(thumbnail,'mergedimage.png');
     688  CopyBitmapToMemoryStream(thumbnail,MergedImageFilename);
    664689  if (thumbnail.Width > AMaxWidth) or
    665690   (thumbnail.Height > AMaxHeight) then
     
    709734end;
    710735
     736procedure TBGRAOpenRasterDocument.LoadFlatImageFromStream(AStream: TStream; out
     737  ANbLayers: integer; out ABitmap: TBGRABitmap);
     738var fileList: TStringList;
     739  imgStream, stackStream: TMemoryStream;
     740  imageNode, stackNode: TDOMNode;
     741  i: integer;
     742begin
     743  fileList := TStringList.Create;
     744  fileList.Add(MergedImageFilename);
     745  fileList.Add(LayerStackFilename);
     746  imgStream := nil;
     747  try
     748    UnzipFromStream(AStream, fileList);
     749    imgStream := GetMemoryStream(MergedImageFilename);
     750    if imgStream = nil then
     751      ABitmap := nil
     752    else
     753      ABitmap := TBGRABitmap.Create(imgStream);
     754    ANbLayers := 1;
     755
     756    stackStream := GetMemoryStream(LayerStackFilename);
     757    ReadXMLFile(FStackXML, StackStream);
     758    imageNode := StackXML.FindNode('image');
     759    if Assigned(imagenode) then
     760    begin
     761      stackNode := imageNode.FindNode('stack');
     762      if Assigned(stackNode) then
     763      begin
     764        ANbLayers:= 0;
     765        for i := stackNode.ChildNodes.Length-1 downto 0 do
     766        begin
     767          if stackNode.ChildNodes[i].NodeName = 'layer' then
     768            inc(ANbLayers);
     769        end;
     770      end;
     771    end;
     772
     773  finally
     774    fileList.Free;
     775    ClearFiles;
     776  end;
     777end;
     778
    711779procedure TBGRAOpenRasterDocument.LoadFromStream(AStream: TStream);
    712780begin
     
    717785  finally
    718786    OnLayeredBitmapLoaded;
     787    ClearFiles;
    719788  end;
    720789end;
  • GraphicTest/Packages/bgrabitmap/bgrapalette.pas

    r494 r521  
    9595    procedure ExceptionInvalidPaletteFormat;
    9696  public
    97     constructor Create(ABitmap: TBGRACustomBitmap); virtual; overload;
    98     constructor Create(APalette: TBGRACustomPalette); virtual; overload;
    99     constructor Create(AColors: ArrayOfTBGRAPixel); virtual; overload;
    100     constructor Create(AColors: ArrayOfWeightedColor); virtual; overload;
     97    constructor Create(ABitmap: TBGRACustomBitmap); overload; virtual;
     98    constructor Create(APalette: TBGRACustomPalette); overload; virtual;
     99    constructor Create(AColors: ArrayOfTBGRAPixel); overload; virtual;
     100    constructor Create(AColors: ArrayOfWeightedColor); overload; virtual;
    101101    function AddColor(AValue: TBGRAPixel): boolean; virtual;
    102     procedure AddColors(ABitmap: TBGRACustomBitmap); virtual; overload;
    103     procedure AddColors(APalette: TBGRACustomPalette); virtual; overload;
     102    procedure AddColors(ABitmap: TBGRACustomBitmap); overload; virtual;
     103    procedure AddColors(APalette: TBGRACustomPalette); overload; virtual;
    104104    function RemoveColor(AValue: TBGRAPixel): boolean; virtual;
    105105    procedure LoadFromFile(AFilenameUTF8: string); virtual;
    106106    procedure LoadFromStream(AStream: TStream; AFormat: TBGRAPaletteFormat); virtual;
     107    procedure LoadFromResource(AFilename: string; AFormat: TBGRAPaletteFormat);
    107108    procedure SaveToFile(AFilenameUTF8: string); virtual;
    108109    procedure SaveToStream(AStream: TStream; AFormat: TBGRAPaletteFormat); virtual;
    109     function DetectPaletteFormat(AStream: TStream): TBGRAPaletteFormat; virtual;
    110     function DetectPaletteFormat(AFilenameUTF8: string): TBGRAPaletteFormat;
     110    function DetectPaletteFormat(AStream: TStream): TBGRAPaletteFormat; overload; virtual;
     111    function DetectPaletteFormat(AFilenameUTF8: string): TBGRAPaletteFormat; overload;
    111112    function SuggestPaletteFormat(AFilenameUTF8: string): TBGRAPaletteFormat; virtual;
    112113  end;
     
    164165  public
    165166    function FindNearestColor(AValue: TBGRAPixel; AIgnoreAlpha: boolean): TBGRAPixel; overload;
    166     function FindNearestColor(AValue: TBGRAPixel): TBGRAPixel; virtual; abstract; overload;
     167    function FindNearestColor(AValue: TBGRAPixel): TBGRAPixel; overload; virtual; abstract;
    167168    function FindNearestColorIndex(AValue: TBGRAPixel; AIgnoreAlpha: boolean): integer; overload;
    168     function FindNearestColorIndex(AValue: TBGRAPixel): integer; virtual; abstract; overload;
     169    function FindNearestColorIndex(AValue: TBGRAPixel): integer; overload; virtual; abstract;
    169170    property Weight[AIndex: Integer]: UInt32 read GetWeightByIndex;
    170171  end;
     
    196197    procedure SetReductionColorCount(AValue: Integer); virtual; abstract;
    197198  public
    198     constructor Create(APalette: TBGRACustomPalette; ASeparateAlphaChannel: boolean); virtual; abstract; overload;
    199     constructor Create(ABitmap: TBGRACustomBitmap; AAlpha: TAlphaChannelPaletteOption); virtual; abstract; overload;
    200     constructor Create(APalette: TBGRACustomPalette; ASeparateAlphaChannel: boolean; AReductionColorCount: integer); virtual; abstract; overload;
    201     constructor Create(ABitmap: TBGRACustomBitmap; AAlpha: TAlphaChannelPaletteOption; AReductionColorCount: integer); virtual; abstract; overload;
    202     procedure ApplyDitheringInplace(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; ABounds: TRect); virtual; abstract; overload;
     199    constructor Create(APalette: TBGRACustomPalette; ASeparateAlphaChannel: boolean); overload; virtual; abstract;
     200    constructor Create(AColors: array of TBGRAPixel; ASeparateAlphaChannel: boolean); overload;
     201    constructor Create(ABitmap: TBGRACustomBitmap; AAlpha: TAlphaChannelPaletteOption); overload; virtual; abstract;
     202    constructor Create(APalette: TBGRACustomPalette; ASeparateAlphaChannel: boolean; AReductionColorCount: integer); overload; virtual; abstract;
     203    constructor Create(AColors: array of TBGRAPixel; ASeparateAlphaChannel: boolean; AReductionColorCount: integer); overload;
     204    constructor Create(ABitmap: TBGRACustomBitmap; AAlpha: TAlphaChannelPaletteOption; AReductionColorCount: integer); overload; virtual; abstract;
     205    procedure ApplyDitheringInplace(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; ABounds: TRect); overload; virtual; abstract;
    203206    procedure ApplyDitheringInplace(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap); overload;
    204     function GetDitheredBitmap(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; ABounds: TRect): TBGRACustomBitmap; virtual; abstract; overload;
     207    function GetDitheredBitmap(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; ABounds: TRect): TBGRACustomBitmap; overload; virtual; abstract;
    205208    function GetDitheredBitmap(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap): TBGRACustomBitmap; overload;
    206209    procedure SaveBitmapToFile(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; AFilenameUTF8: string); overload;
     
    210213    function GetDitheredBitmapIndexedData(ABitDepth: integer; AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap): Pointer; overload;
    211214    function GetDitheredBitmapIndexedData(ABitDepth: integer; AByteOrder: TRawImageByteOrder; AAlgorithm: TDitheringAlgorithm;
    212       ABitmap: TBGRACustomBitmap; out AScanlineSize: PtrInt): Pointer; virtual; abstract; overload;
     215      ABitmap: TBGRACustomBitmap; out AScanlineSize: PtrInt): Pointer; overload; virtual; abstract;
    213216    property SourceColorCount: Integer read GetSourceColorCount;
    214217    property SourceColor[AIndex: integer]: TBGRAPixel read GetSourceColor;
     
    605608end;
    606609
     610constructor TBGRACustomColorQuantizer.Create(AColors: array of TBGRAPixel;
     611  ASeparateAlphaChannel: boolean);
     612var palette: TBGRAPalette;
     613  i: Integer;
     614begin
     615  palette := TBGRAPalette.Create;
     616  for i := 0 to high(AColors) do
     617    palette.AddColor(AColors[i]);
     618  Create(palette, ASeparateAlphaChannel);
     619  palette.Free;
     620end;
     621
     622constructor TBGRACustomColorQuantizer.Create(AColors: array of TBGRAPixel;
     623  ASeparateAlphaChannel: boolean; AReductionColorCount: integer);
     624var palette: TBGRAPalette;
     625  i: Integer;
     626begin
     627  palette := TBGRAPalette.Create;
     628  for i := 0 to high(AColors) do
     629    palette.AddColor(AColors[i]);
     630  Create(palette, ASeparateAlphaChannel, AReductionColorCount);
     631  palette.Free;
     632end;
     633
    607634procedure TBGRACustomColorQuantizer.ApplyDitheringInplace(
    608635  AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap);
     
    709736{ TBGRACustomApproxPalette }
    710737
    711 function TBGRACustomApproxPalette.FindNearestColorIgnoreAlpha(AValue: TBGRAPixel
    712   ): TBGRAPixel;
    713 const AlphaMask : DWord = {$IFDEF ENDIAN_LITTLE}$ff000000{$ELSE}$000000ff{$endif};
     738function TBGRACustomApproxPalette.FindNearestColorIgnoreAlpha(AValue: TBGRAPixel): TBGRAPixel;
     739var saveAlpha: byte;
    714740begin
    715741  if AValue.alpha = 0 then
     
    717743  else
    718744  begin
    719     result := FindNearestColor(TBGRAPixel(DWord(AValue) or AlphaMask));
    720     result.alpha := AValue.alpha;
     745    saveAlpha := AValue.alpha;
     746    AValue.alpha := 255;
     747    result := FindNearestColor(AValue);
     748    result.alpha := saveAlpha;
    721749  end;
    722750end;
     
    724752function TBGRACustomApproxPalette.FindNearestColorIndexIgnoreAlpha(
    725753  AValue: TBGRAPixel): integer;
    726 const AlphaMask : DWord = {$IFDEF ENDIAN_LITTLE}$ff000000{$ELSE}$000000ff{$endif};
    727754begin
    728755  if AValue.alpha = 0 then
     
    730757  else
    731758  begin
    732     result := FindNearestColorIndex(TBGRAPixel(DWord(AValue) or AlphaMask));
     759    AValue.alpha := 255;
     760    result := FindNearestColorIndex(AValue);
    733761  end;
    734762end;
     
    12671295end;
    12681296
     1297procedure TBGRAPalette.LoadFromResource(AFilename: string; AFormat: TBGRAPaletteFormat);
     1298var
     1299  stream: TStream;
     1300begin
     1301  stream := BGRAResource.GetResourceStream(AFilename);
     1302  try
     1303    LoadFromStream(stream, AFormat);
     1304  finally
     1305    stream.Free;
     1306  end;
     1307end;
     1308
    12691309procedure TBGRAPalette.SaveToFile(AFilenameUTF8: string);
    12701310var
  • GraphicTest/Packages/bgrabitmap/bgrapath.pas

    r494 r521  
    118118  { TBGRAPath }
    119119
    120   TBGRAPath = class(IBGRAPath)
     120  TBGRAPath = class(TBGRACustomPath)
    121121  protected
    122122    FData: PByte;
     
    160160    function LastCoordDefined: boolean; inline;
    161161    function GetPolygonalApprox(APos: IntPtr; AAcceptedDeviation: single; AIncludeFirstPoint: boolean): ArrayOfTPointF;
    162     function getPoints: ArrayOfTPointF;
    163     function getPoints(AMatrix: TAffineMatrix): ArrayOfTPointF;
    164     function getCursor: TBGRACustomPathCursor;
     162    function getPoints: ArrayOfTPointF; overload;override;
     163    function getPoints(AMatrix: TAffineMatrix): ArrayOfTPointF; overload;override;
     164    function getLength: single; override;
     165    function getCursor: TBGRACustomPathCursor; override;
    165166    procedure InternalDraw(ADrawProc: TBGRAPathDrawProc; const AMatrix: TAffineMatrix; AAcceptedDeviation: single; AData: pointer);
    166167    procedure BitmapDrawSubPathProc(const APoints: array of TPointF; AClosed: boolean; AData: pointer);
    167168    function CorrectAcceptedDeviation(AAcceptedDeviation: single; const AMatrix: TAffineMatrix): single;
    168169  public
    169     constructor Create; overload;
     170    constructor Create; overload; override;
    170171    constructor Create(ASvgString: string); overload;
    171172    constructor Create(const APoints: ArrayOfTPointF); overload;
    172173    constructor Create(APath: IBGRAPath); overload;
    173174    destructor Destroy; override;
    174     procedure beginPath;
     175    procedure beginPath; override;
    175176    procedure beginSubPath;
    176     procedure closePath;
     177    procedure closePath; override;
    177178    procedure translate(x,y: single);
    178179    procedure resetTransform;
     
    184185    procedure moveTo(x,y: single); overload;
    185186    procedure lineTo(x,y: single); overload;
    186     procedure moveTo(const pt: TPointF); overload;
    187     procedure lineTo(const pt: TPointF); overload;
     187    procedure moveTo(constref pt: TPointF); overload; override;
     188    procedure lineTo(constref pt: TPointF); overload; override;
    188189    procedure polyline(const pts: array of TPointF);
    189     procedure polylineTo(const pts: array of TPointF);
     190    procedure polylineTo(const pts: array of TPointF); override;
    190191    procedure polygon(const pts: array of TPointF);
    191192    procedure quadraticCurveTo(cpx,cpy,x,y: single); overload;
    192     procedure quadraticCurveTo(const cp,pt: TPointF); overload;
     193    procedure quadraticCurveTo(constref cp,pt: TPointF); overload; override;
    193194    procedure quadraticCurve(const curve: TQuadraticBezierCurve); overload;
    194195    procedure quadraticCurve(p1,cp,p2: TPointF); overload;
     
    196197    procedure smoothQuadraticCurveTo(const pt: TPointF); overload;
    197198    procedure bezierCurveTo(cp1x,cp1y,cp2x,cp2y,x,y: single); overload;
    198     procedure bezierCurveTo(const cp1,cp2,pt: TPointF); overload;
     199    procedure bezierCurveTo(constref cp1,cp2,pt: TPointF); overload; override;
    199200    procedure bezierCurve(const curve: TCubicBezierCurve); overload;
    200201    procedure bezierCurve(p1,cp1,cp2,p2: TPointF); overload;
     
    209210    procedure arcTo(x1, y1, x2, y2, radius: single); overload;
    210211    procedure arcTo(const p1,p2: TPointF; radius: single); overload;
    211     procedure arc(const arcDef: TArcDef); overload;
     212    procedure arc(constref arcDef: TArcDef); overload; override;
    212213    procedure arc(cx, cy, rx,ry: single; xAngleRadCW, startAngleRadCW, endAngleRadCW: single); overload;
    213214    procedure arc(cx, cy, rx,ry, xAngleRadCW, startAngleRadCW, endAngleRadCW: single; anticlockwise: boolean); overload;
    214     procedure arcTo(rx,ry, xAngleRadCW: single; largeArc, anticlockwise: boolean; x,y:single);
    215     procedure copyTo(dest: IBGRAPath);
     215    procedure arcTo(rx,ry, xAngleRadCW: single; largeArc, anticlockwise: boolean; x,y:single); overload;
     216    procedure copyTo(dest: IBGRAPath); override;
    216217    procedure addPath(const AValue: string); overload;
    217218    procedure addPath(source: IBGRAPath); overload;
    218     procedure openedSpline(const pts: array of TPointF; style: TSplineStyle);
    219     procedure closedSpline(const pts: array of TPointF; style: TSplineStyle);
     219    procedure openedSpline(const pts: array of TPointF; style: TSplineStyle); override;
     220    procedure closedSpline(const pts: array of TPointF; style: TSplineStyle); override;
    220221    property SvgString: string read GetSvgString write SetSvgString;
    221222    function ComputeLength(AAcceptedDeviation: single = 0.1): single;
     
    225226    function GetBounds(AAcceptedDeviation: single = 0.1): TRectF;
    226227    procedure SetPoints(const APoints: ArrayOfTPointF);
    227     procedure stroke(ABitmap: TBGRACustomBitmap; AColor: TBGRAPixel; AWidth: single; AAcceptedDeviation: single = 0.1);
    228     procedure stroke(ABitmap: TBGRACustomBitmap; ATexture: IBGRAScanner; AWidth: single; AAcceptedDeviation: single = 0.1);
    229     procedure stroke(ABitmap: TBGRACustomBitmap; x,y: single; AColor: TBGRAPixel; AWidth: single; AAcceptedDeviation: single = 0.1);
    230     procedure stroke(ABitmap: TBGRACustomBitmap; x,y: single; ATexture: IBGRAScanner; AWidth: single; AAcceptedDeviation: single = 0.1);
    231     procedure stroke(ABitmap: TBGRACustomBitmap; const AMatrix: TAffineMatrix; AColor: TBGRAPixel; AWidth: single; AAcceptedDeviation: single = 0.1);
    232     procedure stroke(ABitmap: TBGRACustomBitmap; const AMatrix: TAffineMatrix; ATexture: IBGRAScanner; AWidth: single; AAcceptedDeviation: single = 0.1);
    233     procedure stroke(ADrawProc: TBGRAPathDrawProc; const AMatrix: TAffineMatrix; AAcceptedDeviation: single = 0.1; AData: pointer = nil);
    234     procedure fill(ABitmap: TBGRACustomBitmap; AColor: TBGRAPixel; AAcceptedDeviation: single = 0.1);
    235     procedure fill(ABitmap: TBGRACustomBitmap; ATexture: IBGRAScanner; AAcceptedDeviation: single = 0.1);
    236     procedure fill(ABitmap: TBGRACustomBitmap; x,y: single; AColor: TBGRAPixel; AAcceptedDeviation: single = 0.1);
    237     procedure fill(ABitmap: TBGRACustomBitmap; x,y: single; ATexture: IBGRAScanner; AAcceptedDeviation: single = 0.1);
    238     procedure fill(ABitmap: TBGRACustomBitmap; const AMatrix: TAffineMatrix; AColor: TBGRAPixel; AAcceptedDeviation: single = 0.1);
    239     procedure fill(ABitmap: TBGRACustomBitmap; const AMatrix: TAffineMatrix; ATexture: IBGRAScanner; AAcceptedDeviation: single = 0.1);
    240     procedure fill(AFillProc: TBGRAPathFillProc; const AMatrix: TAffineMatrix; AAcceptedDeviation: single = 0.1; AData: pointer = nil);
     228    procedure stroke(ABitmap: TBGRACustomBitmap; AColor: TBGRAPixel; AWidth: single; AAcceptedDeviation: single = 0.1); overload;
     229    procedure stroke(ABitmap: TBGRACustomBitmap; ATexture: IBGRAScanner; AWidth: single; AAcceptedDeviation: single = 0.1); overload;
     230    procedure stroke(ABitmap: TBGRACustomBitmap; x,y: single; AColor: TBGRAPixel; AWidth: single; AAcceptedDeviation: single = 0.1); overload;
     231    procedure stroke(ABitmap: TBGRACustomBitmap; x,y: single; ATexture: IBGRAScanner; AWidth: single; AAcceptedDeviation: single = 0.1); overload;
     232    procedure stroke(ABitmap: TBGRACustomBitmap; const AMatrix: TAffineMatrix; AColor: TBGRAPixel; AWidth: single; AAcceptedDeviation: single = 0.1); overload;
     233    procedure stroke(ABitmap: TBGRACustomBitmap; const AMatrix: TAffineMatrix; ATexture: IBGRAScanner; AWidth: single; AAcceptedDeviation: single = 0.1); overload;
     234    procedure stroke(ADrawProc: TBGRAPathDrawProc; const AMatrix: TAffineMatrix; AAcceptedDeviation: single = 0.1; AData: pointer = nil); overload;
     235    procedure fill(ABitmap: TBGRACustomBitmap; AColor: TBGRAPixel; AAcceptedDeviation: single = 0.1); overload;
     236    procedure fill(ABitmap: TBGRACustomBitmap; ATexture: IBGRAScanner; AAcceptedDeviation: single = 0.1); overload;
     237    procedure fill(ABitmap: TBGRACustomBitmap; x,y: single; AColor: TBGRAPixel; AAcceptedDeviation: single = 0.1); overload;
     238    procedure fill(ABitmap: TBGRACustomBitmap; x,y: single; ATexture: IBGRAScanner; AAcceptedDeviation: single = 0.1); overload;
     239    procedure fill(ABitmap: TBGRACustomBitmap; const AMatrix: TAffineMatrix; AColor: TBGRAPixel; AAcceptedDeviation: single = 0.1); overload;
     240    procedure fill(ABitmap: TBGRACustomBitmap; const AMatrix: TAffineMatrix; ATexture: IBGRAScanner; AAcceptedDeviation: single = 0.1); overload;
     241    procedure fill(AFillProc: TBGRAPathFillProc; const AMatrix: TAffineMatrix; AAcceptedDeviation: single = 0.1; AData: pointer = nil); overload;
    241242    function CreateCursor(AAcceptedDeviation: single = 0.1): TBGRAPathCursor;
    242243    procedure Fit(ARect: TRectF; AAcceptedDeviation: single = 0.1);
    243244    procedure FitInto(ADest: TBGRAPath; ARect: TRectF; AAcceptedDeviation: single = 0.1);
    244   protected
    245     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};
    246     function _AddRef: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
    247     function _Release: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
    248245  end;
    249246
     
    258255function ComputeOpenedSpline(const points: array of TPointF; Style: TSplineStyle; EndCoeff: single = 0.25; AAcceptedDeviation: single = 0.1): ArrayOfTPointF;
    259256function ClosedSplineStartPoint(const points: array of TPointF; Style: TSplineStyle): TPointF;
     257function ComputeEasyBezier(const curve: TEasyBezierCurve; AAcceptedDeviation: single = 0.1): ArrayOfTPointF;
    260258
    261259{ Compute points to draw an antialiased ellipse }
    262 function ComputeEllipse(x,y,rx,ry: single; quality: single = 1): ArrayOfTPointF;
    263 function ComputeArc65536(x, y, rx, ry: single; start65536,end65536: word; quality: single = 1): ArrayOfTPointF;
    264 function ComputeArcRad(x, y, rx, ry: single; startRadCCW,endRadCCW: single; quality: single = 1): ArrayOfTPointF;
     260function ComputeEllipse(x,y,rx,ry: single; quality: single = 1): ArrayOfTPointF; overload;
     261function ComputeEllipse(AOrigin, AXAxis, AYAxis: TPointF; quality: single = 1): ArrayOfTPointF; overload;
     262function ComputeArc65536(x, y, rx, ry: single; start65536,end65536: word; quality: single = 1): ArrayOfTPointF; overload;
     263function ComputeArc65536(AOrigin, AXAxis, AYAxis: TPointF; start65536,end65536: word; quality: single = 1): ArrayOfTPointF; overload;
     264function ComputeArcRad(x, y, rx, ry: single; startRadCCW,endRadCCW: single; quality: single = 1): ArrayOfTPointF; overload;
     265function ComputeArcRad(AOrigin, AXAxis, AYAxis: TPointF; startRadCCW,endRadCCW: single; quality: single = 1): ArrayOfTPointF; overload;
    265266function ComputeArc(const arc: TArcDef; quality: single = 1): ArrayOfTPointF;
    266267function ComputeRoundRect(x1,y1,x2,y2,rx,ry: single; quality: single = 1): ArrayOfTPointF; overload;
     
    463464
    464465begin
     466  if Style = ssEasyBezier then
     467  begin
     468    result := ComputeEasyBezier(EasyBezierCurve(points, true, cmCurve));
     469    exit;
     470  end;
     471
    465472  if length(points) <= 2 then
    466473  begin
     
    514521  kernel: TWideKernelFilter;
    515522begin
     523  if Style = ssEasyBezier then
     524  begin
     525    result := ComputeEasyBezier(EasyBezierCurve(points, false, cmCurve));
     526    exit;
     527  end;
     528
    516529  if length(points) <= 2 then
    517530  begin
     
    592605  ptNext2: TPointF;
    593606begin
    594   if length(points) = 0 then
    595     result := EmptyPointF
    596   else
    597   if length(points)<=2 then
    598     result := points[0]
    599   else
    600   begin
    601     kernel := CreateInterpolator(style);
    602     ptPrev2 := points[high(points)];
    603     ptPrev  := points[0];
    604     ptNext  := points[1];
    605     ptNext2 := points[2];
    606     result := ptPrev2*kernel.Interpolation(1) + ptPrev*kernel.Interpolation(0) +
    607               ptNext*kernel.Interpolation(-1)  + ptNext2*kernel.Interpolation(-2);
    608     kernel.free;
    609   end;
     607  if Style = ssEasyBezier then
     608  begin
     609    result := EasyBezierCurve(points, true, cmCurve).CurveStartPoint;
     610  end else
     611  begin
     612    if length(points) = 0 then
     613      result := EmptyPointF
     614    else
     615    if length(points)<=2 then
     616      result := points[0]
     617    else
     618    begin
     619      kernel := CreateInterpolator(style);
     620      ptPrev2 := points[high(points)];
     621      ptPrev  := points[0];
     622      ptNext  := points[1];
     623      ptNext2 := points[2];
     624      result := ptPrev2*kernel.Interpolation(1) + ptPrev*kernel.Interpolation(0) +
     625                ptNext*kernel.Interpolation(-1)  + ptNext2*kernel.Interpolation(-2);
     626      kernel.free;
     627    end;
     628  end;
     629end;
     630
     631function ComputeEasyBezier(const curve: TEasyBezierCurve;
     632  AAcceptedDeviation: single): ArrayOfTPointF;
     633var
     634  path: TBGRAPath;
     635begin
     636  path := TBGRAPath.Create;
     637  curve.CopyToPath(path);
     638  result := path.ToPoints(AAcceptedDeviation);
     639  path.Free;
    610640end;
    611641
     
    654684end;
    655685
     686function ComputeEllipse(AOrigin, AXAxis, AYAxis: TPointF; quality: single): ArrayOfTPointF;
     687begin
     688  result := ComputeArcRad(AOrigin, AXAxis, AYAxis, 0,0, quality);
     689end;
     690
     691function ComputeArc65536(AOrigin, AXAxis, AYAxis: TPointF; start65536,
     692  end65536: word; quality: single): ArrayOfTPointF;
     693begin
     694  //go back temporarily to radians
     695  result := ComputeArcRad(AOrigin,AXAxis,AYAxis, start65536*Pi/326768, end65536*Pi/326768, quality);
     696end;
     697
    656698function ComputeArcRad(x, y, rx, ry: single; startRadCCW, endRadCCW: single;
    657699  quality: single): ArrayOfTPointF;
     
    660702  result[0] := PointF(x+cos(startRadCCW)*rx,y-sin(startRadCCW)*ry);
    661703  result[high(result)] := PointF(x+cos(endRadCCW)*rx,y-sin(endRadCCW)*ry);
     704end;
     705
     706function ComputeArcRad(AOrigin, AXAxis, AYAxis: TPointF; startRadCCW,endRadCCW: single; quality: single): ArrayOfTPointF;
     707var
     708  u, v: TPointF;
     709  lenU, lenV: Single;
     710  m: TAffineMatrix;
     711  i: Integer;
     712begin
     713  u := AXAxis-AOrigin;
     714  lenU := VectLen(u);
     715  v := AYAxis-AOrigin;
     716  lenV := VectLen(v);
     717  if (lenU = 0) and (lenV = 0) then exit(PointsF([AOrigin]));
     718
     719  result := ComputeArcRad(0, 0, lenU, lenV, startRadCCW, endRadCCW, quality);
     720
     721  if lenU <> 0 then u *= 1/lenU;
     722  if lenV <> 0 then v *= 1/lenV;
     723  m := AffineMatrix(u, v, AOrigin);
     724  for i := 0 to high(result) do
     725    result[i] := m*result[i];
    662726end;
    663727
     
    19111975end;
    19121976
     1977function TBGRAPath.getLength: single;
     1978begin
     1979  result := ComputeLength;
     1980end;
     1981
    19131982function TBGRAPath.getCursor: TBGRACustomPathCursor;
    19141983begin
     
    20332102  var numberStart: integer;
    20342103      errPos: integer;
     2104      decimalFind: boolean;
     2105
     2106    procedure parseFloatInternal;
     2107    begin
     2108      if (p <= length(AValue)) and (AValue[p] in['+','-']) then inc(p);
     2109      decimalFind:= false;
     2110      while (p <= length(AValue)) and (AValue[p] in['0'..'9','.']) do
     2111      begin
     2112        if AValue[p] = '.' then
     2113          if decimalFind then
     2114            Break
     2115          else
     2116            decimalFind:= true;
     2117        inc(p);
     2118      end;
     2119    end;
     2120
    20352121  begin
    20362122    while (p <= length(AValue)) and (AValue[p] in[#0..#32,',']) do inc(p);
    20372123    numberStart:= p;
    2038     if (p <= length(AValue)) and (AValue[p] in['+','-']) then inc(p);
    2039     while (p <= length(AValue)) and (AValue[p] in['0'..'9','.']) do inc(p);
     2124    parseFloatInternal;
    20402125    if (p <= length(AValue)) and (AValue[p] in['e','E']) then
    20412126    begin
    20422127      inc(p);
    2043       if (p <= length(AValue)) and (AValue[p] in['+','-']) then inc(p);
    2044       while (p <= length(AValue)) and (AValue[p] in['0'..'9','.']) do inc(p);
     2128      parseFloatInternal;
    20452129    end;
    20462130    val(copy(AValue,numberStart,p-numberStart),result,errPos);
     
    20932177             moveTo(p1);
    20942178             lastCoord := p1;
     2179             startCoord := p1;
    20952180           end;
    20962181           if relative then implicitCommand:= 'l' else
     
    23012386begin
    23022387  OnModify;
     2388  count += 4; //avoid memory error
    23032389  if FDataPos + count > FDataCapacity then
    23042390  begin
     
    26212707end;
    26222708
    2623 procedure TBGRAPath.moveTo(const pt: TPointF);
     2709procedure TBGRAPath.moveTo(constref pt: TPointF);
    26242710begin
    26252711  if FLastSubPathElementType <> peMoveTo then
     
    26372723end;
    26382724
    2639 procedure TBGRAPath.lineTo(const pt: TPointF);
     2725procedure TBGRAPath.lineTo(constref pt: TPointF);
    26402726var lastTransfCoord, newTransfCoord: TPointF;
    26412727begin
     
    26842770end;
    26852771
    2686 procedure TBGRAPath.quadraticCurveTo(const cp, pt: TPointF);
     2772procedure TBGRAPath.quadraticCurveTo(constref cp, pt: TPointF);
    26872773begin
    26882774  if LastCoordDefined then
     
    26992785end;
    27002786
    2701 procedure TBGRAPath.bezierCurveTo(const cp1, cp2, pt: TPointF);
     2787procedure TBGRAPath.bezierCurveTo(constref cp1, cp2, pt: TPointF);
    27022788begin
    27032789  if not LastCoordDefined then moveTo(cp1);
     
    28232909end;
    28242910
    2825 procedure TBGRAPath.arc(const arcDef: TArcDef);
     2911procedure TBGRAPath.arc(constref arcDef: TArcDef);
    28262912var transformedArc: TArcElement;
    28272913begin
     
    29042990end;
    29052991
    2906 function TBGRAPath.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};
    2907 begin
    2908   if GetInterface(iid, obj) then
    2909     Result := S_OK
    2910   else
    2911     Result := longint(E_NOINTERFACE);
    2912 end;
    2913 
    2914 { There is no automatic reference counting, but it is compulsory to define these functions }
    2915 function TBGRAPath._AddRef: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
    2916 begin
    2917   result := 0;
    2918 end;
    2919 
    2920 function TBGRAPath._Release: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
    2921 begin
    2922   result := 0;
    2923 end;
     2992initialization
     2993
     2994  BGRAPathFactory := TBGRAPath;
    29242995
    29252996end.
  • GraphicTest/Packages/bgrabitmap/bgrapen.pas

    r494 r521  
    1818
    1919type
     20  TPenJoinStyle = BGRAGraphics.TPenJoinStyle;
     21  TPenEndCap = BGRAGraphics.TPenEndCap;
    2022
    2123  { TBGRAPenStroker }
     
    5658      constructor Create;
    5759      destructor Destroy; override;
    58       function ComputePolyline(const APoints: array of TPointF; AWidth: single; AClosedCap: boolean = true): ArrayOfTPointF; override;
    59       function ComputePolyline(const APoints: array of TPointF; AWidth: single; APenColor: TBGRAPixel; AClosedCap: boolean = true): ArrayOfTPointF; override;
     60      function ComputePolyline(const APoints: array of TPointF; AWidth: single; AClosedCap: boolean = true): ArrayOfTPointF; overload; override;
     61      function ComputePolyline(const APoints: array of TPointF; AWidth: single; APenColor: TBGRAPixel; AClosedCap: boolean = true): ArrayOfTPointF; overload; override;
    6062      function ComputePolylineAutocycle(const APoints: array of TPointF; AWidth: single): ArrayOfTPointF; override;
    6163      function ComputePolygon(const APoints: array of TPointF; AWidth: single): ArrayOfTPointF; override;
     
    9193//antialiased version
    9294procedure BGRADrawLineAntialias({%H-}dest: TBGRACustomBitmap; x1, y1, x2, y2: integer;
    93   c: TBGRAPixel; DrawLastPixel: boolean; LinearBlend : boolean = false);
     95  c: TBGRAPixel; DrawLastPixel: boolean; LinearBlend : boolean = false); overload;
    9496procedure BGRAEraseLineAntialias(dest: TBGRACustomBitmap; x1, y1, x2, y2: integer;
    95   calpha: byte; DrawLastPixel: boolean);
     97  calpha: byte; DrawLastPixel: boolean); overload;
    9698
    9799//antialiased version with bicolor dashes (to draw a frame)
    98100procedure BGRADrawLineAntialias(dest: TBGRACustomBitmap; x1, y1, x2, y2: integer;
    99   c1, c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean; var DashPos: integer; LinearBlend : boolean = false);
     101  c1, c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean; var DashPos: integer; LinearBlend : boolean = false); overload;
    100102
    101103//length added to ensure accepable alpha join (using TBGRAMultishapeFiller is still better)
     
    110112function IsClearPenStyle(ACustomPenStyle: TBGRAPenStyle): boolean;
    111113function DuplicatePenStyle(ACustomPenStyle: array of single): TBGRAPenStyle;
     114function PenStyleEqual(AStyle1, AStyle2: TBGRAPenStyle): boolean;
     115function BGRAToPenStyle(ACustomPenStyle: TBGRAPenStyle): TPenStyle;
    112116
    113117implementation
     
    636640end;
    637641
     642function BGRAToPenStyle(ACustomPenStyle: TBGRAPenStyle): TPenStyle;
     643begin
     644  if IsSolidPenStyle(ACustomPenStyle) then exit(psSolid);
     645  if IsClearPenStyle(ACustomPenStyle) then exit(psClear);
     646  if PenStyleEqual(ACustomPenStyle, DashPenStyle) then exit(psDash);
     647  if PenStyleEqual(ACustomPenStyle, DotPenStyle) then exit(psDot);
     648  if PenStyleEqual(ACustomPenStyle, DashDotPenStyle) then exit(psDashDot);
     649  if PenStyleEqual(ACustomPenStyle, DashDotDotPenStyle) then exit(psDashDotDot);
     650  exit(psPattern);
     651end;
     652
     653function PenStyleEqual(AStyle1, AStyle2: TBGRAPenStyle): boolean;
     654var
     655  i: Integer;
     656begin
     657  if length(AStyle1)<>length(AStyle2) then exit(false);
     658  for i := 0 to high(AStyle1) do
     659    if AStyle1[i] <> AStyle2[i] then exit(false);
     660  exit(true);
     661end;
     662
    638663procedure ApplyPenStyle(const leftPts, rightPts: array of TPointF; const penstyle: TBGRAPenStyle;
    639664    width: single; var posstyle: single; out styledPts: ArrayOfTPointF);
     
    658683  begin
    659684    dashStartIndex := index;
    660     dashLeftStartPos := leftPts[index] + (leftPts[index+1]-leftPts[index])*t;
    661     dashRightStartPos := rightPts[index] + (rightPts[index+1]-rightPts[index])*t;
     685    if t = 0 then
     686    begin
     687      dashLeftStartPos := leftPts[index];
     688      dashRightStartPos := rightPts[index];
     689    end else
     690    begin
     691      dashLeftStartPos := leftPts[index] + (leftPts[index+1]-leftPts[index])*t;
     692      dashRightStartPos := rightPts[index] + (rightPts[index+1]-rightPts[index])*t;
     693    end;
    662694    betweenDash := false;
    663695  end;
  • GraphicTest/Packages/bgrabitmap/bgraphongtypes.pas

    r494 r521  
    1515     indicate the global height of the map. }
    1616   procedure Draw(dest: TBGRACustomBitmap; map: TBGRACustomBitmap; mapAltitude: integer; ofsX,ofsY: integer;
    17                   Color : TBGRAPixel); virtual; abstract;
     17                  Color : TBGRAPixel);  overload; virtual; abstract;
    1818
    1919   { Render with a color map of the same size as the height map. Map altitude
    2020     indicate the global height of the map. }
    2121   procedure Draw(dest: TBGRACustomBitmap; map: TBGRACustomBitmap; mapAltitude: integer; ofsX,ofsY: integer;
    22                   ColorMap : TBGRACustomBitmap); virtual; abstract;
     22                  ColorMap : TBGRACustomBitmap);  overload; virtual; abstract;
    2323
    2424   { Render with a scanner. Map altitude
  • GraphicTest/Packages/bgrabitmap/bgraphoxo.pas

    r494 r521  
    4646    procedure AddLayerFromPhoxoData(const ABlockHeader: TPhoxoBlockHeader; ABlockData: PByte);
    4747  public
    48     constructor Create; override; overload;
    49     constructor Create(AWidth, AHeight: integer); override; overload;
     48    constructor Create; overload; override;
     49    constructor Create(AWidth, AHeight: integer); overload; override;
    5050    procedure LoadFromStream(AStream: TStream); override;
    5151    procedure LoadFromFile(const filenameUTF8: string); override;
  • GraphicTest/Packages/bgrabitmap/bgrapixel.inc

    r494 r521  
    1717      {$ENDIF}
    1818      {$IFDEF DARWIN}
    19         {$DEFINE BGRABITMAP_RGBAPIXEL}
     19                {$IFNDEF LCLQt}
     20                        {$DEFINE BGRABITMAP_RGBAPIXEL}
     21                {$ENDIF}
    2022      {$ENDIF}
    2123    {$ENDIF}
     
    99101  {** Returns the lightness of a pixel. The lightness is the
    100102     perceived brightness, 0 being black and 65535 being white }
    101   function GetLightness(c: TBGRAPixel): word;
     103  function GetLightness(c: TBGRAPixel): word; overload;
    102104  {** Sets the lightness of a pixel }
    103   function SetLightness(c: TBGRAPixel; lightness: word): TBGRAPixel;
     105  function SetLightness(c: TBGRAPixel; lightness: word): TBGRAPixel; overload;
    104106  {** Sets the lightness quickly, by fading towards black if ''lightness'' is
    105107      less than 32768, and fading towards white if ''lightness'' is more
     
    251253{$i basiccolorspace.inc}
    252254
     255{$DEFINE INCLUDE_INTERFACE}
     256{$i extendedcolorspace.inc}
     257
    253258{$ENDIF}
    254259
     
    258263{$DEFINE INCLUDE_IMPLEMENTATION}
    259264{$i basiccolorspace.inc}
     265
     266{$DEFINE INCLUDE_IMPLEMENTATION}
     267{$i extendedcolorspace.inc}
    260268
    261269function StrToBlendOperation(str: string): TBlendOperation;
     
    417425{$ELSE}
    418426begin
    419   result := int64(lightness1)*lightness2 shr 15;
     427  if (lightness1 < 0) xor (lightness2 < 0) then
     428    result := -(int64(-lightness1)*lightness2 shr 15)
     429  else
     430    result := int64(lightness1)*lightness2 shr 15;
    420431end;
    421432{$ENDIF}
     
    572583end;
    573584
    574 { Convert a TColor value to a TBGRAPixel value. Note that
    575   you need to call ColorToRGB first if you use a system
    576   color identifier like clWindow. }
     585{ Convert a TColor value to a TBGRAPixel value }
    577586{$PUSH}{$R-}
    578587function ColorToBGRA(color: TColor): TBGRAPixel; overload;
    579588begin
     589  if (color < 0) or (color > $ffffff) then color := ColorToRGB(color);
    580590  RedGreenBlue(color, Result.red,Result.green,Result.blue);
    581591  Result.alpha := 255;
     
    584594function ColorToBGRA(color: TColor; opacity: byte): TBGRAPixel; overload;
    585595begin
     596  if (color < 0) or (color > $ffffff) then color := ColorToRGB(color);
    586597  RedGreenBlue(color, Result.red,Result.green,Result.blue);
    587598  Result.alpha := opacity;
     
    709720{$UNDEF INCLUDE_INIT}
    710721  BGRASetGamma();
     722
     723  {$DEFINE INCLUDE_INITIALIZATION}
     724  {$i extendedcolorspace.inc}
    711725{$ENDIF}
  • GraphicTest/Packages/bgrabitmap/bgrapolygon.pas

    r494 r521  
    5656        color: TExpandedPixel;
    5757        bounds: TRect;
    58       end;
    59     procedure AddShape(AInfo: TBGRACustomFillInfo; AInternalInfo: boolean; ATexture: IBGRAScanner; AInternalTexture: TObject; AColor: TBGRAPixel);
     58        fillMode: TFillMode;
     59        fillModeOverride: boolean;
     60      end;
     61    function AddShape(AInfo: TBGRACustomFillInfo; AInternalInfo: boolean; ATexture: IBGRAScanner; AInternalTexture: TObject; AColor: TBGRAPixel): integer; overload;
    6062    function CheckRectangleBorderBounds(var x1, y1, x2, y2: single; w: single): boolean;
    6163    procedure InternalAddStroke(const APoints: array of TPointF; AClosed: boolean; AData: Pointer);
     
    6769    constructor Create;
    6870    destructor Destroy; override;
    69     procedure AddShape(AShape: TBGRACustomFillInfo; AColor: TBGRAPixel);
    70     procedure AddShape(AShape: TBGRACustomFillInfo; ATexture: IBGRAScanner);
    71     procedure AddPolygon(const points: array of TPointF; AColor: TBGRAPixel);
    72     procedure AddPolygon(const points: array of TPointF; ATexture: IBGRAScanner);
    73     procedure AddPathStroke(APath: TBGRAPath; AColor: TBGRAPixel; AWidth: single; AStroker: TBGRACustomPenStroker);
    74     procedure AddPathStroke(APath: TBGRAPath; ATexture: IBGRAScanner; AWidth: single; AStroker: TBGRACustomPenStroker);
    75     procedure AddPathStroke(APath: TBGRAPath; AMatrix: TAffineMatrix; AColor: TBGRAPixel; AWidth: single; AStroker: TBGRACustomPenStroker);
    76     procedure AddPathStroke(APath: TBGRAPath; AMatrix: TAffineMatrix; ATexture: IBGRAScanner; AWidth: single; AStroker: TBGRACustomPenStroker);
    77     procedure AddPathFill(APath: TBGRAPath; AColor: TBGRAPixel);
    78     procedure AddPathFill(APath: TBGRAPath; ATexture: IBGRAScanner);
    79     procedure AddPathFill(APath: TBGRAPath; AMatrix: TAffineMatrix; AColor: TBGRAPixel);
    80     procedure AddPathFill(APath: TBGRAPath; AMatrix: TAffineMatrix; ATexture: IBGRAScanner);
    81     procedure AddPolylineStroke(const points: array of TPointF; AColor: TBGRAPixel; AWidth: single; AStroker: TBGRACustomPenStroker);
    82     procedure AddPolylineStroke(const points: array of TPointF; ATexture: IBGRAScanner; AWidth: single; AStroker: TBGRACustomPenStroker);
    83     procedure AddPolygonStroke(const points: array of TPointF; AColor: TBGRAPixel; AWidth: single; AStroker: TBGRACustomPenStroker);
    84     procedure AddPolygonStroke(const points: array of TPointF; ATexture: IBGRAScanner; AWidth: single; AStroker: TBGRACustomPenStroker);
    85     procedure AddTriangleLinearColor(pt1, pt2, pt3: TPointF; c1, c2, c3: TBGRAPixel);
    86     procedure AddTriangleLinearMapping(pt1, pt2, pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF);
     71    function AddShape(AShape: TBGRACustomFillInfo; AColor: TBGRAPixel): integer; overload;
     72    function AddShape(AShape: TBGRACustomFillInfo; ATexture: IBGRAScanner): integer; overload;
     73    function AddPolygon(const points: array of TPointF; AColor: TBGRAPixel): integer; overload;
     74    function AddPolygon(const points: array of TPointF; ATexture: IBGRAScanner): integer; overload;
     75    procedure AddPathStroke(APath: TBGRAPath; AColor: TBGRAPixel; AWidth: single; AStroker: TBGRACustomPenStroker); overload;
     76    procedure AddPathStroke(APath: TBGRAPath; ATexture: IBGRAScanner; AWidth: single; AStroker: TBGRACustomPenStroker); overload;
     77    procedure AddPathStroke(APath: TBGRAPath; AMatrix: TAffineMatrix; AColor: TBGRAPixel; AWidth: single; AStroker: TBGRACustomPenStroker); overload;
     78    procedure AddPathStroke(APath: TBGRAPath; AMatrix: TAffineMatrix; ATexture: IBGRAScanner; AWidth: single; AStroker: TBGRACustomPenStroker); overload;
     79    function AddPathFill(APath: TBGRAPath; AColor: TBGRAPixel): integer; overload;
     80    function AddPathFill(APath: TBGRAPath; ATexture: IBGRAScanner): integer; overload;
     81    function AddPathFill(APath: TBGRAPath; AMatrix: TAffineMatrix; AColor: TBGRAPixel): integer; overload;
     82    function AddPathFill(APath: TBGRAPath; AMatrix: TAffineMatrix; ATexture: IBGRAScanner): integer; overload;
     83    function AddPolylineStroke(const points: array of TPointF; AColor: TBGRAPixel; AWidth: single; AStroker: TBGRACustomPenStroker): integer; overload;
     84    function AddPolylineStroke(const points: array of TPointF; ATexture: IBGRAScanner; AWidth: single; AStroker: TBGRACustomPenStroker): integer; overload;
     85    function AddPolygonStroke(const points: array of TPointF; AColor: TBGRAPixel; AWidth: single; AStroker: TBGRACustomPenStroker): integer; overload;
     86    function AddPolygonStroke(const points: array of TPointF; ATexture: IBGRAScanner; AWidth: single; AStroker: TBGRACustomPenStroker): integer; overload;
     87    function AddTriangleLinearColor(pt1, pt2, pt3: TPointF; c1, c2, c3: TBGRAPixel): integer;
     88    function AddTriangleLinearMapping(pt1, pt2, pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF): integer;
    8789    procedure AddQuadLinearColor(pt1, pt2, pt3, pt4: TPointF; c1, c2, c3, c4: TBGRAPixel);
    8890    procedure AddQuadLinearMapping(pt1, pt2, pt3, pt4: TPointF; texture: IBGRAScanner; tex1, tex2, {%H-}tex3, tex4: TPointF;
    8991       ACulling: TFaceCulling = fcNone);
    9092    procedure AddQuadPerspectiveMapping(pt1, pt2, pt3, pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF);
    91     procedure AddEllipse(x, y, rx, ry: single; AColor: TBGRAPixel);
    92     procedure AddEllipse(x, y, rx, ry: single; ATexture: IBGRAScanner);
    93     procedure AddEllipseBorder(x, y, rx, ry, w: single; AColor: TBGRAPixel);
    94     procedure AddEllipseBorder(x, y, rx, ry, w: single; ATexture: IBGRAScanner);
    95     procedure AddRoundRectangle(x1, y1, x2, y2, rx, ry: single; AColor: TBGRAPixel; options: TRoundRectangleOptions= []);
    96     procedure AddRoundRectangle(x1, y1, x2, y2, rx, ry: single; ATexture: IBGRAScanner; options: TRoundRectangleOptions= []);
    97     procedure AddRoundRectangleBorder(x1, y1, x2, y2, rx, ry, w: single; AColor: TBGRAPixel; options: TRoundRectangleOptions= []);
    98     procedure AddRoundRectangleBorder(x1, y1, x2, y2, rx, ry, w: single; ATexture: IBGRAScanner; options: TRoundRectangleOptions= []);
    99     procedure AddRectangle(x1, y1, x2, y2: single; AColor: TBGRAPixel);
    100     procedure AddRectangle(x1, y1, x2, y2: single; ATexture: IBGRAScanner);
    101     procedure AddRectangleBorder(x1, y1, x2, y2, w: single; AColor: TBGRAPixel);
    102     procedure AddRectangleBorder(x1, y1, x2, y2, w: single; ATexture: IBGRAScanner);
     93    function AddEllipse(x, y, rx, ry: single; AColor: TBGRAPixel): integer; overload;
     94    function AddEllipse(x, y, rx, ry: single; ATexture: IBGRAScanner): integer; overload;
     95    function AddEllipseBorder(x, y, rx, ry, w: single; AColor: TBGRAPixel): integer; overload;
     96    function AddEllipseBorder(x, y, rx, ry, w: single; ATexture: IBGRAScanner): integer; overload;
     97    function AddRoundRectangle(x1, y1, x2, y2, rx, ry: single; AColor: TBGRAPixel; options: TRoundRectangleOptions= []): integer; overload;
     98    function AddRoundRectangle(x1, y1, x2, y2, rx, ry: single; ATexture: IBGRAScanner; options: TRoundRectangleOptions= []): integer; overload;
     99    function AddRoundRectangleBorder(x1, y1, x2, y2, rx, ry, w: single; AColor: TBGRAPixel; options: TRoundRectangleOptions= []): integer; overload;
     100    function AddRoundRectangleBorder(x1, y1, x2, y2, rx, ry, w: single; ATexture: IBGRAScanner; options: TRoundRectangleOptions= []): integer; overload;
     101    function AddRectangle(x1, y1, x2, y2: single; AColor: TBGRAPixel): integer; overload;
     102    function AddRectangle(x1, y1, x2, y2: single; ATexture: IBGRAScanner): integer; overload;
     103    function AddRectangleBorder(x1, y1, x2, y2, w: single; AColor: TBGRAPixel): integer; overload;
     104    function AddRectangleBorder(x1, y1, x2, y2, w: single; ATexture: IBGRAScanner): integer; overload;
     105    procedure OverrideFillMode(AShapeIndex: integer; AFillMode: TFillMode);
    103106    procedure Draw(dest: TBGRACustomBitmap; ADrawMode: TDrawMode = dmDrawWithTransparency);
     107    property ShapeCount: integer read nbShapes;
    104108  end;
    105109
    106110procedure FillPolyAliased(bmp: TBGRACustomBitmap; points: array of TPointF;
    107   c: TBGRAPixel; EraseMode: boolean; NonZeroWinding: boolean; drawmode: TDrawMode);
     111  c: TBGRAPixel; EraseMode: boolean; NonZeroWinding: boolean; drawmode: TDrawMode; APixelCenteredCoordinates: boolean = true);
    108112procedure FillPolyAliasedWithTexture(bmp: TBGRACustomBitmap; points: array of TPointF;
    109   scan: IBGRAScanner; NonZeroWinding: boolean; drawmode: TDrawMode);
     113  scan: IBGRAScanner; NonZeroWinding: boolean; drawmode: TDrawMode; APixelCenteredCoordinates: boolean = true);
    110114procedure FillPolyAntialias(bmp: TBGRACustomBitmap; points: array of TPointF;
    111   c: TBGRAPixel; EraseMode: boolean; NonZeroWinding: boolean; LinearBlend: boolean = false);
     115  c: TBGRAPixel; EraseMode: boolean; NonZeroWinding: boolean; LinearBlend: boolean = false; APixelCenteredCoordinates: boolean = true);
    112116procedure FillPolyAntialiasWithTexture(bmp: TBGRACustomBitmap; points: array of TPointF;
    113   scan: IBGRAScanner; NonZeroWinding: boolean; LinearBlend: boolean = false);
     117  scan: IBGRAScanner; NonZeroWinding: boolean; LinearBlend: boolean = false; APixelCenteredCoordinates: boolean = true);
    114118
    115119procedure FillEllipseAntialias(bmp: TBGRACustomBitmap; x, y, rx, ry: single;
     
    123127  scan: IBGRAScanner; LinearBlend: boolean = false);
    124128
     129procedure BorderEllipse(bmp: TBGRACustomBitmap; x, y, rx, ry, w: single;
     130  c: TBGRAPixel; EraseMode: boolean; drawmode: TDrawMode);
     131procedure BorderEllipseWithTexture(bmp: TBGRACustomBitmap; x, y, rx, ry, w: single;
     132  scan: IBGRAScanner; drawmode: TDrawMode);
     133
    125134procedure FillRoundRectangleAntialias(bmp: TBGRACustomBitmap; x1, y1, x2, y2, rx, ry: single;
    126   options: TRoundRectangleOptions; c: TBGRAPixel; EraseMode: boolean; LinearBlend: boolean = false);
     135  options: TRoundRectangleOptions; c: TBGRAPixel; EraseMode: boolean; LinearBlend: boolean = false; APixelCenteredCoordinates: boolean = true);
    127136procedure FillRoundRectangleAntialiasWithTexture(bmp: TBGRACustomBitmap; x1, y1, x2, y2, rx, ry: single;
    128   options: TRoundRectangleOptions; scan: IBGRAScanner; LinearBlend: boolean = false);
     137  options: TRoundRectangleOptions; scan: IBGRAScanner; LinearBlend: boolean = false; APixelCenteredCoordinates: boolean = true);
    129138
    130139procedure BorderRoundRectangleAntialias(bmp: TBGRACustomBitmap; x1, y1, x2, y2, rx, ry, w: single;
    131   options: TRoundRectangleOptions; c: TBGRAPixel; EraseMode: boolean; LinearBlend: boolean = false);
     140  options: TRoundRectangleOptions; c: TBGRAPixel; EraseMode: boolean; LinearBlend: boolean = false; APixelCenteredCoordinates: boolean = true);
    132141procedure BorderRoundRectangleAntialiasWithTexture(bmp: TBGRACustomBitmap; x1, y1, x2, y2, rx, ry, w: single;
    133   options: TRoundRectangleOptions; scan: IBGRAScanner; LinearBlend: boolean = false);
     142  options: TRoundRectangleOptions; scan: IBGRAScanner; LinearBlend: boolean = false; APixelCenteredCoordinates: boolean = true);
    134143
    135144procedure BorderAndFillRoundRectangleAntialias(bmp: TBGRACustomBitmap; x1, y1, x2, y2, rx, ry, w: single;
    136   options: TRoundRectangleOptions; bordercolor,fillcolor: TBGRAPixel; bordertexture,filltexture: IBGRAScanner; EraseMode: boolean);
     145  options: TRoundRectangleOptions; bordercolor,fillcolor: TBGRAPixel; bordertexture,filltexture: IBGRAScanner; EraseMode: boolean; APixelCenteredCoordinates: boolean = true);
    137146
    138147implementation
     
    163172  miny, maxy, minx, maxx,
    164173  densMinX, densMaxX: integer;
     174  joinDensity, nextJoinDensity: boolean;
    165175
    166176  density: PDensity;
     
    312322      if optimised then
    313323      begin
     324        nextJoinDensity := false;
    314325        for i := 0 to firstScan.nbinter div 2 - 1 do
    315326        begin
     327          joinDensity := nextJoinDensity;
    316328          x1 := firstScan.inter[i+i].interX;
    317329          x1b := lastScan.inter[i+i].interX;
    318330          x2 := firstScan.inter[i+i+1].interX;
    319331          x2b := lastScan.inter[i+i+1].interX;
     332          nextJoinDensity := not ((i+i+2 >= firstScan.nbInter) or
     333              ((firstScan.inter[i+i+2].interX >= x2+1) and
     334               (lastScan.inter[i+i+2].interX >= x2b+1)));
    320335          if (abs(x1-x1b)<oneOver512) and (abs(x2-x2b)<oneOver512) and
    321              ((i+i+2 >= firstScan.nbInter) or
    322               ((firstScan.inter[i+i+2].interX >= x2+1) and
    323                (lastScan.inter[i+i+2].interX >= x2b+1))) then
     336              not joinDensity and not nextJoinDensity then
    324337          begin
    325338            x1 := (x1+x1b)*0.5;
    326339            x2 := (x2+x2b)*0.5;
     340
     341            if x1 < minx then x1 := minx;
    327342            ix1 := floor(x1);
    328             ix2 := floor(x2);
    329             if ix1 < minx then ix1 := minx;
     343
     344            if x2 >= maxx+1 then
     345            begin
     346              x2 := maxx+1;
     347              ix2 := maxx;
     348            end else
     349              ix2 := floor(x2);
    330350            if ix2 > maxx then ix2 := maxx;
     351
    331352            if ix1>ix2 then continue;
    332353            if ix1=ix2 then
     
    600621
    601622procedure FillPolyAliased(bmp: TBGRACustomBitmap; points: array of TPointF;
    602   c: TBGRAPixel; EraseMode: boolean; NonZeroWinding: boolean; drawmode: TDrawMode);
     623  c: TBGRAPixel; EraseMode: boolean; NonZeroWinding: boolean; drawmode: TDrawMode; APixelCenteredCoordinates: boolean);
    603624var
    604625  info: TCustomFillPolyInfo;
     
    607628    exit;
    608629
    609   info := TOnePassFillPolyInfo.Create(points);
     630  info := TOnePassFillPolyInfo.Create(points, APixelCenteredCoordinates);
    610631  FillShapeAliased(bmp, info, c, EraseMode, nil, NonZeroWinding, drawmode);
    611632  info.Free;
     
    613634
    614635procedure FillPolyAliasedWithTexture(bmp: TBGRACustomBitmap;
    615   points: array of TPointF; scan: IBGRAScanner; NonZeroWinding: boolean; drawmode: TDrawMode);
     636  points: array of TPointF; scan: IBGRAScanner; NonZeroWinding: boolean; drawmode: TDrawMode; APixelCenteredCoordinates: boolean);
    616637var
    617638  info: TCustomFillPolyInfo;
     
    620641    exit;
    621642
    622   info := TOnePassFillPolyInfo.Create(points);
     643  info := TOnePassFillPolyInfo.Create(points, APixelCenteredCoordinates);
    623644  FillShapeAliased(bmp, info, BGRAPixelTransparent,False,scan, NonZeroWinding, drawmode);
    624645  info.Free;
     
    626647
    627648procedure FillPolyAntialias(bmp: TBGRACustomBitmap; points: array of TPointF;
    628   c: TBGRAPixel; EraseMode: boolean; NonZeroWinding: boolean; LinearBlend: boolean);
     649  c: TBGRAPixel; EraseMode: boolean; NonZeroWinding: boolean; LinearBlend: boolean; APixelCenteredCoordinates: boolean);
    629650var
    630651  info: TCustomFillPolyInfo;
     
    633654    exit;
    634655
    635   info := TOnePassFillPolyInfo.Create(points);
     656  info := TOnePassFillPolyInfo.Create(points, APixelCenteredCoordinates);
    636657  FillShapeAntialias(bmp, info, c, EraseMode, nil, NonZeroWinding, LinearBlend);
    637658  info.Free;
     
    639660
    640661procedure FillPolyAntialiasWithTexture(bmp: TBGRACustomBitmap;
    641   points: array of TPointF; scan: IBGRAScanner; NonZeroWinding: boolean; LinearBlend: boolean);
     662  points: array of TPointF; scan: IBGRAScanner; NonZeroWinding: boolean; LinearBlend: boolean; APixelCenteredCoordinates: boolean);
    642663var
    643664  info: TCustomFillPolyInfo;
     
    646667    exit;
    647668
    648   info := TOnePassFillPolyInfo.Create(points);
     669  info := TOnePassFillPolyInfo.Create(points, APixelCenteredCoordinates);
    649670  FillShapeAntialiasWithTexture(bmp, info, scan, NonZeroWinding, LinearBlend);
    650671  info.Free;
     
    703724{ TBGRAMultishapeFiller }
    704725
    705 procedure TBGRAMultishapeFiller.AddShape(AInfo: TBGRACustomFillInfo; AInternalInfo: boolean; ATexture: IBGRAScanner; AInternalTexture: TObject; AColor: TBGRAPixel);
     726function TBGRAMultishapeFiller.AddShape(AInfo: TBGRACustomFillInfo; AInternalInfo: boolean; ATexture: IBGRAScanner; AInternalTexture: TObject; AColor: TBGRAPixel): integer;
    706727begin
    707728  if length(shapes) = nbShapes then
    708729    setlength(shapes, (length(shapes)+1)*2);
    709   with shapes[nbShapes] do
     730  result := nbShapes;
     731  inc(nbShapes);
     732
     733  with shapes[result] do
    710734  begin
    711735    info := AInfo;
     
    714738    internalTexture:= AInternalTexture;
    715739    color := GammaExpansion(AColor);
    716   end;
    717   inc(nbShapes);
     740    fillModeOverride:= false;
     741  end;
    718742end;
    719743
     
    740764  const APoints: array of TPointF; AClosed: boolean; AData: Pointer);
    741765var pts: ArrayOfTPointF;
     766  idxShape: Integer;
    742767begin
    743768  with TPathStrokeData(AData^) do
     
    748773      pts := Stroker.ComputePolylineAutoCycle(APoints, Width);
    749774    if Texture <> nil then
    750       AddPolygon(pts, Texture)
     775      idxShape := AddPolygon(pts, Texture)
    751776    else
    752       AddPolygon(pts, Color);
     777      idxShape := AddPolygon(pts, Color);
     778    OverrideFillMode(idxShape, fmWinding);
    753779  end;
    754780end;
     
    777803end;
    778804
    779 procedure TBGRAMultishapeFiller.AddShape(AShape: TBGRACustomFillInfo; AColor: TBGRAPixel);
    780 begin
    781   AddShape(AShape,False,nil,nil,AColor);
    782 end;
    783 
    784 procedure TBGRAMultishapeFiller.AddShape(AShape: TBGRACustomFillInfo;
    785   ATexture: IBGRAScanner);
    786 begin
    787   AddShape(AShape,False,ATexture,nil,BGRAPixelTransparent);
    788 end;
    789 
    790 procedure TBGRAMultishapeFiller.AddPolygon(const points: array of TPointF;
    791   AColor: TBGRAPixel);
    792 begin
    793   if length(points) <= 2 then exit;
    794   AddShape(TOnePassFillPolyInfo.Create(points),True,nil,nil,AColor);
    795 end;
    796 
    797 procedure TBGRAMultishapeFiller.AddPolygon(const points: array of TPointF;
    798   ATexture: IBGRAScanner);
    799 begin
    800   if length(points) <= 2 then exit;
    801   AddShape(TOnePassFillPolyInfo.Create(points),True,ATexture,nil,BGRAPixelTransparent);
     805function TBGRAMultishapeFiller.AddShape(AShape: TBGRACustomFillInfo;
     806  AColor: TBGRAPixel): integer;
     807begin
     808  result := AddShape(AShape,False,nil,nil,AColor);
     809end;
     810
     811function TBGRAMultishapeFiller.AddShape(AShape: TBGRACustomFillInfo;
     812  ATexture: IBGRAScanner): integer;
     813begin
     814  result := AddShape(AShape,False,ATexture,nil,BGRAPixelTransparent);
     815end;
     816
     817function TBGRAMultishapeFiller.AddPolygon(const points: array of TPointF;
     818  AColor: TBGRAPixel): integer;
     819begin
     820  if length(points) <= 2 then exit(-1);
     821  result := AddShape(TOnePassFillPolyInfo.Create(points),True,nil,nil,AColor);
     822end;
     823
     824function TBGRAMultishapeFiller.AddPolygon(const points: array of TPointF;
     825  ATexture: IBGRAScanner): integer;
     826begin
     827  if length(points) <= 2 then exit(-1);
     828  result := AddShape(TOnePassFillPolyInfo.Create(points),True,ATexture,nil,BGRAPixelTransparent);
    802829end;
    803830
     
    838865end;
    839866
    840 procedure TBGRAMultishapeFiller.AddPathFill(APath: TBGRAPath; AColor: TBGRAPixel);
    841 begin
    842   AddPolygon(APath.ToPoints, AColor);
    843 end;
    844 
    845 procedure TBGRAMultishapeFiller.AddPathFill(APath: TBGRAPath;
    846   ATexture: IBGRAScanner);
    847 begin
    848   AddPolygon(APath.ToPoints, ATexture);
    849 end;
    850 
    851 procedure TBGRAMultishapeFiller.AddPathFill(APath: TBGRAPath;
    852   AMatrix: TAffineMatrix; AColor: TBGRAPixel);
    853 begin
    854   AddPolygon(APath.ToPoints(AMatrix), AColor);
    855 end;
    856 
    857 procedure TBGRAMultishapeFiller.AddPathFill(APath: TBGRAPath;
    858   AMatrix: TAffineMatrix; ATexture: IBGRAScanner);
    859 begin
    860   AddPolygon(APath.ToPoints(AMatrix), ATexture);
    861 end;
    862 
    863 procedure TBGRAMultishapeFiller.AddPolylineStroke(
     867function TBGRAMultishapeFiller.AddPathFill(APath: TBGRAPath; AColor: TBGRAPixel): integer;
     868begin
     869  result := AddPolygon(APath.ToPoints, AColor);
     870end;
     871
     872function TBGRAMultishapeFiller.AddPathFill(APath: TBGRAPath;
     873  ATexture: IBGRAScanner): integer;
     874begin
     875  result := AddPolygon(APath.ToPoints, ATexture);
     876end;
     877
     878function TBGRAMultishapeFiller.AddPathFill(APath: TBGRAPath;
     879  AMatrix: TAffineMatrix; AColor: TBGRAPixel): integer;
     880begin
     881  result := AddPolygon(APath.ToPoints(AMatrix), AColor);
     882end;
     883
     884function TBGRAMultishapeFiller.AddPathFill(APath: TBGRAPath;
     885  AMatrix: TAffineMatrix; ATexture: IBGRAScanner): integer;
     886begin
     887  result := AddPolygon(APath.ToPoints(AMatrix), ATexture);
     888end;
     889
     890function TBGRAMultishapeFiller.AddPolylineStroke(
    864891  const points: array of TPointF; AColor: TBGRAPixel; AWidth: single;
    865   AStroker: TBGRACustomPenStroker);
    866 begin
    867   AddPolygon(AStroker.ComputePolyline(points,AWidth,AColor), AColor);
    868 end;
    869 
    870 procedure TBGRAMultishapeFiller.AddPolylineStroke(
     892  AStroker: TBGRACustomPenStroker): integer;
     893begin
     894  result := AddPolygon(AStroker.ComputePolyline(points,AWidth,AColor), AColor);
     895end;
     896
     897function TBGRAMultishapeFiller.AddPolylineStroke(
    871898  const points: array of TPointF; ATexture: IBGRAScanner; AWidth: single;
    872   AStroker: TBGRACustomPenStroker);
    873 begin
    874   AddPolygon(AStroker.ComputePolyline(points,AWidth), ATexture);
    875 end;
    876 
    877 procedure TBGRAMultishapeFiller.AddPolygonStroke(
    878   const points: array of TPointF; AColor: TBGRAPixel; AWidth: single;
    879   AStroker: TBGRACustomPenStroker);
    880 begin
    881   AddPolygon(AStroker.ComputePolygon(points,AWidth), AColor);
    882 end;
    883 
    884 procedure TBGRAMultishapeFiller.AddPolygonStroke(
    885   const points: array of TPointF; ATexture: IBGRAScanner; AWidth: single;
    886   AStroker: TBGRACustomPenStroker);
    887 begin
    888   AddPolygon(AStroker.ComputePolygon(points,AWidth), ATexture);
    889 end;
    890 
    891 procedure TBGRAMultishapeFiller.AddTriangleLinearColor(pt1, pt2, pt3: TPointF; c1, c2,
    892   c3: TBGRAPixel);
     899  AStroker: TBGRACustomPenStroker): integer;
     900begin
     901  result := AddPolygon(AStroker.ComputePolyline(points,AWidth), ATexture);
     902end;
     903
     904function TBGRAMultishapeFiller.AddPolygonStroke(const points: array of TPointF;
     905  AColor: TBGRAPixel; AWidth: single; AStroker: TBGRACustomPenStroker): integer;
     906begin
     907  result := AddPolygon(AStroker.ComputePolygon(points,AWidth), AColor);
     908end;
     909
     910function TBGRAMultishapeFiller.AddPolygonStroke(const points: array of TPointF;
     911  ATexture: IBGRAScanner; AWidth: single; AStroker: TBGRACustomPenStroker
     912  ): integer;
     913begin
     914  result := AddPolygon(AStroker.ComputePolygon(points,AWidth), ATexture);
     915end;
     916
     917function TBGRAMultishapeFiller.AddTriangleLinearColor(pt1, pt2, pt3: TPointF;
     918  c1, c2, c3: TBGRAPixel): integer;
    893919var grad: TBGRAGradientTriangleScanner;
    894920begin
    895921  if (c1 = c2) and (c2 = c3) then
    896     AddPolygon([pt1,pt2,pt3],c1)
     922    result := AddPolygon([pt1,pt2,pt3],c1)
    897923  else
    898924  begin
    899925    grad := TBGRAGradientTriangleScanner.Create(pt1,pt2,pt3, c1,c2,c3);
    900     AddShape(TOnePassFillPolyInfo.Create([pt1,pt2,pt3]),True,grad,grad,BGRAPixelTransparent);
    901   end;
    902 end;
    903 
    904 procedure TBGRAMultishapeFiller.AddTriangleLinearMapping(pt1, pt2,
    905   pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF);
     926    result := AddShape(TOnePassFillPolyInfo.Create([pt1,pt2,pt3]),True,grad,grad,BGRAPixelTransparent);
     927  end;
     928end;
     929
     930function TBGRAMultishapeFiller.AddTriangleLinearMapping(pt1, pt2, pt3: TPointF;
     931  texture: IBGRAScanner; tex1, tex2, tex3: TPointF): integer;
    906932var
    907933  mapping: TBGRATriangleLinearMapping;
    908934begin
    909935  mapping := TBGRATriangleLinearMapping.Create(texture, pt1,pt2,pt3, tex1, tex2, tex3);
    910   AddShape(TOnePassFillPolyInfo.Create([pt1,pt2,pt3]),True,mapping,mapping,BGRAPixelTransparent);
     936  result := AddShape(TOnePassFillPolyInfo.Create([pt1,pt2,pt3]),True,mapping,mapping,BGRAPixelTransparent);
    911937end;
    912938
     
    952978end;
    953979
    954 procedure TBGRAMultishapeFiller.AddEllipse(x, y, rx, ry: single; AColor: TBGRAPixel
    955   );
    956 begin
    957   AddShape(TFillEllipseInfo.Create(x,y,rx,ry),True,nil,nil,AColor);
    958 end;
    959 
    960 procedure TBGRAMultishapeFiller.AddEllipse(x, y, rx, ry: single;
    961   ATexture: IBGRAScanner);
    962 begin
    963   AddShape(TFillEllipseInfo.Create(x,y,rx,ry),True,ATexture,nil,BGRAPixelTransparent);
    964 end;
    965 
    966 procedure TBGRAMultishapeFiller.AddEllipseBorder(x, y, rx, ry, w: single;
    967   AColor: TBGRAPixel);
    968 begin
    969   AddShape(TFillBorderEllipseInfo.Create(x,y,rx,ry,w),True,nil,nil,AColor);
    970 end;
    971 
    972 procedure TBGRAMultishapeFiller.AddEllipseBorder(x, y, rx, ry, w: single;
    973   ATexture: IBGRAScanner);
    974 begin
    975   AddShape(TFillBorderEllipseInfo.Create(x,y,rx,ry,w),True,ATexture,nil,BGRAPixelTransparent);
    976 end;
    977 
    978 procedure TBGRAMultishapeFiller.AddRoundRectangle(x1, y1, x2, y2, rx, ry: single;
    979   AColor: TBGRAPixel; options: TRoundRectangleOptions);
    980 begin
    981   AddShape(TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry,options),True,nil,nil,AColor);
    982 end;
    983 
    984 procedure TBGRAMultishapeFiller.AddRoundRectangle(x1, y1, x2, y2, rx, ry: single;
    985   ATexture: IBGRAScanner; options: TRoundRectangleOptions);
    986 begin
    987   AddShape(TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry,options),True,
     980function TBGRAMultishapeFiller.AddEllipse(x, y, rx, ry: single;
     981  AColor: TBGRAPixel): integer;
     982begin
     983  result := AddShape(TFillEllipseInfo.Create(x,y,rx,ry),True,nil,nil,AColor);
     984end;
     985
     986function TBGRAMultishapeFiller.AddEllipse(x, y, rx, ry: single;
     987  ATexture: IBGRAScanner): integer;
     988begin
     989  result := AddShape(TFillEllipseInfo.Create(x,y,rx,ry),True,ATexture,nil,BGRAPixelTransparent);
     990end;
     991
     992function TBGRAMultishapeFiller.AddEllipseBorder(x, y, rx, ry, w: single;
     993  AColor: TBGRAPixel): integer;
     994begin
     995  result := AddShape(TFillBorderEllipseInfo.Create(x,y,rx,ry,w),True,nil,nil,AColor);
     996end;
     997
     998function TBGRAMultishapeFiller.AddEllipseBorder(x, y, rx, ry, w: single;
     999  ATexture: IBGRAScanner): integer;
     1000begin
     1001  result := AddShape(TFillBorderEllipseInfo.Create(x,y,rx,ry,w),True,ATexture,nil,BGRAPixelTransparent);
     1002end;
     1003
     1004function TBGRAMultishapeFiller.AddRoundRectangle(x1, y1, x2, y2, rx,
     1005  ry: single; AColor: TBGRAPixel; options: TRoundRectangleOptions): integer;
     1006begin
     1007  result := AddShape(TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry,options),True,nil,nil,AColor);
     1008end;
     1009
     1010function TBGRAMultishapeFiller.AddRoundRectangle(x1, y1, x2, y2, rx,
     1011  ry: single; ATexture: IBGRAScanner; options: TRoundRectangleOptions): integer;
     1012begin
     1013  result := AddShape(TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry,options),True,
    9881014     ATexture,nil,BGRAPixelTransparent);
    9891015end;
    9901016
    991 procedure TBGRAMultishapeFiller.AddRoundRectangleBorder(x1, y1, x2, y2, rx,
    992   ry, w: single; AColor: TBGRAPixel; options: TRoundRectangleOptions);
    993 begin
    994   AddShape(TFillBorderRoundRectInfo.Create(x1, y1, x2, y2, rx, ry,w,options),True,
     1017function TBGRAMultishapeFiller.AddRoundRectangleBorder(x1, y1, x2, y2, rx, ry,
     1018  w: single; AColor: TBGRAPixel; options: TRoundRectangleOptions): integer;
     1019begin
     1020  result := AddShape(TFillBorderRoundRectInfo.Create(x1, y1, x2, y2, rx, ry,w,options),True,
    9951021    nil,nil,AColor);
    9961022end;
    9971023
    998 procedure TBGRAMultishapeFiller.AddRoundRectangleBorder(x1, y1, x2, y2, rx, ry,
    999   w: single; ATexture: IBGRAScanner; options: TRoundRectangleOptions);
    1000 begin
    1001   AddShape(TFillBorderRoundRectInfo.Create(x1, y1, x2, y2, rx, ry,w,options),True,
     1024function TBGRAMultishapeFiller.AddRoundRectangleBorder(x1, y1, x2, y2, rx, ry,
     1025  w: single; ATexture: IBGRAScanner; options: TRoundRectangleOptions): integer;
     1026begin
     1027  result := AddShape(TFillBorderRoundRectInfo.Create(x1, y1, x2, y2, rx, ry,w,options),True,
    10021028    ATexture,nil,BGRAPixelTransparent);
    10031029end;
    10041030
    1005 procedure TBGRAMultishapeFiller.AddRectangle(x1, y1, x2, y2: single;
    1006   AColor: TBGRAPixel);
    1007 begin
    1008   AddPolygon([PointF(x1,y1),PointF(x2,y1),PointF(x2,y2),PointF(x1,y2)],AColor);
    1009 end;
    1010 
    1011 procedure TBGRAMultishapeFiller.AddRectangle(x1, y1, x2, y2: single;
    1012   ATexture: IBGRAScanner);
    1013 begin
    1014   AddPolygon([PointF(x1,y1),PointF(x2,y1),PointF(x2,y2),PointF(x1,y2)],ATexture);
    1015 end;
    1016 
    1017 procedure TBGRAMultishapeFiller.AddRectangleBorder(x1, y1, x2, y2,
    1018   w: single; AColor: TBGRAPixel);
     1031function TBGRAMultishapeFiller.AddRectangle(x1, y1, x2, y2: single;
     1032  AColor: TBGRAPixel): integer;
     1033begin
     1034  result := AddPolygon([PointF(x1,y1),PointF(x2,y1),PointF(x2,y2),PointF(x1,y2)],AColor);
     1035end;
     1036
     1037function TBGRAMultishapeFiller.AddRectangle(x1, y1, x2, y2: single;
     1038  ATexture: IBGRAScanner): integer;
     1039begin
     1040  result := AddPolygon([PointF(x1,y1),PointF(x2,y1),PointF(x2,y2),PointF(x1,y2)],ATexture);
     1041end;
     1042
     1043function TBGRAMultishapeFiller.AddRectangleBorder(x1, y1, x2, y2, w: single;
     1044  AColor: TBGRAPixel): integer;
    10191045var hw : single;
    10201046begin
    10211047  hw := w/2;
    10221048  if not CheckRectangleBorderBounds(x1,y1,x2,y2,w) then
    1023     AddRectangle(x1-hw,y1-hw,x2+hw,y2+hw,AColor) else
    1024     AddPolygon([PointF(x1-hw,y1-hw),PointF(x2+hw,y1-hw),PointF(x2+hw,y2+hw),PointF(x1-hw,y2+hw),EmptyPointF,
     1049    result := AddRectangle(x1-hw,y1-hw,x2+hw,y2+hw,AColor) else
     1050    result := AddPolygon([PointF(x1-hw,y1-hw),PointF(x2+hw,y1-hw),PointF(x2+hw,y2+hw),PointF(x1-hw,y2+hw),EmptyPointF,
    10251051                PointF(x1+hw,y2-hw),PointF(x2-hw,y2-hw),PointF(x2-hw,y1+hw),PointF(x1+hw,y1+hw)],AColor);
    10261052end;
    10271053
    1028 procedure TBGRAMultishapeFiller.AddRectangleBorder(x1, y1, x2, y2,
    1029   w: single; ATexture: IBGRAScanner);
     1054function TBGRAMultishapeFiller.AddRectangleBorder(x1, y1, x2, y2, w: single;
     1055  ATexture: IBGRAScanner): integer;
    10301056var hw : single;
    10311057begin
    10321058  hw := w/2;
    10331059  if not CheckRectangleBorderBounds(x1,y1,x2,y2,w) then
    1034     AddRectangle(x1-hw,y1-hw,x2+hw,y2+hw,ATexture) else
    1035     AddPolygon([PointF(x1-hw,y1-hw),PointF(x2+hw,y1-hw),PointF(x2+hw,y2+hw),PointF(x1-hw,y2+hw),EmptyPointF,
     1060    result := AddRectangle(x1-hw,y1-hw,x2+hw,y2+hw,ATexture) else
     1061    result := AddPolygon([PointF(x1-hw,y1-hw),PointF(x2+hw,y1-hw),PointF(x2+hw,y2+hw),PointF(x1-hw,y2+hw),EmptyPointF,
    10361062                PointF(x1+hw,y2-hw),PointF(x2-hw,y2-hw),PointF(x2-hw,y1+hw),PointF(x1+hw,y1+hw)],ATexture);
     1063end;
     1064
     1065procedure TBGRAMultishapeFiller.OverrideFillMode(AShapeIndex: integer;
     1066  AFillMode: TFillMode);
     1067begin
     1068  if AShapeIndex < 0 then exit;
     1069  if AShapeIndex >= nbShapes then raise exception.Create('Index out of bounds');
     1070  shapes[AShapeIndex].fillMode := AFillMode;
     1071  shapes[AShapeIndex].fillModeOverride := true;
    10371072end;
    10381073
     
    11161151      begin
    11171152        //find intersections
    1118         info.ComputeAndSort(cury, inter, nbInter, FillMode=fmWinding);
     1153        info.ComputeAndSort(cury, inter, nbInter, fillMode=fmWinding);
    11191154        nbInter := nbInter and not 1; //even
    11201155      end;
     
    11501185            if ix2 > densMaxx then densMaxx := ix2;
    11511186
    1152             FillWord(density[ix1-minx],ix2-ix1+1,256);
     1187            if ix2 >= ix1 then
     1188              FillWord(density[ix1-minx],ix2-ix1+1,256);
    11531189          end;
    11541190        end else
    1155                   {$DEFINE INCLUDE_FILLDENSITY}
     1191          {$DEFINE INCLUDE_FILLDENSITY}
    11561192          {$i density256.inc}
    11571193      end;
     
    11741210  bounds: TRect;
    11751211
    1176   xb, yb, yc, j,k: integer;
     1212  xb, yb, yc, k: integer;
    11771213  pdest:    PBGRAPixel;
    11781214
    11791215  curSum,nextSum: ^TCardinalSum;
    11801216  sums: array of TCardinalSum;
     1217  curAlpha: byte;
    11811218
    11821219  pdens: PDensity;
    1183   w: cardinal;
     1220  w: UInt32or64;
    11841221  ec: TExpandedPixel;
    11851222  count: integer;
     
    11881225begin
    11891226  if nbShapes = 0 then exit;
     1227  for k := 0 to nbShapes-1 do
     1228    if not shapes[k].fillModeOverride then shapes[k].fillMode:= fillMode;
     1229
    11901230  useAA := Antialiasing and (ADrawMode in [dmDrawWithTransparency,dmLinearBlend]);
    11911231  if nbShapes = 1 then
    11921232  begin
    11931233    if useAA then
    1194       FillShapeAntialias(dest,shapes[0].info,GammaCompression(shapes[0].color),False,shapes[0].texture,FillMode = fmWinding, ADrawMode=dmLinearBlend) else
    1195       FillShapeAliased(dest,shapes[0].info,GammaCompression(shapes[0].color),False,shapes[0].texture,FillMode = fmWinding, ADrawMode,
     1234      FillShapeAntialias(dest,shapes[0].info,GammaCompression(shapes[0].color),False,shapes[0].texture,shapes[0].fillMode = fmWinding, ADrawMode=dmLinearBlend) else
     1235      FillShapeAliased(dest,shapes[0].info,GammaCompression(shapes[0].color),False,shapes[0].texture,shapes[0].fillMode = fmWinding, ADrawMode,
    11961236        AliasingIncludeBottomRight);
    11971237    exit;
     
    12351275    AliasingOfs := PointF(-0.0001,-0.0001);
    12361276
    1237   setlength(sums,maxx-minx+2); //more for safety
     1277  setlength(sums,maxx-minx+1);
    12381278  setlength(shapeRowsList, nbShapes);
    12391279
     
    12671307    end;
    12681308
    1269     rowminx := minx;
    1270     rowmaxx := maxx;
     1309    if rowminx < minx then rowminx := minx;
     1310    if rowmaxx > maxx then rowmaxx := maxx;
     1311
    12711312    if rowminx <= rowmaxx then
    12721313    begin
    1273       if rowminx < minx then rowminx := minx;
    1274       if rowmaxx > maxx then rowmaxx := maxx;
    1275 
    12761314      FillChar(sums[rowminx-minx],(rowmaxx-rowminx+1)*sizeof(sums[0]),0);
    12771315
     
    12981336                ec.green := (sumG+sumA shr 1) div sumA;
    12991337                ec.blue := (sumB+sumA shr 1) div sumA;
    1300                 if sumA > 255 then sumA := 255;
    1301                 ec.alpha := sumA shl 8 + sumA;
     1338                if sumA > 255 then curAlpha := 255 else curAlpha := sumA;
     1339                ec.alpha := curAlpha shl 8 + curAlpha;
    13021340                count := 1;
    13031341                while (xb < rowmaxx) and (nextSum^.sumA = sumA) and (nextSum^.sumB = sumB)
     
    13091347                end;
    13101348                if count = 1 then
    1311                   DrawExpandedPixelInlineNoAlphaCheck(pdest,ec,sumA) else
     1349                  DrawExpandedPixelInlineNoAlphaCheck(pdest,ec,curAlpha) else
    13121350                   DrawExpandedPixelsInline(pdest, ec, count );
    13131351                inc(pdest,count-1);
     
    13301368                ec.green := (sumG+sumA shr 1) div sumA;
    13311369                ec.blue := (sumB+sumA shr 1) div sumA;
    1332                 if sumA > 255 then sumA := 255;
    1333                 ec.alpha := sumA shl 8 + sumA;
     1370                if sumA > 255 then curAlpha := 255 else curAlpha := sumA;
     1371                ec.alpha := curAlpha shl 8 + curAlpha;
    13341372                count := 1;
    13351373                while (xb < rowmaxx) and (nextSum^.sumA = sumA) and (nextSum^.sumB = sumB)
     
    13421380                if count = 1 then
    13431381                  DrawPixelInlineNoAlphaCheck(pdest,GammaCompression(ec)) else
     1382                begin
    13441383                   DrawPixelsInline(pdest, GammaCompression(ec), count );
    1345                 inc(pdest,count-1);
     1384                   inc(pdest,count-1);
     1385                end;
    13461386              end;
    13471387            end;
     
    13621402                ec.green := (sumG+sumA shr 1) div sumA;
    13631403                ec.blue := (sumB+sumA shr 1) div sumA;
    1364                 if sumA > 255 then sumA := 255;
    1365                 ec.alpha := sumA shl 8 + sumA;
     1404                if sumA > 255 then curAlpha := 255 else curAlpha := sumA;
     1405                ec.alpha := curAlpha shl 8 + curAlpha;
    13661406                count := 1;
    13671407                while (xb < rowmaxx) and (nextSum^.sumA = sumA) and (nextSum^.sumB = sumB)
     
    13921432                ec.green := (sumG+sumA shr 1) div sumA;
    13931433                ec.blue := (sumB+sumA shr 1) div sumA;
    1394                 if sumA > 255 then sumA := 255;
    1395                 ec.alpha := sumA shl 8 + sumA;
     1434                if sumA > 255 then curAlpha := 255 else curAlpha := sumA;
     1435                ec.alpha := curAlpha shl 8 + curAlpha;
    13961436                count := 1;
    13971437                while (xb < rowmaxx) and (nextSum^.sumA = sumA) and (nextSum^.sumB = sumB)
     
    14221462                ec.green := (sumG+sumA shr 1) div sumA;
    14231463                ec.blue := (sumB+sumA shr 1) div sumA;
    1424                 if sumA > 255 then sumA := 255;
    1425                 ec.alpha := sumA shl 8 + sumA;
     1464                if sumA > 255 then curAlpha := 255 else curAlpha := sumA;
     1465                ec.alpha := curAlpha shl 8 + curAlpha;
    14261466                count := 1;
    14271467                while (xb < rowmaxx) and (nextSum^.sumA = sumA) and (nextSum^.sumB = sumB)
     
    14541494end;
    14551495
     1496procedure BorderEllipse(bmp: TBGRACustomBitmap; x, y, rx, ry, w: single;
     1497  c: TBGRAPixel; EraseMode: boolean; drawmode: TDrawMode);
     1498var
     1499  info: TFillBorderEllipseInfo;
     1500begin
     1501  if ((rx = 0) and (ry = 0)) or (w=0) or (x = EmptySingle) or (y = EmptySingle) then
     1502    exit;
     1503  info := TFillBorderEllipseInfo.Create(x, y, rx, ry, w);
     1504  FillShapeAliased(bmp, info, c, EraseMode, nil, False, drawmode);
     1505  info.Free;
     1506end;
     1507
     1508procedure BorderEllipseWithTexture(bmp: TBGRACustomBitmap; x, y, rx, ry,
     1509  w: single; scan: IBGRAScanner; drawmode: TDrawMode);
     1510var
     1511  info: TFillBorderEllipseInfo;
     1512begin
     1513  if ((rx = 0) and (ry = 0)) or (w=0) or (x = EmptySingle) or (y = EmptySingle) then
     1514    exit;
     1515  info := TFillBorderEllipseInfo.Create(x, y, rx, ry, w);
     1516  FillShapeAliased(bmp, info, BGRAPixelTransparent, False, scan, false, drawmode);
     1517  info.Free;
     1518end;
     1519
    14561520procedure FillRoundRectangleAntialias(bmp: TBGRACustomBitmap; x1, y1, x2, y2,
    1457   rx, ry: single; options: TRoundRectangleOptions; c: TBGRAPixel; EraseMode: boolean; LinearBlend: boolean);
     1521  rx, ry: single; options: TRoundRectangleOptions; c: TBGRAPixel; EraseMode: boolean; LinearBlend: boolean; APixelCenteredCoordinates: boolean);
    14581522var
    14591523  info: TFillRoundRectangleInfo;
    14601524begin
    14611525  if (x1 = x2) or (y1 = y2) then exit;
    1462   info := TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry, options);
     1526  info := TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry, options, APixelCenteredCoordinates);
    14631527  FillShapeAntialias(bmp, info, c, EraseMode,nil, False, LinearBlend);
    14641528  info.Free;
     
    14671531procedure FillRoundRectangleAntialiasWithTexture(bmp: TBGRACustomBitmap; x1,
    14681532  y1, x2, y2, rx, ry: single; options: TRoundRectangleOptions;
    1469   scan: IBGRAScanner; LinearBlend: boolean);
     1533  scan: IBGRAScanner; LinearBlend: boolean; APixelCenteredCoordinates: boolean);
    14701534var
    14711535  info: TFillRoundRectangleInfo;
    14721536begin
    14731537  if (x1 = x2) or (y1 = y2) then exit;
    1474   info := TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry, options);
     1538  info := TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry, options, APixelCenteredCoordinates);
    14751539  FillShapeAntialiasWithTexture(bmp, info, scan, False, LinearBlend);
    14761540  info.Free;
     
    14791543procedure BorderRoundRectangleAntialias(bmp: TBGRACustomBitmap; x1, y1, x2,
    14801544  y2, rx, ry, w: single; options: TRoundRectangleOptions; c: TBGRAPixel;
    1481   EraseMode: boolean; LinearBlend: boolean);
     1545  EraseMode: boolean; LinearBlend: boolean; APixelCenteredCoordinates: boolean);
    14821546var
    14831547  info: TFillShapeInfo;
     
    14931557    exit;
    14941558  end;
    1495   info := TFillBorderRoundRectInfo.Create(x1, y1, x2,y2, rx, ry, w, options);
     1559  info := TFillBorderRoundRectInfo.Create(x1, y1, x2,y2, rx, ry, w, options, APixelCenteredCoordinates);
    14961560  FillShapeAntialias(bmp, info, c, EraseMode, nil, False, LinearBlend);
    14971561  info.Free;
     
    15001564procedure BorderRoundRectangleAntialiasWithTexture(bmp: TBGRACustomBitmap; x1,
    15011565  y1, x2, y2, rx, ry, w: single; options: TRoundRectangleOptions;
    1502   scan: IBGRAScanner; LinearBlend: boolean);
     1566  scan: IBGRAScanner; LinearBlend: boolean; APixelCenteredCoordinates: boolean);
    15031567var
    15041568  info: TFillBorderRoundRectInfo;
     
    15141578    exit;
    15151579  end;
    1516   info := TFillBorderRoundRectInfo.Create(x1, y1, x2,y2, rx, ry, w, options);
     1580  info := TFillBorderRoundRectInfo.Create(x1, y1, x2,y2, rx, ry, w, options, APixelCenteredCoordinates);
    15171581  FillShapeAntialiasWithTexture(bmp, info, scan, False, LinearBlend);
    15181582  info.Free;
     
    15211585procedure BorderAndFillRoundRectangleAntialias(bmp: TBGRACustomBitmap; x1, y1,
    15221586  x2, y2, rx, ry, w: single; options: TRoundRectangleOptions; bordercolor,
    1523   fillcolor: TBGRAPixel; bordertexture,filltexture: IBGRAScanner; EraseMode: boolean);
     1587  fillcolor: TBGRAPixel; bordertexture,filltexture: IBGRAScanner; EraseMode: boolean; APixelCenteredCoordinates: boolean);
    15241588var
    15251589  info: TFillBorderRoundRectInfo;
     
    15271591begin
    15281592  if (rx = 0) or (ry = 0) then exit;
    1529   info := TFillBorderRoundRectInfo.Create(x1, y1, x2,y2, rx, ry, w, options);
     1593  info := TFillBorderRoundRectInfo.Create(x1, y1, x2,y2, rx, ry, w, options, APixelCenteredCoordinates);
    15301594  if not EraseMode then
    15311595  begin
  • GraphicTest/Packages/bgrabitmap/bgrapolygonaliased.pas

    r494 r521  
    105105      ANumSegment: integer; dy: single; AData: pointer); override;
    106106  public
    107     constructor Create(const points: array of TPointF; const texCoords: array of TPointF);
    108     constructor Create(const points: array of TPointF; const texCoords: array of TPointF; const lightnesses: array of word);
     107    constructor Create(const points: array of TPointF; const texCoords: array of TPointF); overload;
     108    constructor Create(const points: array of TPointF; const texCoords: array of TPointF; const lightnesses: array of word); overload;
    109109    function CreateSegmentData(numPt,nextPt: integer; x,y: single): pointer; override;
    110110    function CreateIntersectionInfo: TIntersectionInfo; override;
     
    150150      ANumSegment: integer; dy: single; AData: pointer); override;
    151151  public
    152     constructor Create(const points: array of TPointF; const pointsZ: array of single; const texCoords: array of TPointF);
    153     constructor Create(const points: array of TPointF; const pointsZ: array of single; const texCoords: array of TPointF; const lightnesses: array of word);
     152    constructor Create(const points: array of TPointF; const pointsZ: array of single; const texCoords: array of TPointF); overload;
     153    constructor Create(const points: array of TPointF; const pointsZ: array of single; const texCoords: array of TPointF; const lightnesses: array of word); overload;
    154154    function CreateSegmentData(numPt,nextPt: integer; x,y: single): pointer; override;
    155155    function CreateIntersectionInfo: TIntersectionInfo; override;
     
    165165      ANumSegment: integer; dy: single; AData: pointer); override;
    166166  public
    167     constructor Create(const points: array of TPointF; const points3D: array of TPoint3D; const normals: array of TPoint3D; const texCoords: array of TPointF);
    168     constructor Create(const points: array of TPointF; const points3D: array of TPoint3D_128; const normals: array of TPoint3D_128; const texCoords: array of TPointF);
     167    constructor Create(const points: array of TPointF; const points3D: array of TPoint3D; const normals: array of TPoint3D; const texCoords: array of TPointF); overload;
     168    constructor Create(const points: array of TPointF; const points3D: array of TPoint3D_128; const normals: array of TPoint3D_128; const texCoords: array of TPointF); overload;
    169169    function CreateSegmentData(numPt,nextPt: integer; x,y: single): pointer; override;
    170170    function CreateIntersectionInfo: TIntersectionInfo; override;
     
    196196  DX, DY: integer; BorderColor, FillColor: TBGRAPixel; FillTexture: IBGRAScanner = nil; ADrawMode: TDrawMode = dmDrawWithTransparency;
    197197  skipFill: boolean = false);
     198procedure BGRAFillRoundRectAliased(dest: TBGRACustomBitmap; X1, Y1, X2, Y2: integer;
     199  DX, DY: integer; FillColor: TBGRAPixel; FillTexture: IBGRAScanner = nil; ADrawMode: TDrawMode = dmDrawWithTransparency);
    198200
    199201implementation
    200202
    201 uses Math, BGRABlend;
     203uses Math, BGRABlend, BGRAPolygon;
    202204
    203205{ TPolygonPerspectiveColorGradientInfo }
     
    10181020end;
    10191021
     1022procedure BGRAFillRoundRectAliased(dest: TBGRACustomBitmap; X1, Y1, X2,
     1023  Y2: integer; DX, DY: integer; FillColor: TBGRAPixel;
     1024  FillTexture: IBGRAScanner; ADrawMode: TDrawMode);
     1025var
     1026  fi: TFillRoundRectangleInfo;
     1027begin
     1028  fi := TFillRoundRectangleInfo.Create(x1,y1,x2,y2,dx/2,dy/2,[rrDefault],false);
     1029  FillShapeAliased(dest, fi, FillColor, false, FillTexture, true, ADrawMode);
     1030  fi.Free;
     1031end;
     1032
    10201033end.
    10211034
  • GraphicTest/Packages/bgrabitmap/bgraqtbitmap.pas

    r494 r521  
    4040  public
    4141    procedure DataDrawTransparent(ACanvas: TCanvas; Rect: TRect;
    42       AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
    43       override;
     42      AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); override;
     43    procedure DataDrawOpaque(ACanvas: TCanvas; ARect: TRect; AData: Pointer;
     44      ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); override;
    4445    procedure Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean = True); override;
    4546    procedure Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean = True); override;
     
    6970  SlowDrawTransparent(Temp, ACanvas, Rect);
    7071  Temp.Free;
     72end;
     73
     74procedure TBGRAQtBitmap.DataDrawOpaque(ACanvas: TCanvas; ARect: TRect;
     75  AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
     76var psrc,pdest: PBGRAPixel;
     77  bmp: TBGRAQtBitmap;
     78begin
     79  {$IFDEF DARWIN}
     80  bmp := TBGRAQtBitmap.Create(AWidth,AHeight);
     81  try
     82    if ALineOrder = riloTopToBottom then psrc := AData
     83    else psrc := PBGRAPixel(AData) + (AWidth*AHeight);
     84    for y := 0 to AHeight-1 do
     85    begin
     86      pdest := bmp.ScanLine[y];
     87      for x := 0 to AWidth-1 do
     88      begin
     89        pdest^.red := psrc^.red;
     90        pdest^.green:= psrc^.green;
     91        pdest^.blue := psrc^.blue;
     92        pdest^.alpha := 255;
     93      end;
     94      if ALineOrder = riloBottomToTop then psrc -= 2*AWidth;
     95    end;
     96    bmp.Draw(ACanvas, ARect, false);
     97  finally
     98    bmp.Free;
     99  end;
     100  {$ELSE}
     101  inherited DataDrawOpaque(ACanvas, ARect, AData, ALineOrder, AWidth, AHeight);
     102  {$ENDIF}
    71103end;
    72104
  • GraphicTest/Packages/bgrabitmap/bgrareadbmp.pas

    r494 r521  
    2424   - direct access to pixels with TBGRABitmap
    2525   - vertical shrink option with MinifyHeight,WantedHeight,OutputHeight (useful for thumbnails)
     26  01/2017 by circular:
     27   - support for OS/2 1.x format
     28   - support for headerless files
    2629}
    2730
     
    3740type
    3841  TBMPTransparencyOption = (toAuto, toTransparent, toOpaque);
     42  TBitMapInfoHeader = BMPcomn.TBitMapInfoHeader;
     43  TBitMapFileHeader = BMPcomn.TBitMapFileHeader;
     44  TOS2BitmapHeader = packed record
     45    bcSize: DWORD;
     46    bcWidth: Word;
     47    bcHeight: Word;
     48    bcPlanes: Word;
     49    bcBitCount: Word;
     50  end;
     51  TMinimumBitmapHeader = packed record
     52    Size:longint;
     53    Width:longint;
     54    Height:longint;
     55    Planes:word;
     56    BitCount:word;
     57  end;
     58  TBitmapSubFormat = (bsfWithFileHeader, bsfHeaderless, bsfHeaderlessWithMask);
     59  TReadScanlineProc = procedure(Row : Integer; Stream : TStream) of object;
     60  TWriteScanlineProc = procedure(Row : Integer; Img : TFPCustomImage) of object;
     61  TProgressProc = procedure(Percent: integer; var ShouldContinue: boolean) of object;
     62
    3963
    4064  { TBGRAReaderBMP }
    4165
    42   TBGRAReaderBMP = class (TFPCustomImageReader)
     66  TBGRAReaderBMP = class (TBGRAImageReader)
    4367    Private
    4468      DeltaX, DeltaY : integer; // Used for the never-used delta option in RLE
    4569      TopDown : boolean;        // If set, bitmap is stored top down instead of bottom up
    46       continue : boolean;       // needed for onprogress event
    47       Rect : TRect;
    4870      Procedure FreeBufs;       // Free (and nil) buffers.
    4971    protected
    5072      ReadSize : Integer;       // Size (in bytes) of 1 scanline.
    51       BFI : TBitMapInfoHeader;  // The header as read from the stream.
     73      BFH: TBitMapFileHeader;    // The file header
     74      BFI: TBitMapInfoHeader;  // The header as read from the stream.
     75      FPaletteEntrySize: integer;  // 4 for Windows, 3 for OS/2 1.x
    5276      FPalette : PFPcolor;      // Buffer with Palette entries. (useless now)
    5377      FBGRAPalette : PBGRAPixel;
     
    6286      FBufferStream: TStream;
    6387      FHasAlphaValues: boolean;
     88      FMaskData: PByte;
     89      FMaskDataSize: integer;
    6490      // SetupRead will allocate the needed buffers, and read the colormap if needed.
    6591      procedure SetupRead(nPalette, nRowBits: Integer; Stream : TStream); virtual;
     
    74100      procedure WriteScanLine(Row : Integer; Img : TFPCustomImage); virtual;
    75101      procedure WriteScanLineBGRA(Row : Integer; Img : TFPCustomImage); virtual;
     102      procedure ReadMaskLine({%H-}Row : Integer; Stream : TStream); virtual;
     103      procedure SkipMaskLine({%H-}Row : Integer; Stream : TStream); virtual;
     104      procedure WriteMaskLine(Row : Integer; Img : TFPCustomImage); virtual;
    76105      // required by TFPCustomImageReader
    77106      procedure InternalRead  (Stream:TStream; Img:TFPCustomImage); override;
     
    81110      function GetNextBufferByte: byte;
    82111      procedure MakeOpaque(Img: TFPCustomImage);
     112      procedure LoadMask(Stream:TStream; Img:TFPCustomImage; var ShouldContinue: boolean);
     113      procedure MainProgressProc(Percent: integer; var ShouldContinue: boolean);
     114      procedure ImageVerticalLoop(Stream:TStream; Img:TFPCustomImage;
     115        ReadProc, SkipProc: TReadScanlineProc; WriteProc: TWriteScanlineProc;
     116        ProgressProc: TProgressProc; var ShouldContinue: boolean);
    83117    public
    84118      MinifyHeight,WantedHeight: integer;
     119      Hotspot: TPoint;
     120      Subformat: TBitmapSubFormat;
    85121      constructor Create; override;
    86122      destructor Destroy; override;
     
    88124      property OutputHeight: integer read FOutputHeight;
    89125      property TransparencyOption: TBMPTransparencyOption read FTransparencyOption write FTransparencyOption;
    90   end;
     126      function GetQuickInfo(AStream: TStream): TQuickImageInfo; override;
     127      function GetBitmapDraft(AStream: TStream; {%H-}AMaxWidth, AMaxHeight: integer; out AOriginalWidth,AOriginalHeight: integer): TBGRACustomBitmap; override;
     128  end;
     129
     130function MakeBitmapFileHeader(AData: TStream): TBitMapFileHeader;
    91131
    92132implementation
    93133
    94 type
    95   TWriteScanlineProc = procedure (Row : Integer; Img : TFPCustomImage) of object;
    96 
     134uses math;
     135
     136function MakeBitmapFileHeader(AData: TStream): TBitMapFileHeader;
     137var header: PBitMapInfoHeader;
     138  headerSize: integer;
     139  extraSize: integer;
     140  os2header: TOS2BitmapHeader;
     141begin
     142  AData.Position := 0;
     143  headerSize := LEtoN(AData.ReadDWord);
     144  if headerSize = sizeof(TOS2BitmapHeader) then //OS2 1.x
     145  begin
     146    AData.ReadBuffer({%H-}os2header,sizeof(os2header));
     147    if LEtoN(os2header.bcBitCount) in [1,2,4,8] then
     148    begin
     149      extraSize := 3*(1 shl LEtoN(os2header.bcBitCount));
     150    end else
     151      extraSize := 0;
     152    result.bfType:= Word('BM');
     153    result.bfSize := NtoLE(Integer(sizeof(TBitMapFileHeader) + AData.Size));
     154    result.bfReserved:= 0;
     155    result.bfOffset := NtoLE(Integer(sizeof(TBitMapFileHeader) + headerSize + extraSize));
     156  end else
     157  begin
     158    if (headerSize < 16) or (headerSize > AData.Size) or (headerSize > 1024) then
     159      raise exception.Create('Invalid header size');
     160    getmem(header, headerSize);
     161    try
     162      fillchar(header^, headerSize,0);
     163      header^.Size := NtoLE(headerSize);
     164      AData.ReadBuffer((PByte(header)+4)^, headerSize-4);
     165      if LEtoN(header^.Compression) = BI_BITFIELDS then
     166        extraSize := 4*3
     167      else if LEtoN(header^.BitCount) in [1,2,4,8] then
     168      begin
     169        if header^.ClrUsed > 0 then
     170          extraSize := 4*header^.ClrUsed
     171        else
     172          extraSize := 4*(1 shl header^.BitCount);
     173      end else
     174        extraSize := 0;
     175      result.bfType:= Word('BM');
     176      result.bfSize := NtoLE(Integer(sizeof(TBitMapFileHeader) + AData.Size));
     177      result.bfReserved:= 0;
     178      result.bfOffset := NtoLE(Integer(sizeof(TBitMapFileHeader) + headerSize + extraSize));
     179    finally
     180      freemem(header);
     181    end;
     182  end;
     183end;
    97184
    98185function RGBAToFPColor(Const RGBA: TColorRGBA) : TFPcolor;
    99 
    100186begin
    101187  with Result, RGBA do
     
    125211  inherited create;
    126212  FTransparencyOption := toTransparent;
     213  Subformat:= bsfWithFileHeader;
    127214end;
    128215
     
    134221end;
    135222
     223function TBGRAReaderBMP.GetQuickInfo(AStream: TStream): TQuickImageInfo;
     224var headerSize: dword;
     225  os2header: TOS2BitmapHeader;
     226  minHeader: TMinimumBitmapHeader;
     227  totalDepth: integer;
     228  headerPos: int64;
     229begin
     230  fillchar({%H-}result, sizeof(result), 0);
     231  headerPos := AStream.Position;
     232  if AStream.Read({%H-}headerSize, sizeof(headerSize)) <> sizeof(headerSize) then exit;
     233  headerSize := LEtoN(headerSize);
     234
     235  //check presence of file header
     236  if (headerSize and $ffff) = BMmagic then
     237  begin
     238    headerPos += sizeof(TBitMapFileHeader);
     239    AStream.Position := headerPos;
     240    if AStream.Read(headerSize, sizeof(headerSize)) <> sizeof(headerSize) then exit;
     241    headerSize := LEtoN(headerSize);
     242  end;
     243
     244  AStream.Position := headerPos;
     245
     246  if headerSize = sizeof(TOS2BitmapHeader) then //OS2 1.x
     247  begin
     248    if AStream.Read({%H-}os2header, sizeof(os2header)) <> sizeof(os2header) then exit;
     249    result.width := LEtoN(os2header.bcWidth);
     250    result.height := LEtoN(os2header.bcHeight);
     251    result.colorDepth := LEtoN(os2header.bcBitCount);
     252    result.alphaDepth := 0;
     253  end
     254  else
     255  if headerSize >= sizeof(minHeader) then
     256  begin
     257    if AStream.Read({%H-}minHeader, sizeof(minHeader)) <> sizeof(minHeader) then exit;
     258    result.width := LEtoN(minHeader.Width);
     259    result.height := LEtoN(minHeader.Height);
     260    totalDepth := LEtoN(minHeader.BitCount);
     261    if totalDepth > 24 then
     262    begin
     263      result.colorDepth:= 24;
     264      result.alphaDepth:= 8;
     265    end else
     266    begin
     267      result.colorDepth := totalDepth;
     268      result.alphaDepth:= 0;
     269    end;
     270  end else
     271  begin
     272    result.width := 0;
     273    result.height:= 0;
     274    result.colorDepth:= 0;
     275    result.alphaDepth:= 0;
     276  end;
     277end;
     278
     279function TBGRAReaderBMP.GetBitmapDraft(AStream: TStream; AMaxWidth,
     280  AMaxHeight: integer; out AOriginalWidth, AOriginalHeight: integer): TBGRACustomBitmap;
     281var
     282  bmpFormat: TBGRAReaderBMP;
     283  prevStreamPos: Int64;
     284begin
     285  bmpFormat:= TBGRAReaderBMP.Create;
     286  bmpFormat.Subformat:= Subformat;
     287  bmpFormat.MinifyHeight := AMaxHeight*2;
     288  result := BGRABitmapFactory.Create;
     289  prevStreamPos := AStream.Position;
     290  try
     291    result.LoadFromStream(AStream, bmpFormat);
     292    AOriginalWidth:= result.Width;
     293    AOriginalHeight:= bmpFormat.OriginalHeight;
     294  finally
     295    bmpFormat.Free;
     296    AStream.Position := prevStreamPos;
     297  end;
     298end;
     299
    136300procedure TBGRAReaderBMP.FreeBufs;
    137 
    138301begin
    139302  If (LineBuf<>Nil) then
     
    233396var
    234397  ColInfo: ARRAY OF TColorRGBA;
    235   i: Integer;
     398  ColInfo3: packed array of TColorRGB;
     399  i,colorPresent: Integer;
    236400
    237401begin
     
    262426    SetLength(ColInfo, nPalette);
    263427    if BFI.ClrUsed>0 then
    264       Stream.Read(ColInfo[0],BFI.ClrUsed*SizeOf(TColorRGBA))
    265     else // Seems to me that this is dangerous.
    266       Stream.Read(ColInfo[0],nPalette*SizeOf(TColorRGBA));
     428      colorPresent:= min(BFI.ClrUsed,nPalette)
     429    else
     430      colorPresent:= nPalette;
     431    if FPaletteEntrySize = 3 then
     432    begin
     433      setlength(ColInfo3, nPalette);
     434      Stream.Read(ColInfo3[0],colorPresent*SizeOf(TColorRGB));
     435      for i := 0 to colorPresent-1 do
     436        ColInfo[i].RGB := ColInfo3[i];
     437    end
     438    else
     439    begin
     440      Stream.Read(ColInfo[0],colorPresent*SizeOf(TColorRGBA));
     441    end;
    267442    for i := 0 to High(ColInfo) do
    268443    begin
     
    282457
    283458Var
    284   PrevSourceRow,SourceRow, i, pallen, SourceRowDelta, SourceLastRow : Integer;
     459  i, pallen : Integer;
    285460  BadCompression : boolean;
    286461  WriteScanlineProc: TWriteScanlineProc;
    287   SourceRowAdd: integer;
    288   SourceRowAcc,SourceRowMod: integer;
    289   SourceRowAccAdd: integer;
    290   OutputLastRow, OutputRow, OutputRowDelta: integer;
    291 
    292   prevPercent, percent, percentAdd : byte;
    293   percentMod : longword;
    294   percentAcc, percentAccAdd : longword;
    295 
    296 begin
    297   Rect.Left:=0; Rect.Top:=0; Rect.Right:=0; Rect.Bottom:=0;
    298   continue:=true;
    299   Progress(psStarting,0,false,Rect,'',continue);
    300   if not continue then exit;
    301   Stream.Read(BFI,SizeOf(BFI));
    302   {$IFDEF ENDIAN_BIG}
    303   SwapBMPInfoHeader(BFI);
    304   {$ENDIF}
     462  headerSize: longword;
     463  os2header: TOS2BitmapHeader;
     464  shouldContinue: boolean;
     465
     466begin
     467  shouldContinue:=true;
     468  Progress(psStarting,0,false,EmptyRect,'',shouldContinue);
     469  if not shouldContinue then exit;
     470
     471  headerSize := LEtoN(Stream.ReadDWord);
     472  fillchar({%H-}BFI,SizeOf(BFI),0);
     473  if headerSize = sizeof(TOS2BitmapHeader) then
     474  begin
     475    fillchar({%H-}os2header,SizeOf(os2header),0);
     476    Stream.Read(os2header.bcWidth,min(SizeOf(os2header),headerSize)-sizeof(DWord));
     477    BFI.Size := 16;
     478    BFI.Width := LEtoN(os2header.bcWidth);
     479    BFI.Height := LEtoN(os2header.bcHeight);
     480    BFI.Planes := LEtoN(os2header.bcPlanes);
     481    BFI.BitCount := LEtoN(os2header.bcBitCount);
     482    FPaletteEntrySize:= 3;
     483  end else
     484  begin
     485    Stream.Read(BFI.Width,min(SizeOf(BFI),headerSize)-sizeof(DWord));
     486    {$IFDEF ENDIAN_BIG}
     487    SwapBMPInfoHeader(BFI);
     488    {$ENDIF}
     489    BFI.Size := headerSize;
     490    FPaletteEntrySize:= 4;
     491  end;
    305492  { This will move past any junk after the BFI header }
    306493  Stream.Position:=Stream.Position-SizeOf(BFI)+BFI.Size;
     
    339526      32:
    340527        SetupRead(0,Width*8*4,Stream);
    341     end;
    342   end;
     528    else raise exception.Create('Invalid bit depth ('+inttostr(BFI.BitCount)+')');
     529    end;
     530  end;
     531  if Subformat = bsfHeaderlessWithMask then BFI.Height := BFI.Height div 2;
    343532  Try
    344533    { Note: it would be better to Fill the image palette in setupread instead of creating FPalette.
     
    350539    if pallen>0 then
    351540    begin
     541      if FPalette = nil then raise exception.Create('Internal error: palette object not initialized');
    352542      Img.Palette.Count:=pallen;
    353543      for i:=0 to pallen-1 do
    354544        Img.Palette.Color[i]:=FPalette[i];
    355545    end;
    356     if MinifyHeight < BFI.Height then FOutputHeight:= MinifyHeight else
    357     if WantedHeight <> 0 then FOutputHeight:= WantedHeight else
    358       FOutputHeight:= 0;
    359 
    360     percent:=0;
    361     percentAdd := 100 div BFI.Height;
    362     percentAcc:=BFI.Height div 2;
    363     percentAccAdd := 100 mod BFI.Height;
    364     percentMod:=BFI.Height;
    365 
    366     DeltaX:=-1; DeltaY:=-1;
    367     if TopDown then
    368     begin
    369       SourceRowDelta := 1;
    370       SourceRow := 0;
    371       SourceLastRow := BFI.Height-1;
    372     end else
    373     begin
    374       SourceRowDelta := -1;
    375       SourceRow := BFI.Height-1;
    376       SourceLastRow := 0;
    377     end;
    378     OutputRowDelta:= SourceRowDelta;
    379     if (OutputHeight <= 0) or (OutputHeight = BFI.Height) then
    380     begin
    381       SourceRowAdd := SourceRowDelta;
    382       SourceRowAcc := 0;
    383       SourceRowAccAdd := 0;
    384       SourceRowMod := 1;
    385       OutputRow := SourceRow;
    386       OutputLastRow := SourceLastRow;
    387       Img.SetSize(BFI.Width,BFI.Height);
    388     end else
    389     begin
    390       SourceRowAdd := (BFI.Height div OutputHeight)*SourceRowDelta;
    391       SourceRowAcc := OutputHeight div 2;
    392       SourceRowAccAdd := BFI.Height mod OutputHeight;
    393       SourceRowMod := OutputHeight;
    394       If TopDown then
    395       begin
    396         OutputRow := 0;
    397         OutputLastRow := OutputHeight-1;
    398       end
    399       else
    400       begin
    401         OutputRow := OutputHeight-1;
    402         OutputLastRow := 0;
    403       end;
    404       Img.SetSize(BFI.Width,OutputHeight);
    405     end;
     546    if (MinifyHeight > 0) and (MinifyHeight < BFI.Height) then FOutputHeight:= MinifyHeight else
     547    if WantedHeight > 0 then FOutputHeight:= WantedHeight else
     548      FOutputHeight:= BFI.Height;
     549
     550    if (BFI.Compression=BI_RLE8) or(BFI.Compression=BI_RLE4) then InitReadBuffer(Stream,2048);
     551    FHasAlphaValues:= false;
     552
     553    Img.SetSize(BFI.Width,FOutputHeight);
     554
    406555    if Img is TBGRACustomBitmap then
    407556      WriteScanlineProc := @WriteScanLineBGRA else
    408557        WriteScanlineProc := @WriteScanLine;
    409     PrevSourceRow := SourceRow-SourceRowDelta;
    410     if (BFI.Compression=BI_RLE8) or(BFI.Compression=BI_RLE4) then InitReadBuffer(Stream,2048);
    411     FHasAlphaValues:= false;
    412     while SourceRow <> SourceLastRow+SourceRowDelta do
    413     begin
    414       while PrevSourceRow <> SourceRow do
    415       begin
    416         inc(PrevSourceRow, SourceRowDelta);
    417         if PrevSourceRow = SourceRow then
    418           ReadScanLine(PrevSourceRow,Stream)
    419         else
    420           SkipScanLine(PrevSourceRow,Stream);
    421       end;
    422       WriteScanLineProc(OutputRow,Img);
    423       if OutputRow = OutputLastRow then break;
    424       if not continue then exit;
    425 
    426       inc(OutputRow,OutputRowDelta);
    427       inc(SourceRow,SourceRowAdd);
    428       inc(SourceRowAcc,SourceRowAccAdd);
    429       if SourceRowAcc >= SourceRowMod then
    430       begin
    431        dec(SourceRowAcc,SourceRowMod);
    432        Inc(SourceRow,SourceRowDelta);
    433       end;
    434 
    435       prevPercent := percent;
    436       inc(percent,percentAdd);
    437       inc(percentAcc,percentAccAdd);
    438       if percentAcc>=percentMod then inc(percent);
    439       if percent<>prevPercent then Progress(psRunning,percent,false,Rect,'',continue);
    440     end;
    441     if not FHasAlphaValues and (TransparencyOption = toAuto) and (BFI.BitCount = 32) then
    442       MakeOpaque(Img);
    443     Progress(psEnding,100,false,Rect,'',continue);
     558
     559    ImageVerticalLoop(Stream, Img, @ReadScanLine, @SkipScanLine, WriteScanlineProc,
     560                      @MainProgressProc, shouldContinue);
     561
     562    if shouldContinue then
     563    begin
     564      if not FHasAlphaValues and (TransparencyOption = toAuto) and (BFI.BitCount = 32) then
     565        MakeOpaque(Img);
     566      if (BFI.Compression=BI_RLE8) or(BFI.Compression=BI_RLE4) then CloseReadBuffer;
     567
     568      if Subformat = bsfHeaderlessWithMask then LoadMask(Stream,Img, shouldContinue);
     569
     570      Progress(psEnding,100,false,EmptyRect,'',shouldContinue);
     571    end;
     572
    444573  finally
    445     if (BFI.Compression=BI_RLE8) or(BFI.Compression=BI_RLE4) then CloseReadBuffer;
    446574    FreeBufs;
    447575  end;
     
    729857        for Column:=0 to img.Width-1 do
    730858        begin
    731           PDest^:= BGRA((PSrc)^,(PSrc+1)^,(PSrc+2)^,(PSrc+3)^);
     859          PDest^:= BGRA((PSrc+2)^,(PSrc+1)^,(PSrc)^,(PSrc+3)^);
    732860          if PDest^.alpha <> 0 then FHasAlphaValues:= true;
    733861          inc(PDest);
     
    750878end;
    751879
     880procedure TBGRAReaderBMP.ReadMaskLine(Row: Integer; Stream: TStream);
     881begin
     882  FillChar(FMaskData^, FMaskDataSize, 0);
     883  Stream.Read(FMaskData^, FMaskDataSize);
     884end;
     885
     886procedure TBGRAReaderBMP.SkipMaskLine(Row: Integer; Stream: TStream);
     887begin
     888  Stream.Position := Stream.Position+FMaskDataSize;
     889end;
     890
     891procedure TBGRAReaderBMP.WriteMaskLine(Row: Integer; Img: TFPCustomImage);
     892var x, maskPos: integer;
     893  bit: byte;
     894  bmp: TBGRACustomBitmap;
     895  pimg: PBGRAPixel;
     896begin
     897  if Img is TBGRACustomBitmap then
     898    bmp := TBGRACustomBitmap(Img)
     899  else
     900    exit;
     901
     902  maskPos := 0;
     903  bit := $80;
     904  pimg := bmp.ScanLine[Row];
     905  for x := 0 to bmp.Width-1 do
     906  begin
     907    if (FMaskData[maskPos] and bit) <> 0 then //if AND mask is non zero, value is kept
     908    begin
     909      if pimg^.alpha = 255 then
     910      begin
     911        pimg^.alpha := 0;
     912        if dword(pimg^) <> 0 then
     913        begin
     914         bmp.NeedXorMask;
     915         bmp.XorMask.SetPixel(x,Row,pimg^);
     916        end;
     917      end;
     918    end;
     919    inc(pimg);
     920    bit := bit shr 1;
     921    if bit = 0 then
     922    begin
     923      bit := $80;
     924      inc(maskPos);
     925    end;
     926  end;
     927end;
     928
    752929function  TBGRAReaderBMP.InternalCheck (Stream:TStream) : boolean;
    753 
    754 var
    755   {%H-}BFH:TBitMapFileHeader;
    756 begin
    757   stream.Read({%H-}BFH,SizeOf(BFH));
    758   {$IFDEF ENDIAN_BIG}
    759   SwapBMPFileHeader(BFH);
    760   {$ENDIF}
    761   With BFH do
    762     Result:=(bfType=BMmagic); // Just check magic number
     930begin
     931  fillchar(BFH, sizeof(BFH), 0);
     932  if Subformat in [bsfHeaderless,bsfHeaderlessWithMask] then
     933  begin
     934   result := true;
     935   Hotspot := Point(0,0);
     936  end else
     937  begin
     938    if stream.Read(BFH,SizeOf(BFH)) <> sizeof(BFH) then
     939    begin
     940      result := false;
     941      exit;
     942    end;
     943    Hotspot := Point(LEtoN(PWord(@BFH.bfReserved)^),LEtoN((PWord(@BFH.bfReserved)+1)^));
     944    {$IFDEF ENDIAN_BIG}
     945    SwapBMPFileHeader(BFH);
     946    {$ENDIF}
     947    With BFH do
     948      Result:=(bfType=BMmagic); // Just check magic number
     949  end;
    763950end;
    764951
     
    8141001end;
    8151002
     1003procedure TBGRAReaderBMP.LoadMask(Stream: TStream; Img: TFPCustomImage; var ShouldContinue: boolean);
     1004begin
     1005  if Img is TBGRACustomBitmap then TBGRACustomBitmap(Img).DiscardXorMask;
     1006  FMaskDataSize := ((Img.Width+31) div 32)*4; //padded to dword
     1007  getmem(FMaskData, FMaskDataSize);
     1008  try
     1009    ImageVerticalLoop(Stream,Img, @ReadMaskLine, @SkipMaskLine, @WriteMaskLine, nil, ShouldContinue);
     1010  finally
     1011    freemem(FMaskData);
     1012    FMaskData := nil;
     1013    FMaskDataSize := 0;
     1014  end;
     1015end;
     1016
     1017procedure TBGRAReaderBMP.MainProgressProc(Percent: integer;
     1018  var ShouldContinue: boolean);
     1019begin
     1020  Progress(psRunning,Percent,false,EmptyRect,'',ShouldContinue);
     1021end;
     1022
     1023procedure TBGRAReaderBMP.ImageVerticalLoop(Stream: TStream;
     1024  Img: TFPCustomImage; ReadProc, SkipProc: TReadScanlineProc;
     1025  WriteProc: TWriteScanlineProc; ProgressProc: TProgressProc;
     1026  var ShouldContinue: boolean);
     1027var
     1028  prevPercent, percent, percentAdd : byte;
     1029  percentMod : longword;
     1030  percentAcc, percentAccAdd : longword;
     1031  PrevSourceRow,SourceRow, SourceRowDelta, SourceLastRow: integer;
     1032  SourceRowAdd: integer;
     1033  SourceRowAcc,SourceRowMod: integer;
     1034  SourceRowAccAdd: integer;
     1035  OutputLastRow, OutputRow, OutputRowDelta: integer;
     1036begin
     1037  if OutputHeight <= 0 then exit;
     1038
     1039  percent:=0;
     1040  percentAdd := 100 div BFI.Height;
     1041  percentAcc:=BFI.Height div 2;
     1042  percentAccAdd := 100 mod BFI.Height;
     1043  percentMod:=BFI.Height;
     1044
     1045  DeltaX:=-1; DeltaY:=-1;
     1046  if TopDown then
     1047  begin
     1048    SourceRowDelta := 1;
     1049    SourceRow := 0;
     1050    SourceLastRow := BFI.Height-1;
     1051  end else
     1052  begin
     1053    SourceRowDelta := -1;
     1054    SourceRow := BFI.Height-1;
     1055    SourceLastRow := 0;
     1056  end;
     1057  OutputRowDelta:= SourceRowDelta;
     1058
     1059  SourceRowAdd := (BFI.Height div OutputHeight)*SourceRowDelta;
     1060  SourceRowAcc := OutputHeight div 2;
     1061  SourceRowAccAdd := BFI.Height mod OutputHeight;
     1062  SourceRowMod := OutputHeight;
     1063  If TopDown then
     1064  begin
     1065    OutputRow := 0;
     1066    OutputLastRow := OutputHeight-1;
     1067  end
     1068  else
     1069  begin
     1070    OutputRow := OutputHeight-1;
     1071    OutputLastRow := 0;
     1072  end;
     1073
     1074  PrevSourceRow := SourceRow-SourceRowDelta;
     1075
     1076  while ShouldContinue and (SourceRow <> SourceLastRow+SourceRowDelta) do
     1077  begin
     1078    while PrevSourceRow <> SourceRow do
     1079    begin
     1080      inc(PrevSourceRow, SourceRowDelta);
     1081      if PrevSourceRow = SourceRow then
     1082        ReadProc(PrevSourceRow,Stream)
     1083      else
     1084        SkipProc(PrevSourceRow,Stream);
     1085    end;
     1086    WriteProc(OutputRow,Img);
     1087    if OutputRow = OutputLastRow then break;
     1088
     1089    inc(OutputRow,OutputRowDelta);
     1090    inc(SourceRow,SourceRowAdd);
     1091    inc(SourceRowAcc,SourceRowAccAdd);
     1092    if SourceRowAcc >= SourceRowMod then
     1093    begin
     1094     dec(SourceRowAcc,SourceRowMod);
     1095     Inc(SourceRow,SourceRowDelta);
     1096    end;
     1097
     1098    prevPercent := percent;
     1099    inc(percent,percentAdd);
     1100    inc(percentAcc,percentAccAdd);
     1101    if percentAcc>=percentMod then inc(percent);
     1102    if (percent<>prevPercent) and Assigned(ProgressProc) then ProgressProc(percent, ShouldContinue);
     1103  end;
     1104end;
    8161105
    8171106initialization
  • GraphicTest/Packages/bgrabitmap/bgrareadico.pas

    r494 r521  
    77
    88uses
    9   Classes, SysUtils, FPimage;
     9  Classes, SysUtils, FPimage{$IFDEF BGRABITMAP_USE_LCL}, Graphics{$ENDIF};
    1010
    1111type
     12  {$IFDEF BGRABITMAP_USE_LCL}TCustomIconClass = class of TCustomIcon;{$ENDIF}
     13  TByteSet = set of byte;
    1214
    13   { TBGRAReaderIco }
     15  { TBGRAReaderIcoOrCur }
    1416
    15   TBGRAReaderIco = class(TFPCustomImageReader)
     17  TBGRAReaderIcoOrCur = class(TFPCustomImageReader)
    1618  protected
    1719    procedure InternalRead({%H-}Str: TStream; {%H-}Img: TFPCustomImage); override;
    1820    function InternalCheck(Str: TStream): boolean; override;
     21    function ExpectedMagic: TByteSet; virtual; abstract;
     22    {$IFDEF BGRABITMAP_USE_LCL}function LazClass: TCustomIconClass; virtual; abstract;{$ENDIF}
    1923  public
    2024    WantedWidth, WantedHeight : integer;
    2125  end;
    2226
     27  TBGRAReaderIco = class(TBGRAReaderIcoOrCur)
     28  protected
     29    function ExpectedMagic: TByteSet; override;
     30    {$IFDEF BGRABITMAP_USE_LCL}function LazClass: TCustomIconClass; override;{$ENDIF}
     31  end;
     32
     33  { TBGRAReaderCur }
     34
     35  TBGRAReaderCur = class(TBGRAReaderIcoOrCur)
     36  protected
     37    function ExpectedMagic: TByteSet; override;
     38    {$IFDEF BGRABITMAP_USE_LCL}function LazClass: TCustomIconClass; override;{$ENDIF}
     39  end;
     40
    2341implementation
    2442
    25 uses BGRABitmapTypes{$IFDEF BGRABITMAP_USE_LCL}, Graphics{$ENDIF};
     43uses BGRABitmapTypes{$IFNDEF BGRABITMAP_USE_LCL}, BGRAIconCursor{$ENDIF};
     44
     45{ TBGRAReaderCur }
     46
     47function TBGRAReaderCur.ExpectedMagic: TByteSet;
     48begin
     49  result := [2];
     50end;
     51
     52{$IFDEF BGRABITMAP_USE_LCL}function TBGRAReaderCur.LazClass: TCustomIconClass;
     53begin
     54  result := TCursorImage;
     55end;{$ENDIF}
    2656
    2757{ TBGRAReaderIco }
    2858
    29 procedure TBGRAReaderIco.InternalRead(Str: TStream; Img: TFPCustomImage);
     59function TBGRAReaderIco.ExpectedMagic: TByteSet;
     60begin
     61  result := [1,2];
     62end;
     63
     64{$IFDEF BGRABITMAP_USE_LCL}function TBGRAReaderIco.LazClass: TCustomIconClass;
     65begin
     66  result := TIcon;
     67end;{$ENDIF}
     68
     69{ TBGRAReaderIcoOrCur }
     70
     71procedure TBGRAReaderIcoOrCur.InternalRead(Str: TStream; Img: TFPCustomImage);
    3072{$IFDEF BGRABITMAP_USE_LCL}
    31 var ico: TIcon; i,bestIdx: integer;
     73var ico: TCustomIcon; i,bestIdx: integer;
    3274    height,width: word; format:TPixelFormat;
    3375    bestHeight,bestWidth: integer; maxFormat: TPixelFormat;
     
    3678  if WantedWidth > 0 then compWidth:= WantedWidth else compWidth:= 65536;
    3779  if WantedHeight > 0 then compHeight:= WantedHeight else compHeight:= 65536;
    38   ico := TIcon.Create;
     80  ico := LazClass.Create;
    3981  try
    4082    ico.LoadFromStream(Str);
     
    4789      ico.GetDescription(i,format,height,width);
    4890      if (bestIdx = -1) or (abs(height-compHeight)+abs(width-compWidth) < abs(bestHeight-compHeight)+abs(bestWidth-compWidth)) or
    49       ((height = bestHeight) or (width = bestWidth) and (format > maxFormat)) then
     91      ((height = bestHeight) and (width = bestWidth) and (format > maxFormat)) then
    5092      begin
    5193        bestIdx := i;
     
    59101    begin
    60102      ico.Current := bestIdx;
    61       (Img as TBGRACustomBitmap).Assign(ico);
     103      Img.Assign(ico);
    62104    end;
    63105  finally
     
    66108end;
    67109{$ELSE}
     110var icoCur: TBGRAIconCursor;
     111    compWidth,compHeight: integer;
     112    bmp: TBGRACustomBitmap;
    68113begin
    69   raise exception.create('Not implemented');
     114  if WantedWidth > 0 then compWidth:= WantedWidth else compWidth:= 65536;
     115  if WantedHeight > 0 then compHeight:= WantedHeight else compHeight:= 65536;
     116  icoCur := TBGRAIconCursor.Create(Str);
     117  try
     118    bmp := icoCur.GetBestFitBitmap(compWidth,compHeight);
     119    try
     120      Img.Assign(bmp);
     121    finally
     122      bmp.Free;
     123    end;
     124  finally
     125    icoCur.Free;
     126  end;
    70127end;
    71128{$ENDIF}
    72129
    73 function TBGRAReaderIco.InternalCheck(Str: TStream): boolean;
     130function TBGRAReaderIcoOrCur.InternalCheck(Str: TStream): boolean;
    74131var {%H-}magic: packed array[0..5] of byte;
    75132    oldPos: int64;
     
    79136  str.Position:= oldPos;
    80137  if result then
    81     result := (magic[0] = $00) and (magic[1] = $00) and (magic[2] in[$01,$02]) and (magic[3] = $00) and
     138    result := (magic[0] = $00) and (magic[1] = $00) and (magic[2] in ExpectedMagic) and (magic[3] = $00) and
    82139             (magic[4] + (magic[5] shl 8) > 0);
    83140end;
     
    86143
    87144  DefaultBGRAImageReader[ifIco] := TBGRAReaderIco;
     145  DefaultBGRAImageReader[ifCur] := TBGRAReaderCur;
    88146
    89147end.
  • GraphicTest/Packages/bgrabitmap/bgrareadlzp.pas

    r494 r521  
    9696    str.Position:= oldPos;
    9797    InternalReadCompressableBitmap(str,Img);
    98     if Str.Position < Str.Size then InternalReadLayers(Str,Img);
     98    if (Str.Position < Str.Size) and (FCaption = 'Preview') then InternalReadLayers(Str,Img);
    9999  end;
    100100end;
     
    169169  nameLen := LEtoN(str.ReadDWord);
    170170  setlength(ACaption, nameLen);
     171  {$PUSH}{$RANGECHECKS OFF}
    171172  str.ReadBuffer(ACaption[1], nameLen);
     173  {$POP}
    172174  channelFlags := str.ReadByte;
    173175  NbPixels := w*h;
  • GraphicTest/Packages/bgrabitmap/bgrareadpng.pas

    r494 r521  
    4040  { TBGRAReaderPNG }
    4141
    42   TBGRAReaderPNG = class (TFPCustomImageReader)
     42  TBGRAReaderPNG = class (TBGRAImageReader)
    4343    private
    4444
     
    133133      property OriginalWidth: integer read GetOriginalWidth;
    134134      property OriginalHeight: integer read GetOriginalHeight;
     135      function GetQuickInfo(AStream: TStream): TQuickImageInfo; override;
     136      function GetBitmapDraft(AStream: TStream; {%H-}AMaxWidth, AMaxHeight: integer; out AOriginalWidth,AOriginalHeight: integer): TBGRACustomBitmap; override;
    135137  end;
    136138
    137139implementation
    138140
    139 
     141uses math;
    140142
    141143const StartPoints : array[0..7, 0..1] of word =
     
    163165end;
    164166
     167function TBGRAReaderPNG.GetQuickInfo(AStream: TStream): TQuickImageInfo;
     168const headerChunkSize = 13;
     169var
     170  {%H-}FileHeader : packed array[0..7] of byte;
     171  {%H-}ChunkHeader : TChunkHeader;
     172  {%H-}HeaderChunk : THeaderChunk;
     173begin
     174  fillchar({%H-}result, sizeof(result), 0);
     175  if AStream.Read({%H-}FileHeader, sizeof(FileHeader))<> sizeof(FileHeader) then exit;
     176  if QWord(FileHeader) <> QWord(PNGComn.Signature) then exit;
     177  if AStream.Read({%H-}ChunkHeader, sizeof(ChunkHeader))<> sizeof(ChunkHeader) then exit;
     178  if ChunkHeader.CType <> ChunkTypes[ctIHDR] then exit;
     179  if BEtoN(ChunkHeader.CLength) < headerChunkSize then exit;
     180  if AStream.Read({%H-}HeaderChunk, headerChunkSize) <> headerChunkSize then exit;
     181  result.width:= BEtoN(HeaderChunk.Width);
     182  result.height:= BEtoN(HeaderChunk.height);
     183  case HeaderChunk.ColorType and 3 of
     184    0,3: {grayscale, palette}
     185      if HeaderChunk.BitDepth > 8 then
     186        result.colorDepth := 8
     187      else
     188        result.colorDepth := HeaderChunk.BitDepth;
     189
     190    2: {color} result.colorDepth := HeaderChunk.BitDepth*3;
     191  end;
     192  if (HeaderChunk.ColorType and 4) = 4 then
     193    result.alphaDepth := HeaderChunk.BitDepth
     194  else
     195    result.alphaDepth := 0;
     196end;
     197
     198function TBGRAReaderPNG.GetBitmapDraft(AStream: TStream; AMaxWidth,
     199  AMaxHeight: integer; out AOriginalWidth, AOriginalHeight: integer): TBGRACustomBitmap;
     200var
     201  png: TBGRAReaderPNG;
     202begin
     203  png:= TBGRAReaderPNG.Create;
     204  result := BGRABitmapFactory.Create;
     205  try
     206    png.MinifyHeight := AMaxHeight;
     207    result.LoadFromStream(AStream, png);
     208    AOriginalWidth:= result.Width;
     209    AOriginalHeight:= png.OriginalHeight;
     210  finally
     211    png.Free;
     212  end;
     213end;
     214
    165215procedure TBGRAReaderPNG.ReadChunk;
    166 
    167216var {%H-}ChunkHeader : TChunkHeader;
    168217    readCRC : longword;
     
    520569  UsingBitGroup := 0;
    521570  DataIndex := 0;
     571  {$PUSH}{$RANGECHECKS OFF} //because PByteArray is limited to 32767
    522572  if (UsingBitGroup = 0) and (Header.BitDepth <> 16) then
    523573    case ByteWidth of
     
    583633         end;
    584634    end;
     635  {$POP}
    585636
    586637  X := StartX;
     
    694745end;
    695746
    696 function TBGRAReaderPNG.ColorGray1 (const CD:TColorDAta) : TFPColor;
     747function TBGRAReaderPNG.ColorGray1(const CD: TColorData): TFPColor;
    697748begin
    698749  if CD = 0 then
     
    702753end;
    703754
    704 function TBGRAReaderPNG.ColorGray2 (const CD:TColorDAta) : TFPColor;
     755function TBGRAReaderPNG.ColorGray2(const CD: TColorData): TFPColor;
    705756var c : NativeUint;
    706757begin
     
    718769end;
    719770
    720 function TBGRAReaderPNG.ColorGray4 (const CD:TColorDAta) : TFPColor;
     771function TBGRAReaderPNG.ColorGray4(const CD: TColorData): TFPColor;
    721772var c : NativeUint;
    722773begin
     
    733784end;
    734785
    735 function TBGRAReaderPNG.ColorGray8 (const CD:TColorDAta) : TFPColor;
     786function TBGRAReaderPNG.ColorGray8(const CD: TColorData): TFPColor;
    736787var c : NativeUint;
    737788begin
     
    747798end;
    748799
    749 function TBGRAReaderPNG.ColorGray16 (const CD:TColorDAta) : TFPColor;
     800function TBGRAReaderPNG.ColorGray16(const CD: TColorData): TFPColor;
    750801var c : NativeUint;
    751802begin
     
    10651116    while Count4 > 0 do
    10661117    begin
    1067       {$push}{$r-}
     1118      {$push}{$r-}{$q-}
    10681119      PDWord(p)^ := (((PDWord(pPrev)^ and $00FF00FF) + (PDWord(p)^ and $00FF00FF)) and $00FF00FF)
    10691120        or (((PDWord(pPrev)^ and $FF00FF00) + (PDWord(p)^ and $FF00FF00)) and $FF00FF00);
     
    13071358    // Check IHDR
    13081359    ReadChunk;
    1309     move (chunk.data^, FHeader, sizeof(Header));
     1360    fillchar(FHeader, sizeof(FHeader), 0);
     1361    move (chunk.data^, FHeader, min(sizeof(Header), chunk.alength));
    13101362    with header do
    13111363      begin
  • GraphicTest/Packages/bgrabitmap/bgraresample.pas

    r494 r521  
    2626  NewWidth, NewHeight: integer): TBGRACustomBitmap;
    2727procedure StretchPutImage(bmp: TBGRACustomBitmap;
    28   NewWidth, NewHeight: integer; dest: TBGRACustomBitmap; OffsetX,OffsetY: Integer; ADrawMode: TDrawMode; AOpacity: byte);
     28  NewWidth, NewHeight: integer; dest: TBGRACustomBitmap; OffsetX,OffsetY: Integer; ADrawMode: TDrawMode; AOpacity: byte; ANoTransition: boolean = false);
    2929procedure DownSamplePutImage(source: TBGRACustomBitmap; factorX,factorY: integer; dest: TBGRACustomBitmap; OffsetX,OffsetY: Integer; ADrawMode: TDrawMode);
    3030function DownSample(source: TBGRACustomBitmap; factorX,factorY: integer): TBGRACustomBitmap;
     
    5353  public
    5454    Coeff: single;
    55     constructor Create;
    56     constructor Create(ACoeff: single);
     55    constructor Create; overload;
     56    constructor Create(ACoeff: single); overload;
    5757    function Interpolation(t: single): single; override;
    5858    function ShouldCheckRange: boolean; override;
     
    112112
    113113procedure StretchPutImage(bmp: TBGRACustomBitmap; NewWidth, NewHeight: integer;
    114   dest: TBGRACustomBitmap; OffsetX, OffsetY: Integer; ADrawMode: TDrawMode; AOpacity: byte);
     114  dest: TBGRACustomBitmap; OffsetX, OffsetY: Integer; ADrawMode: TDrawMode; AOpacity: byte; ANoTransition: boolean);
    115115type
    116116  TTransitionState = (tsNone, tsPlain, tsLeft, tsMiddle, tsRight);
     
    136136    newTransition: TTransitionState;
    137137  begin
    138     if DeltaSrc=0 then
     138    if (DeltaSrc=0) or ANoTransition then
    139139    begin
    140140      PDest^ := PSrc^;
     
    154154      begin
    155155        transition:= tsMiddle;
    156         asum := psrc^.alpha + (psrc+DeltaSrc)^.alpha;
    157         if asum = 0 then
    158           pdest^ := BGRAPixelTransparent
    159         else if asum = 510 then
    160         begin
    161           pdest^.alpha := 255;
     156        if ADrawMode = dmXor then
     157        begin
     158          pdest^.alpha := (psrc^.alpha + (psrc+DeltaSrc)^.alpha + 1) shr 1;
    162159          pdest^.red := (psrc^.red + (psrc+DeltaSrc)^.red + 1) shr 1;
    163160          pdest^.green := (psrc^.green + (psrc+DeltaSrc)^.green + 1) shr 1;
     
    165162        end else
    166163        begin
    167           pdest^.alpha := asum shr 1;
    168           a1 := psrc^.alpha;
    169           a2 := (psrc+DeltaSrc)^.alpha;
    170           pdest^.red := (psrc^.red*a1 + (psrc+DeltaSrc)^.red*a2 + (asum shr 1)) div asum;
    171           pdest^.green := (psrc^.green*a1 + (psrc+DeltaSrc)^.green*a2 + (asum shr 1)) div asum;
    172           pdest^.blue := (psrc^.blue*a1 + (psrc+DeltaSrc)^.blue*a2 + (asum shr 1)) div asum;
     164          asum := psrc^.alpha + (psrc+DeltaSrc)^.alpha;
     165          if asum = 0 then
     166            pdest^ := BGRAPixelTransparent
     167          else if asum = 510 then
     168          begin
     169            pdest^.alpha := 255;
     170            pdest^.red := (psrc^.red + (psrc+DeltaSrc)^.red + 1) shr 1;
     171            pdest^.green := (psrc^.green + (psrc+DeltaSrc)^.green + 1) shr 1;
     172            pdest^.blue := (psrc^.blue + (psrc+DeltaSrc)^.blue + 1) shr 1;
     173          end else
     174          begin
     175            pdest^.alpha := asum shr 1;
     176            a1 := psrc^.alpha;
     177            a2 := (psrc+DeltaSrc)^.alpha;
     178            pdest^.red := (psrc^.red*a1 + (psrc+DeltaSrc)^.red*a2 + (asum shr 1)) div asum;
     179            pdest^.green := (psrc^.green*a1 + (psrc+DeltaSrc)^.green*a2 + (asum shr 1)) div asum;
     180            pdest^.blue := (psrc^.blue*a1 + (psrc+DeltaSrc)^.blue*a2 + (asum shr 1)) div asum;
     181          end;
    173182        end;
    174183      end else
     
    176185      begin
    177186        transition := tsRight;
    178         asum := psrc^.alpha + (psrc+DeltaSrc)^.alpha*3;
    179         if asum = 0 then
    180           pdest^ := BGRAPixelTransparent
    181         else if asum = 1020 then
    182         begin
    183           pdest^.alpha := 255;
     187        if ADrawMode = dmXor then
     188        begin
     189          pdest^.alpha := (psrc^.alpha + (psrc+DeltaSrc)^.alpha*3 + 2) shr 2;
    184190          pdest^.red := (psrc^.red + (psrc+DeltaSrc)^.red*3 + 2) shr 2;
    185191          pdest^.green := (psrc^.green + (psrc+DeltaSrc)^.green*3 + 2) shr 2;
     
    187193        end else
    188194        begin
    189           pdest^.alpha := asum shr 2;
    190           a1 := psrc^.alpha;
    191           a2 := (psrc+DeltaSrc)^.alpha;
    192           pdest^.red := (psrc^.red*a1 + (psrc+DeltaSrc)^.red*a2*3 + (asum shr 1)) div asum;
    193           pdest^.green := (psrc^.green*a1 + (psrc+DeltaSrc)^.green*a2*3 + (asum shr 1)) div asum;
    194           pdest^.blue := (psrc^.blue*a1 + (psrc+DeltaSrc)^.blue*a2*3 + (asum shr 1)) div asum;
     195          asum := psrc^.alpha + (psrc+DeltaSrc)^.alpha*3;
     196          if asum = 0 then
     197            pdest^ := BGRAPixelTransparent
     198          else if asum = 1020 then
     199          begin
     200            pdest^.alpha := 255;
     201            pdest^.red := (psrc^.red + (psrc+DeltaSrc)^.red*3 + 2) shr 2;
     202            pdest^.green := (psrc^.green + (psrc+DeltaSrc)^.green*3 + 2) shr 2;
     203            pdest^.blue := (psrc^.blue + (psrc+DeltaSrc)^.blue*3 + 2) shr 2;
     204          end else
     205          begin
     206            pdest^.alpha := asum shr 2;
     207            a1 := psrc^.alpha;
     208            a2 := (psrc+DeltaSrc)^.alpha;
     209            pdest^.red := (psrc^.red*a1 + (psrc+DeltaSrc)^.red*a2*3 + (asum shr 1)) div asum;
     210            pdest^.green := (psrc^.green*a1 + (psrc+DeltaSrc)^.green*a2*3 + (asum shr 1)) div asum;
     211            pdest^.blue := (psrc^.blue*a1 + (psrc+DeltaSrc)^.blue*a2*3 + (asum shr 1)) div asum;
     212          end;
    195213        end;
    196214      end else
    197215      begin
    198216        transition:= tsLeft;
    199         asum := psrc^.alpha*3 + (psrc+DeltaSrc)^.alpha;
    200         if asum = 0 then
    201           pdest^ := BGRAPixelTransparent
    202         else if asum = 1020 then
    203         begin
    204           pdest^.alpha := 255;
     217        if ADrawMode = dmXor then
     218        begin
     219          pdest^.alpha := (psrc^.alpha*3 + (psrc+DeltaSrc)^.alpha + 2) shr 2;
    205220          pdest^.red := (psrc^.red*3 + (psrc+DeltaSrc)^.red + 2) shr 2;
    206221          pdest^.green := (psrc^.green*3 + (psrc+DeltaSrc)^.green + 2) shr 2;
     
    208223        end else
    209224        begin
    210           pdest^.alpha := asum shr 2;
    211           a1 := psrc^.alpha;
    212           a2 := (psrc+DeltaSrc)^.alpha;
    213           pdest^.red := (psrc^.red*a1*3 + (psrc+DeltaSrc)^.red*a2 + (asum shr 1)) div asum;
    214           pdest^.green := (psrc^.green*a1*3 + (psrc+DeltaSrc)^.green*a2 + (asum shr 1)) div asum;
    215           pdest^.blue := (psrc^.blue*a1*3 + (psrc+DeltaSrc)^.blue*a2 + (asum shr 1)) div asum;
     225          asum := psrc^.alpha*3 + (psrc+DeltaSrc)^.alpha;
     226          if asum = 0 then
     227            pdest^ := BGRAPixelTransparent
     228          else if asum = 1020 then
     229          begin
     230            pdest^.alpha := 255;
     231            pdest^.red := (psrc^.red*3 + (psrc+DeltaSrc)^.red + 2) shr 2;
     232            pdest^.green := (psrc^.green*3 + (psrc+DeltaSrc)^.green + 2) shr 2;
     233            pdest^.blue := (psrc^.blue*3 + (psrc+DeltaSrc)^.blue + 2) shr 2;
     234          end else
     235          begin
     236            pdest^.alpha := asum shr 2;
     237            a1 := psrc^.alpha;
     238            a2 := (psrc+DeltaSrc)^.alpha;
     239            pdest^.red := (psrc^.red*a1*3 + (psrc+DeltaSrc)^.red*a2 + (asum shr 1)) div asum;
     240            pdest^.green := (psrc^.green*a1*3 + (psrc+DeltaSrc)^.green*a2 + (asum shr 1)) div asum;
     241            pdest^.blue := (psrc^.blue*a1*3 + (psrc+DeltaSrc)^.blue*a2 + (asum shr 1)) div asum;
     242          end;
    216243        end;
    217244      end;
     
    11761203    ssRoundOutside: result := TSplineKernel.Create(0.75);
    11771204    ssVertexToSide: result := TSplineKernel.Create(1);
     1205    ssEasyBezier: raise Exception.Create('EasyBezier does not have an interpolator');
    11781206  else
    11791207    raise Exception.Create('Unknown spline style');
  • GraphicTest/Packages/bgrabitmap/bgrascene3d.pas

    r494 r521  
    152152    FetchThrowsException: boolean;
    153153
    154     constructor Create;
    155     constructor Create(ASurface: TBGRACustomBitmap);
     154    constructor Create; overload;
     155    constructor Create(ASurface: TBGRACustomBitmap); overload;
    156156    destructor Destroy; override;
    157157    procedure Clear; virtual;
     
    169169    procedure LookUp(angleDeg: single);
    170170    procedure LookDown(angleDeg: single);
    171     procedure Render; virtual;
    172     procedure Render(ARenderer: TCustomRenderer3D);
     171    procedure Render;  overload; virtual;
     172    procedure Render(ARenderer: TCustomRenderer3D); overload;
    173173    function CreateObject: IBGRAObject3D; overload;
    174174    function CreateObject(ATexture: IBGRAScanner): IBGRAObject3D; overload;
     
    179179    function CreateHalfSphere(ARadius: Single; AColor: TBGRAPixel; AHorizPrecision: integer = 6; AVerticalPrecision : integer = 6): IBGRAObject3D; overload;
    180180    procedure RemoveObject(AObject: IBGRAObject3D);
    181     function AddDirectionalLight(ADirection: TPoint3D; ALightness: single = 1; AMinIntensity : single = 0): IBGRADirectionalLight3D;
    182     function AddDirectionalLight(ADirection: TPoint3D; AColor: TBGRAPixel; AMinIntensity: single = 0): IBGRADirectionalLight3D;
    183     function AddPointLight(AVertex: IBGRAVertex3D; AOptimalDistance: single; ALightness: single = 1; AMinIntensity : single = 0): IBGRAPointLight3D;
    184     function AddPointLight(AVertex: IBGRAVertex3D; AOptimalDistance: single; AColor: TBGRAPixel; AMinIntensity: single = 0): IBGRAPointLight3D;
     181    function AddDirectionalLight(ADirection: TPoint3D; ALightness: single = 1; AMinIntensity : single = 0): IBGRADirectionalLight3D; overload;
     182    function AddDirectionalLight(ADirection: TPoint3D; AColor: TBGRAPixel; AMinIntensity: single = 0): IBGRADirectionalLight3D; overload;
     183    function AddPointLight(AVertex: IBGRAVertex3D; AOptimalDistance: single; ALightness: single = 1; AMinIntensity : single = 0): IBGRAPointLight3D; overload;
     184    function AddPointLight(AVertex: IBGRAVertex3D; AOptimalDistance: single; AColor: TBGRAPixel; AMinIntensity: single = 0): IBGRAPointLight3D; overload;
    185185    procedure RemoveLight(ALight: IBGRALight3D);
    186186    procedure SetZoom(value: Single); overload;
    187187    procedure SetZoom(value: TPointF); overload;
    188     function CreateMaterial: IBGRAMaterial3D;
    189     function CreateMaterial(ASpecularIndex: integer): IBGRAMaterial3D;
     188    function CreateMaterial: IBGRAMaterial3D; overload;
     189    function CreateMaterial(ASpecularIndex: integer): IBGRAMaterial3D; overload;
    190190    function GetMaterialByName(AName: string): IBGRAMaterial3D;
    191191    procedure UpdateMaterials; virtual;
     
    949949
    950950  function GetSingle: single;
    951   var code: integer;
    952   begin
    953     val(GetNextToken,result,code);
     951  var {%H-}code: integer;
     952  begin
     953    val(GetNextToken,result,{%H-}code);
    954954  end;
    955955
    956956  function GetColorF: TColorF;
    957957  var r,g,b: single;
    958     code: integer;
    959   begin
    960     val(GetNextToken,r,code);
    961     val(GetNextToken,g,code);
    962     val(GetNextToken,b,code);
     958    {%H-}code: integer;
     959  begin
     960    val(GetNextToken,r,{%H-}code);
     961    val(GetNextToken,g,{%H-}code);
     962    val(GetNextToken,b,{%H-}code);
    963963    result := ColorF(r,g,b,1);
    964964  end;
  • GraphicTest/Packages/bgrabitmap/bgrascenetypes.pas

    r494 r521  
    253253  IBGRAPart3D = interface
    254254    procedure Clear(ARecursive: boolean);
    255     function Add(x,y,z: single): IBGRAVertex3D;
    256     function Add(pt: TPoint3D): IBGRAVertex3D;
    257     function Add(pt: TPoint3D; normal: TPoint3D): IBGRAVertex3D;
    258     function Add(pt: TPoint3D_128): IBGRAVertex3D;
    259     function Add(pt: TPoint3D_128; normal: TPoint3D_128): IBGRAVertex3D;
    260     function AddNormal(x,y,z: single): IBGRANormal3D;
    261     function AddNormal(pt: TPoint3D): IBGRANormal3D;
    262     function AddNormal(pt: TPoint3D_128): IBGRANormal3D;
    263     function Add(const coords: array of single): arrayOfIBGRAVertex3D;
    264     function Add(const pts: array of TPoint3D): arrayOfIBGRAVertex3D;
    265     function Add(const pts_128: array of TPoint3D_128): arrayOfIBGRAVertex3D;
    266     procedure Add(const pts: array of IBGRAVertex3D);
    267     procedure Add(AVertex: IBGRAVertex3D);
     255    function Add(x,y,z: single): IBGRAVertex3D; overload;
     256    function Add(pt: TPoint3D): IBGRAVertex3D; overload;
     257    function Add(pt: TPoint3D; normal: TPoint3D): IBGRAVertex3D; overload;
     258    function Add(pt: TPoint3D_128): IBGRAVertex3D; overload;
     259    function Add(pt: TPoint3D_128; normal: TPoint3D_128): IBGRAVertex3D; overload;
     260    function AddNormal(x,y,z: single): IBGRANormal3D; overload;
     261    function AddNormal(pt: TPoint3D): IBGRANormal3D; overload;
     262    function AddNormal(pt: TPoint3D_128): IBGRANormal3D; overload;
     263    function Add(const coords: array of single): arrayOfIBGRAVertex3D; overload;
     264    function Add(const pts: array of TPoint3D): arrayOfIBGRAVertex3D; overload;
     265    function Add(const pts_128: array of TPoint3D_128): arrayOfIBGRAVertex3D; overload;
     266    procedure Add(const pts: array of IBGRAVertex3D); overload;
     267    procedure Add(AVertex: IBGRAVertex3D); overload;
    268268    function GetTotalNormalCount: integer;
    269269    function IndexOf(AVertex: IBGRAVertex3D): integer;
     
    282282    function GetContainer: IBGRAPart3D;
    283283    procedure ResetTransform;
    284     procedure Scale(size: single; Before: boolean = true);
    285     procedure Scale(x,y,z: single; Before: boolean = true);
    286     procedure Scale(size: TPoint3D; Before: boolean = true);
     284    procedure Scale(size: single; Before: boolean = true); overload;
     285    procedure Scale(x,y,z: single; Before: boolean = true); overload;
     286    procedure Scale(size: TPoint3D; Before: boolean = true); overload;
    287287    procedure SetMatrix(const AValue: TMatrix3D);
    288288    procedure SetNormal(AIndex: Integer; AValue: IBGRANormal3D);
    289289    procedure SetVertex(AIndex: Integer; AValue: IBGRAVertex3D);
    290     procedure Translate(x,y,z: single; Before: boolean = true);
    291     procedure Translate(ofs: TPoint3D; Before: boolean = true);
     290    procedure Translate(x,y,z: single; Before: boolean = true); overload;
     291    procedure Translate(ofs: TPoint3D; Before: boolean = true); overload;
    292292    procedure RotateXDeg(angle: single; Before: boolean = true);
    293293    procedure RotateYDeg(angle: single; Before: boolean = true);
     
    418418    procedure ForEachFace(ACallback: TFace3DCallback);
    419419    function AddFaceReversed(const AVertices: array of IBGRAVertex3D): IBGRAFace3D;
    420     function AddFace(const AVertices: array of IBGRAVertex3D): IBGRAFace3D;
    421     function AddFace(const AVertices: array of IBGRAVertex3D; ABiface: boolean): IBGRAFace3D;
    422     function AddFace(const AVertices: array of IBGRAVertex3D; ATexture: IBGRAScanner): IBGRAFace3D;
    423     function AddFace(const AVertices: array of IBGRAVertex3D; AColor: TBGRAPixel): IBGRAFace3D;
    424     function AddFace(const AVertices: array of IBGRAVertex3D; AColors: array of TBGRAPixel): IBGRAFace3D;
     420    function AddFace(const AVertices: array of IBGRAVertex3D): IBGRAFace3D; overload;
     421    function AddFace(const AVertices: array of IBGRAVertex3D; ABiface: boolean): IBGRAFace3D; overload;
     422    function AddFace(const AVertices: array of IBGRAVertex3D; ATexture: IBGRAScanner): IBGRAFace3D; overload;
     423    function AddFace(const AVertices: array of IBGRAVertex3D; AColor: TBGRAPixel): IBGRAFace3D; overload;
     424    function AddFace(const AVertices: array of IBGRAVertex3D; AColors: array of TBGRAPixel): IBGRAFace3D; overload;
    425425    procedure Update;
    426426    procedure SetBiface(AValue : boolean);
  • GraphicTest/Packages/bgrabitmap/bgraslicescaling.pas

    r494 r521  
    6666    // or as a local owned copy in other cases
    6767    constructor Create(ABitmap: TBGRABitmap;
    68       AMarginTop, AMarginRight, AMarginBottom, AMarginLeft: integer; ABitmapOwner: boolean = false);
     68      AMarginTop, AMarginRight, AMarginBottom, AMarginLeft: integer; ABitmapOwner: boolean = false); overload;
    6969    constructor Create(ABitmap: TBitmap;
    70       AMarginTop, AMarginRight, AMarginBottom, AMarginLeft: integer);
     70      AMarginTop, AMarginRight, AMarginBottom, AMarginLeft: integer); overload;
    7171    constructor Create(AFilename: string;
    72       AMarginTop, AMarginRight, AMarginBottom, AMarginLeft: integer);
     72      AMarginTop, AMarginRight, AMarginBottom, AMarginLeft: integer); overload;
    7373    constructor Create(AFilename: string; AIsUtf8: boolean;
    74       AMarginTop, AMarginRight, AMarginBottom, AMarginLeft: integer);
     74      AMarginTop, AMarginRight, AMarginBottom, AMarginLeft: integer); overload;
    7575    constructor Create(AStream: TStream;
    76       AMarginTop, AMarginRight, AMarginBottom, AMarginLeft: integer);
    77     constructor Create(ABitmap: TBGRABitmap; ABitmapOwner: boolean = false);
    78     constructor Create(ABitmap: TBitmap);
    79     constructor Create(AFilename: string);
    80     constructor Create(AFilename: string; AIsUtf8: boolean);
    81     constructor Create(AStream: TStream);
    82     constructor Create;
    83     procedure SetMargins(AMarginTop, AMarginRight, AMarginBottom, AMarginLeft: integer);
    84     procedure SetMargins(AMargins: TMargins);
     76      AMarginTop, AMarginRight, AMarginBottom, AMarginLeft: integer); overload;
     77    constructor Create(ABitmap: TBGRABitmap; ABitmapOwner: boolean = false); overload;
     78    constructor Create(ABitmap: TBitmap); overload;
     79    constructor Create(AFilename: string); overload;
     80    constructor Create(AFilename: string; AIsUtf8: boolean); overload;
     81    constructor Create(AStream: TStream); overload;
     82    constructor Create; overload;
     83    procedure SetMargins(AMarginTop, AMarginRight, AMarginBottom, AMarginLeft: integer); overload;
     84    procedure SetMargins(AMargins: TMargins); overload;
    8585    destructor Destroy; override;
    8686  public
     
    8888    //so new bitmaps should be used
    8989    // Draw
    90     procedure Draw(ABitmap: TBGRABitmap; ARect: TRect; DrawGrid: boolean = False);
     90    procedure Draw(ABitmap: TBGRABitmap; ARect: TRect; DrawGrid: boolean = False); overload;
    9191    procedure Draw(ABitmap: TBGRABitmap; ALeft, ATop, AWidth, AHeight: integer;
    92       DrawGrid: boolean = False);
     92      DrawGrid: boolean = False); overload;
    9393    procedure AutodetectRepeat;
    9494  public
     
    124124    constructor Create(ABitmap: TBGRABitmap;
    125125      AMarginTop, AMarginRight, AMarginBottom, AMarginLeft, NumberOfItems: integer;
    126       Direction: TSliceScalingDirection; ABitmapOwner: boolean = false);
     126      Direction: TSliceScalingDirection; ABitmapOwner: boolean = false); overload;
    127127    constructor Create(ABitmap: TBitmap;
    128128      AMarginTop, AMarginRight, AMarginBottom, AMarginLeft, NumberOfItems: integer;
    129       Direction: TSliceScalingDirection);
     129      Direction: TSliceScalingDirection); overload;
    130130    constructor Create(ABitmapFilename: string;
    131131      AMarginTop, AMarginRight, AMarginBottom, AMarginLeft, NumberOfItems: integer;
    132       Direction: TSliceScalingDirection);
     132      Direction: TSliceScalingDirection); overload;
    133133    constructor Create(ABitmapFilename: string; AIsUtf8: boolean;
    134134      AMarginTop, AMarginRight, AMarginBottom, AMarginLeft, NumberOfItems: integer;
    135       Direction: TSliceScalingDirection);
     135      Direction: TSliceScalingDirection); overload;
    136136    constructor Create(AStream: TStream;
    137137      AMarginTop, AMarginRight, AMarginBottom, AMarginLeft, NumberOfItems: integer;
    138       Direction: TSliceScalingDirection);
     138      Direction: TSliceScalingDirection); overload;
    139139    destructor Destroy; override;
    140     constructor Create(AIniFilename, ASection: string; AIsUtf8Filename: boolean= false);
     140    constructor Create(AIniFilename, ASection: string; AIsUtf8Filename: boolean= false); overload;
    141141  public
    142142    procedure Draw(ItemNumber: integer; ABitmap: TBGRABitmap;
    143       ARect: TRect; DrawGrid: boolean = False);
     143      ARect: TRect; DrawGrid: boolean = False); overload;
    144144    procedure Draw(ItemNumber: integer; ABitmap: TBGRABitmap;
    145       ALeft, ATop, AWidth, AHeight: integer; DrawGrid: boolean = False);
     145      ALeft, ATop, AWidth, AHeight: integer; DrawGrid: boolean = False); overload;
    146146  public
    147147    property SliceScalingArray: TSliceScalingArray
  • GraphicTest/Packages/bgrabitmap/bgraspritegl.pas

    r494 r521  
    3232    function GetLayer: Integer; virtual; abstract;
    3333    function GetLocation: TPointF; virtual;
     34    function GetVisible: Boolean; virtual;
    3435    function GetW: Single; virtual; abstract;
    3536    function GetX: Single; virtual; abstract;
     
    4647    procedure SetLocation(AValue: TPointF); virtual;
    4748    procedure SetW(AValue: Single); virtual; abstract;
     49    procedure SetVisible({%H-}AValue: boolean); virtual;
    4850    procedure SetX(AValue: Single); virtual; abstract;
    4951    procedure SetY(AValue: Single); virtual; abstract;
     
    5456    destructor Destroy; override;
    5557    procedure OnDraw; virtual;
    56     procedure OnElapse(AElapsedMs: integer); virtual;
     58    procedure OnElapse({%H-}AElapsedMs: integer); virtual;
    5759    procedure OnTimer; virtual;
    5860    procedure QueryDestroy; virtual; abstract;
     
    7173    property HorizontalAlign: TAlignment read GetHorizontalAlign write SetHorizontalAlign;
    7274    property VerticalAlign: TTextLayout read GetVerticalAlign write SetVerticalAlign;
     75    property Visible : Boolean read GetVisible write SetVisible;
    7376    property Texture : IBGLTexture read GetTexture;
    7477    property Handle  : Pointer read GetHandle;
     
    8689    FQueryDestroy: boolean;
    8790    FLayer: integer;
     91    FHidden: boolean;
    8892    function GetHorizontalAlign: TAlignment; override;
    8993    function GetVerticalAlign: TTextLayout; override;
     
    97101    function GetH: Single; override;
    98102    function GetLayer: Integer; override;
     103    function GetVisible: Boolean; override;
    99104    function GetW: Single; override;
    100105    function GetX: Single; override;
     
    107112    procedure SetH(AValue: Single); override;
    108113    procedure SetLayer(AValue: Integer); override;
     114    procedure SetVisible(AValue: boolean); override;
    109115    procedure SetW(AValue: Single); override;
    110116    procedure SetX(AValue: Single); override;
     
    342348end;
    343349
     350function TBGLDefaultSprite.GetVisible: Boolean;
     351begin
     352  Result:= not FHidden;
     353end;
     354
    344355function TBGLDefaultSprite.GetW: Single;
    345356begin
     
    390401begin
    391402  FLayer:= AValue;
     403end;
     404
     405procedure TBGLDefaultSprite.SetVisible(AValue: boolean);
     406begin
     407  FHidden := not AValue;
    392408end;
    393409
     
    487503end;
    488504
     505function TBGLCustomSprite.GetVisible: Boolean;
     506begin
     507  result := true;
     508end;
     509
    489510procedure TBGLCustomSprite.SetLocation(AValue: TPointF);
    490511begin
    491512  X := AValue.X;
    492513  Y := AValue.Y;
     514end;
     515
     516procedure TBGLCustomSprite.SetVisible(AValue: boolean);
     517begin
     518  raise ENotImplemented.Create('Not implemented in base class');
    493519end;
    494520
     
    536562var NumFrame: integer;
    537563begin
    538   if Texture <> nil then
     564  if Visible and (Texture <> nil) then
    539565    begin
    540566      NumFrame := Trunc(Frame+0.5);
  • GraphicTest/Packages/bgrabitmap/bgrastreamlayers.pas

    r494 r521  
    22
    33{$mode objfpc}{$H+}
     4{$MODESWITCH ADVANCEDRECORDS}
    45
    56interface
     
    910
    1011function CheckStreamForLayers(AStream: TStream): boolean;
    11 function LoadLayersFromStream(AStream: TStream; out ASelectedLayerIndex: integer; ALoadLayerUniqueIds: boolean = false) : TBGRALayeredBitmap;
     12function LoadLayersFromStream(AStream: TStream; out ASelectedLayerIndex: integer; ALoadLayerUniqueIds: boolean = false;
     13         ADestination: TBGRALayeredBitmap = nil): TBGRALayeredBitmap;
    1214procedure SaveLayersToStream(AStream: TStream; ALayers: TBGRACustomLayeredBitmap; ASelectedLayerIndex: integer; ACompression: TLzpCompression = lzpZStream);
    1315procedure SaveLayerBitmapToStream(AStream: TStream; ABitmap: TBGRABitmap; ACaption: string; ACompression: TLzpCompression = lzpZStream);
     
    1820
    1921uses BGRABitmapTypes, BGRACompressableBitmap, zstream, BGRAReadLzp, BGRAWriteLzp,
    20      BGRAUTF8;
     22     BGRAUTF8, Math;
     23
     24type
     25  PLayerHeader = ^TLayerHeader;
     26
     27  { TLayerHeader }
     28
     29  TLayerHeader = packed record
     30    LayerOption, BlendOp,
     31    LayerOfsX, LayerOfsY,
     32    LayerUniqueId, LayerOpacity: Longint;
     33    LayerBitmapSize: int64;
     34    OriginalGuid: TGuid;
     35    OriginalMatrix: TAffineMatrix;
     36    procedure FixEndian;
     37  end;
     38
     39{ TLayerHeader }
     40
     41procedure TLayerHeader.FixEndian;
     42begin
     43  LayerOption := NtoLE(LayerOption);
     44  BlendOp := NtoLE(BlendOp);
     45  LayerOfsX := NtoLE(LayerOfsX);
     46  LayerOfsY := NtoLE(LayerOfsY);
     47  LayerUniqueId := NtoLE(LayerUniqueId);
     48  LayerOpacity := NtoLE(LayerOpacity);
     49  LayerBitmapSize := NtoLE(LayerBitmapSize);
     50  OriginalGuid.D1 := NtoBE(OriginalGuid.D1);
     51  OriginalGuid.D2 := NtoBE(OriginalGuid.D2);
     52  OriginalGuid.D3 := NtoBE(OriginalGuid.D3);
     53  DWord(OriginalMatrix[1,1]) := NtoLE(DWord(OriginalMatrix[1,1]));
     54  DWord(OriginalMatrix[2,1]) := NtoLE(DWord(OriginalMatrix[2,1]));
     55  DWord(OriginalMatrix[1,2]) := NtoLE(DWord(OriginalMatrix[1,2]));
     56  DWord(OriginalMatrix[2,2]) := NtoLE(DWord(OriginalMatrix[2,2]));
     57  DWord(OriginalMatrix[1,3]) := NtoLE(DWord(OriginalMatrix[1,3]));
     58  DWord(OriginalMatrix[2,3]) := NtoLE(DWord(OriginalMatrix[2,3]));
     59end;
    2160
    2261procedure SaveLayeredBitmapToStream(AStream: TStream; ALayers: TBGRACustomLayeredBitmap);
     
    2564end;
    2665
    27 function LoadLayeredBitmapFromStream(AStream: TStream) : TBGRALayeredBitmap;
     66procedure LoadLayeredBitmapFromStream(AStream: TStream; ALayers: TBGRACustomLayeredBitmap);
    2867var selectedIndex: integer;
    2968begin
    3069  if not CheckStreamForLayers(AStream) then
    31     result := nil
     70  begin
     71    if Assigned(ALayers) then ALayers.Clear;
     72  end
    3273  else
    33     result := LoadLayersFromStream(AStream,selectedIndex);
     74    LoadLayersFromStream(AStream,selectedIndex,false,ALayers as TBGRALayeredBitmap);
    3475end;
    3576
     
    60101end;
    61102
    62 function LoadLayersFromStream(AStream: TStream; out ASelectedLayerIndex: integer; ALoadLayerUniqueIds: boolean = false): TBGRALayeredBitmap;
     103function LoadLayersFromStream(AStream: TStream; out ASelectedLayerIndex: integer; ALoadLayerUniqueIds: boolean = false;
     104         ADestination: TBGRALayeredBitmap = nil): TBGRALayeredBitmap;
    63105var
    64106  OldPosition: Int64;
    65107  HeaderFound: string;
    66   NbLayers: LongInt;
     108  NbLayers, canvasWidth, canvasHeight: LongInt;
    67109  HeaderSize, LayerHeaderSize: LongInt;
    68   LayerStackStartPosition, LayerHeaderPosition, LayerBitmapPosition, LayerEndPosition: Int64;
    69   LayerOption,StackOption: LongInt;
     110  LayerStackStartPosition, LayerHeaderPosition,
     111  LayerBitmapPosition, LayerEndPosition, MemDirPos: Int64;
     112  StackOption: LongInt;
    70113  Layer: TBGRABitmap;
    71114  i,LayerIndex: integer;
    72115  LayerName: string;
    73   LayerId: LongInt;
    74116  Compression: TLzpCompression;
    75   LayerVisible: boolean;
    76117  LayerBlendOp: TBlendOperation;
    77   LayerOffset: TPoint;
    78   LayerOpacity: integer;
    79118  LayerIdFound: boolean;
    80   LayerBitmapSize: integer;
    81 begin
    82   result := TBGRALayeredBitmap.Create;
     119  h: TLayerHeader;
     120begin
     121  if Assigned(ADestination) then
     122  begin
     123    result := ADestination;
     124    result.Clear;
     125  end else
     126    result := TBGRALayeredBitmap.Create;
    83127  OldPosition:= AStream.Position;
    84128  SetLength(HeaderFound, length(StreamHeader));
     
    106150    result.LinearBlend := (StackOption and 1) = 1;
    107151    if (StackOption and 2) = 2 then Compression := lzpRLE else Compression:= lzpZStream;
     152
     153    if headerSize >= 20 then
     154    begin
     155      canvasWidth := LEReadLongint(AStream);
     156      canvasHeight := LEReadLongint(AStream);
     157      result.SetSize(canvasWidth,canvasHeight);
     158    end;
     159
     160    if headerSize >= 28 then
     161    begin
     162      MemDirPos := LEReadInt64(AStream);
     163    end else MemDirPos := 0;
    108164    //end of header
     165
     166    if MemDirPos <> 0 then
     167    begin
     168      AStream.Position:= MemDirPos+OldPosition;
     169      result.MemDirectory.LoadFromStream(AStream);
     170    end else
     171      result.MemDirectory.Clear;
    109172
    110173    AStream.Position:= LayerStackStartPosition;
     
    112175    begin
    113176      LayerHeaderSize:= LEReadLongint(AStream);
     177
    114178      LayerHeaderPosition := AStream.Position;
    115179      LayerBitmapPosition := LayerHeaderPosition + LayerHeaderSize;
    116180      LayerEndPosition := -1;
    117181
    118       LayerVisible := true;
    119       LayerBlendOp := result.DefaultBlendingOperation;
    120       LayerOffset := Point(0,0);
    121       LayerId := 0;
    122       LayerIdFound := false;
    123       LayerOpacity := 255;
    124 
    125       if AStream.Position <= LayerBitmapPosition-4 then
    126       begin
    127         LayerOption := LEReadLongint(AStream);
    128         LayerVisible := (LayerOption and 1) = 1;
    129       end;
    130       if AStream.Position <= LayerBitmapPosition-4 then
    131         LayerBlendOp := TBlendOperation(LEReadLongint(AStream));
    132 
    133       if AStream.Position <= LayerBitmapPosition-8 then
    134       begin
    135         LayerOffset := Point(LEReadLongint(AStream),LEReadLongint(AStream));
    136         if AStream.Position <= LayerBitmapPosition-4 then
    137         begin
    138           LayerId := LEReadLongint(AStream);
    139           LayerIdFound := true;
    140         end;
    141         if AStream.Position <= LayerBitmapPosition-4 then
    142           LayerOpacity := LEReadLongint(AStream) shr 8;
    143       end;
    144       if AStream.Position <= LayerBitmapPosition-4 then
    145       begin
    146         LayerBitmapSize := LEReadLongint(AStream);
    147         LayerEndPosition:= LayerBitmapPosition+LayerBitmapSize;
    148       end;
     182      fillchar({%H-}h, sizeof(h), 0);
     183      h.LayerOption := 1; //visible
     184      h.BlendOp:= integer(result.DefaultBlendingOperation);
     185      h.LayerOpacity := 65535; //opaque
     186      h.LayerUniqueId:= maxLongint;
     187      h.FixEndian;
     188
     189      AStream.ReadBuffer(h, min(LayerHeaderSize, sizeof(h)));
     190      h.FixEndian;
     191
     192      if h.BlendOp > ord(high(TBlendOperation)) then
     193        LayerBlendOp := result.DefaultBlendingOperation
     194      else
     195        LayerBlendOp:= TBlendOperation(h.BlendOp);
     196
     197      LayerIdFound := h.LayerUniqueId <> maxLongint;
     198
     199      if h.LayerBitmapSize > 0 then
     200        LayerEndPosition:= LayerBitmapPosition+h.LayerBitmapSize;
    149201
    150202      AStream.Position:= LayerBitmapPosition;
     
    155207
    156208      result.LayerName[LayerIndex] := LayerName;
    157       result.LayerVisible[LayerIndex] := LayerVisible;
     209      result.LayerVisible[LayerIndex] := (h.LayerOption and 1) = 1;
    158210      result.BlendOperation[LayerIndex]:= LayerBlendOp;
    159       result.LayerOffset[LayerIndex] := LayerOffset;
     211      result.LayerOffset[LayerIndex] := Point(h.LayerOfsX,h.LayerOfsY);
    160212      if ALoadLayerUniqueIds and LayerIdFound then
    161         result.LayerUniqueId[LayerIndex] := LayerId;
    162       result.LayerOpacity[LayerIndex] := LayerOpacity;
     213        result.LayerUniqueId[LayerIndex] := h.LayerUniqueId;
     214      result.LayerOpacity[LayerIndex] := h.LayerOpacity shr 8;
     215      result.LayerOriginalGuid[LayerIndex] := h.OriginalGuid;
     216      result.LayerOriginalMatrix[LayerIndex] := h.OriginalMatrix;
     217      result.LayerOriginalRenderStatus[layerIndex] := orsProof;
    163218
    164219      if LayerEndPosition <> -1 then AStream.Position := LayerEndPosition;
    165220    end;
     221    result.NotifyLoaded;
    166222  except
    167223    on ex: Exception do
    168224    begin
    169225      AStream.Position := OldPosition;
     226      if not Assigned(ADestination) then result.Free;
    170227      raise ex;
    171228    end;
     
    175232procedure SaveLayersToStream(AStream: TStream; ALayers: TBGRACustomLayeredBitmap; ASelectedLayerIndex: integer; ACompression: TLzpCompression);
    176233var
    177   LayerOption,StackOption: longint;
     234  StackOption: longint;
    178235  i: integer;
    179   LayerHeaderSizePosition,LayerHeaderPosition: int64;
    180   LayerBitmapPosition,LayerBitmapSizePosition,BitmapSize: int64;
    181   LayerHeaderSize: integer;
     236  DirectoryOffsetPos, EndPos: int64;
     237  LayerHeaderPosition: int64;
     238  LayerBitmapPosition,BitmapSize, startPos: int64;
    182239  bitmap: TBGRABitmap;
     240  h: TLayerHeader;
    183241begin
    184242  if (ASelectedLayerIndex < -1) or (ASelectedLayerIndex >= ALayers.NbLayers) then
    185243    raise exception.Create('Selected layer out of bounds');
     244
     245  ALayers.NotifySaving;
     246
     247  startPos := AStream.Position;
    186248  AStream.Write(StreamHeader[1], length(StreamHeader));
    187   LEWriteLongint(AStream, 12); //header size
     249  LEWriteLongint(AStream, 28); //header size
    188250  LEWriteLongint(AStream, ALayers.NbLayers);
    189251  LEWriteLongint(AStream, ASelectedLayerIndex);
     
    192254  if ACompression = lzpRLE then StackOption:= StackOption or 2;
    193255  LEWriteLongint(AStream, StackOption);
     256  LEWriteLongint(AStream, ALayers.Width);
     257  LEWriteLongint(AStream, ALayers.Height);
     258  DirectoryOffsetPos := AStream.Position;
     259  LEWriteInt64(AStream, 0);
    194260  //end of header
    195261
    196262  for i := 0 to ALayers.NbLayers-1 do
    197263  begin
    198     LayerHeaderSizePosition:= AStream.Position;
    199     LEWriteLongint(AStream, 0); //header size not computed yet
     264    LEWriteLongint(AStream, sizeof(h));
    200265    LayerHeaderPosition := AStream.Position;
    201266
    202     LayerOption := 0;
    203     if ALayers.LayerVisible[i] then LayerOption:= LayerOption or 1;
    204     LEWriteLongint(AStream, LayerOption);
    205     LEWriteLongint(AStream, Longint(ALayers.BlendOperation[i]));
    206     LEWriteLongint(AStream, ALayers.LayerOffset[i].x);
    207     LEWriteLongint(AStream, ALayers.LayerOffset[i].y);
    208     LEWriteLongint(AStream, ALayers.LayerUniqueId[i]);
    209     LEWriteLongint(AStream, integer(ALayers.LayerOpacity[i])*$101);
    210     LayerBitmapSizePosition:=AStream.Position;
    211     LEWriteLongint(AStream, 0);
     267    bitmap := ALayers.GetLayerBitmapDirectly(i); //do it before to ensure update from original
     268
     269    h.LayerOption:= 0;
     270    if ALayers.LayerVisible[i] then h.LayerOption:= h.LayerOption or 1;
     271    h.BlendOp:= Longint(ALayers.BlendOperation[i]);
     272    h.LayerOfsX:= ALayers.LayerOffset[i].x;
     273    h.LayerOfsY:= ALayers.LayerOffset[i].y;
     274    h.LayerUniqueId:= ALayers.LayerUniqueId[i];
     275    h.LayerOpacity:= integer(ALayers.LayerOpacity[i])*$101;
     276    h.LayerBitmapSize := 0;
     277    h.OriginalGuid := ALayers.LayerOriginalGuid[i];
     278    h.OriginalMatrix := ALayers.LayerOriginalMatrix[i];
     279    h.FixEndian;
     280    AStream.WriteBuffer(h, sizeof(h));
     281    //end of layer header
     282
    212283    LayerBitmapPosition:=AStream.Position;
    213     LayerHeaderSize := LayerBitmapPosition - LayerHeaderPosition;
    214     AStream.Position:= LayerHeaderSizePosition;
    215     LEWriteLongint(AStream, LayerHeaderSize);
    216     //end of layer header
    217 
    218     AStream.Position:= LayerBitmapPosition;
    219     bitmap := ALayers.GetLayerBitmapDirectly(i);
    220284    if bitmap <> nil then
    221285      SaveLayerBitmapToStream(AStream, bitmap, ALayers.LayerName[i], ACompression)
     
    226290      bitmap.free;
    227291    end;
     292
    228293    BitmapSize := AStream.Position - LayerBitmapPosition;
    229     if BitmapSize > maxLongint then
    230       raise exception.Create('Image too big');
    231     AStream.Position:= LayerBitmapSizePosition;
    232     LEWriteLongint(AStream, BitmapSize);
     294
     295    //store back the bitmap size
     296    AStream.Position:= LayerHeaderPosition + (PByte(@PLayerHeader(nil)^.LayerBitmapSize)-PByte(nil));
     297    LEWriteInt64(AStream, BitmapSize);
     298
    233299    AStream.Position:= LayerBitmapPosition+BitmapSize;
     300  end;
     301
     302  EndPos:= AStream.Position;
     303  if ALayers.HasMemFiles then
     304  begin
     305    AStream.Position := DirectoryOffsetPos;
     306    LEWriteInt64(AStream,EndPos-startPos);
     307    AStream.Position:= EndPos;
     308    ALayers.MemDirectory.SaveToStream(AStream);
    234309  end;
    235310end;
     
    271346  LayeredBitmapSaveToStreamProc := @SaveLayeredBitmapToStream;
    272347  LayeredBitmapLoadFromStreamProc := @LoadLayeredBitmapFromStream;
    273 end;
     348  LayeredBitmapCheckStreamProc := @CheckStreamForLayers;
     349end;
     350
     351initialization
     352
     353  RegisterStreamLayers;
    274354
    275355end.
  • GraphicTest/Packages/bgrabitmap/bgrasvg.pas

    r494 r521  
    77uses
    88  Classes, SysUtils, BGRABitmapTypes, laz2_DOM, BGRAUnits, BGRASVGShapes,
    9   BGRACanvas2D;
     9  BGRACanvas2D, BGRASVGType, FPimage;
     10
     11type
     12  TCSSUnit = BGRAUnits.TCSSUnit;
     13
     14const
     15  cuCustom = BGRAUnits.cuCustom;
     16  cuPixel = BGRAUnits.cuPixel;
     17  cuCentimeter = BGRAUnits.cuCentimeter;
     18  cuMillimeter = BGRAUnits.cuMillimeter;
     19  cuInch = BGRAUnits.cuInch;
     20  cuPica = BGRAUnits.cuPica;
     21  cuPoint = BGRAUnits.cuPoint;
     22  cuFontEmHeight = BGRAUnits.cuFontEmHeight;
     23  cuFontXHeight = BGRAUnits.cuFontXHeight;
     24  cuPercent = BGRAUnits.cuPercent;
    1025
    1126type
     
    2136  TSVGUnits = class(TCSSUnitConverter)
    2237  private
     38    FOnRecompute: TSVGRecomputeEvent;
     39    FViewOffset: TPointF;
    2340    function GetCustomDpi: TPointF;
    2441    procedure Recompute;
     42    procedure SetOnRecompute(AValue: TSVGRecomputeEvent);
    2543  protected
    2644    FSvg: TDOMElement;
    2745    FViewBox: TSVGViewBox;
    28     FViewSize: TSVGSize;
     46    FOriginalViewSize, FProportionalViewSize: TSVGSize;
     47
    2948    FDefaultUnitHeight, FDefaultUnitWidth: TFloatWithCSSUnit;
    3049    FDefaultDpi: PSingle;
    3150    FUseDefaultDPI: boolean;
    3251    FDpiScaleX,FDpiScaleY: single;
     52    FContainerHeight: TFloatWithCSSUnit;
     53    FContainerWidth: TFloatWithCSSUnit;
     54    procedure SetContainerHeight(AValue: TFloatWithCSSUnit);
     55    procedure SetContainerWidth(AValue: TFloatWithCSSUnit);
    3356    function GetDefaultUnitHeight: TFloatWithCSSUnit; override;
    3457    function GetDefaultUnitWidth: TFloatWithCSSUnit; override;
     
    4770    procedure SetDefaultDpiAndOrigin;
    4871    constructor Create(ASvg: TDOMElement; ADefaultDpi: PSingle);
     72    function GetStretchRectF(AViewSize: TRectF; par: TSVGPreserveAspectRatio): TRectF;
    4973    property ViewBox: TSVGViewBox read FViewBox write SetViewBox;
     74    property OriginalViewSize: TSVGSize read FOriginalViewSize;
     75    property ProportionalViewSize: TSVGSize read FProportionalViewSize;
     76    property ViewOffset: TPointF read FViewOffset;
    5077    property CustomOrigin: TPointF read GetCustomOrigin write SetCustomOrigin;
    5178    property CustomDpiX: single read GetCustomDpiX;
    5279    property CustomDpiY: single read GetCustomDpiY;
    5380    property CustomDpi: TPointF read GetCustomDpi write SetCustomDpi;
     81    property ContainerWidth: TFloatWithCSSUnit read FContainerWidth write SetContainerWidth;
     82    property ContainerHeight: TFloatWithCSSUnit read FContainerHeight write SetContainerHeight;
     83    property OnRecompute: TSVGRecomputeEvent read FOnRecompute write SetOnRecompute;
    5484  end;
    5585
     
    5888  TBGRASVG = class
    5989  private
    60     function GetAttribute(AName: string): string;
     90    function GetAttribute(AName: string): string; overload;
     91    function GetAttribute(AName: string; ADefault: string): string; overload;
    6192    function GetCustomDpi: TPointF;
    6293    function GetHeight: TFloatWithCSSUnit;
    6394    function GetHeightAsCm: single;
    6495    function GetHeightAsInch: single;
    65     function GetPreserveAspectRatio: string;
    66     function GetViewBox: TSVGViewBox;
    67     function GetViewBox(AUnit: TCSSUnit): TSVGViewBox;
     96    function GetPreserveAspectRatio: TSVGPreserveAspectRatio;
     97    function GetUTF8String: utf8string;
     98    function GetViewBox: TSVGViewBox; overload;
     99    function GetViewBox(AUnit: TCSSUnit): TSVGViewBox; overload;
    68100    procedure GetViewBoxIndirect(AUnit: TCSSUnit; out AViewBox: TSVGViewBox);
     101    function GetViewMin(AUnit: TCSSUnit): TPointF;
     102    function GetViewSize(AUnit: TCSSUnit): TPointF;
    69103    function GetWidth: TFloatWithCSSUnit;
    70104    function GetWidthAsCm: single;
     
    77111    procedure SetHeightAsCm(AValue: single);
    78112    procedure SetHeightAsInch(AValue: single);
    79     procedure SetPreserveAspectRatio(AValue: string);
     113    procedure SetPreserveAspectRatio(AValue: TSVGPreserveAspectRatio);
     114    procedure SetUTF8String(AValue: utf8string);
    80115    procedure SetViewBox(AValue: TSVGViewBox);
    81116    procedure SetWidth(AValue: TFloatWithCSSUnit);
     
    89124    FDefaultDpi: single;
    90125    FContent: TSVGContent;
     126    FDataLink: TSVGDataLink;
    91127    procedure Init(ACreateEmpty: boolean);
    92128    function GetViewBoxAlignment(AHorizAlign: TAlignment; AVertAlign: TTextLayout): TPointF;
     129    procedure UnitsRecompute(Sender: TObject);
    93130  public
    94131    constructor Create; overload;
     
    97134    constructor Create(AFilenameUTF8: string); overload;
    98135    constructor Create(AStream: TStream); overload;
     136    constructor CreateFromString(AUTF8String: string);
    99137    destructor Destroy; override;
    100138    procedure LoadFromFile(AFilenameUTF8: string);
    101139    procedure LoadFromStream(AStream: TStream);
     140    procedure LoadFromResource(AFilename: string);
    102141    procedure SaveToFile(AFilenameUTF8: string);
    103142    procedure SaveToStream(AStream: TStream);
     
    108147    procedure Draw(ACanvas2d: TBGRACanvas2D; x,y: single; destDpi: single); overload;
    109148    procedure Draw(ACanvas2d: TBGRACanvas2D; x,y: single; destDpi: TPointF); overload;
    110     procedure StretchDraw(ACanvas2d: TBGRACanvas2D; x,y,w,h: single); overload;
     149    procedure StretchDraw(ACanvas2d: TBGRACanvas2D; x,y,w,h: single; useSvgAspectRatio: boolean = false); overload;
     150    procedure StretchDraw(ACanvas2d: TBGRACanvas2D; r: TRectF; useSvgAspectRatio: boolean = false); overload;
    111151    procedure StretchDraw(ACanvas2d: TBGRACanvas2D; AHorizAlign: TAlignment; AVertAlign: TTextLayout; x,y,w,h: single); overload;
     152    function GetStretchRectF(AHorizAlign: TAlignment; AVertAlign: TTextLayout; x,y,w,h: single): TRectF;
     153    property AsUTF8String: utf8string read GetUTF8String write SetUTF8String;
    112154    property Units: TSVGUnits read FUnits;
    113155    property Width: TFloatWithCSSUnit read GetWidth write SetWidth;
     
    120162    property ViewBox: TSVGViewBox read GetViewBox write SetViewBox;
    121163    property ViewBoxInUnit[AUnit: TCSSUnit]: TSVGViewBox read GetViewBox;
     164    property ViewMinInUnit[AUnit: TCSSUnit]: TPointF read GetViewMin;
     165    property ViewSizeInUnit[AUnit: TCSSUnit]: TPointF read GetViewSize;
    122166    property Attribute[AName: string]: string read GetAttribute write SetAttribute;
     167    property AttributeDef[AName: string; ADefault: string]: string read GetAttribute;
    123168    property DefaultDpi: single read FDefaultDpi write SetDefaultDpi; //this is not saved in the SVG file
    124169    property CustomDpi: TPointF read GetCustomDpi write SetCustomDpi;
    125170    property Content: TSVGContent read FContent;
    126     property preserveAspectRatio: string read GetPreserveAspectRatio write SetPreserveAspectRatio;
    127   end;
     171    property DataLink: TSVGDataLink read FDataLink;//(for test or internal info)
     172    property preserveAspectRatio: TSVGPreserveAspectRatio read GetPreserveAspectRatio write SetPreserveAspectRatio;
     173  end;
     174
     175  { TFPReaderSVG }
     176
     177  TFPReaderSVG = class(TBGRAImageReader)
     178    private
     179      FRenderDpi: single;
     180      FWidth,FHeight: integer;
     181      FScale: single;
     182    protected
     183      function InternalCheck(Stream: TStream): boolean; override;
     184      procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
     185    public
     186      constructor Create; override;
     187      function GetQuickInfo(AStream: TStream): TQuickImageInfo; override;
     188      function GetBitmapDraft(AStream: TStream; AMaxWidth, AMaxHeight: integer; out AOriginalWidth,AOriginalHeight: integer): TBGRACustomBitmap; override;
     189      property RenderDpi: single read FRenderDpi write FRenderDpi;
     190      property Width: integer read FWidth;
     191      property Height: integer read FHeight;
     192      property Scale: single read FScale write FScale;
     193  end;
     194
     195procedure RegisterSvgFormat;
    128196
    129197implementation
    130198
    131 uses laz2_XMLRead, laz2_XMLWrite, BGRAUTF8;
     199uses laz2_XMLRead, laz2_XMLWrite, BGRAUTF8, math;
    132200
    133201const SvgNamespace = 'http://www.w3.org/2000/svg';
     202
     203{ TFPReaderSVG }
     204
     205function TFPReaderSVG.InternalCheck(Stream: TStream): boolean;
     206var
     207  magic: array[1..6] of char;
     208  prevPos: int64;
     209  count: LongInt;
     210begin
     211  prevPos := Stream.Position;
     212  count := Stream.Read({%H-}magic, sizeof(magic));
     213  Stream.Position:= prevPos;
     214  result:= (count = sizeof(magic)) and (magic = '<?xml ');
     215end;
     216
     217procedure TFPReaderSVG.InternalRead(Stream: TStream; Img: TFPCustomImage);
     218var
     219  svg: TBGRASVG;
     220  vmin,vsize: TPointF;
     221  bgra: TBGRACustomBitmap;
     222  c2d: TBGRACanvas2D;
     223  y, x: Integer;
     224  p: PBGRAPixel;
     225begin
     226  svg := TBGRASVG.Create(Stream);
     227  bgra := nil;
     228  try
     229    svg.DefaultDpi:= RenderDpi;
     230    if Img is TBGRACustomBitmap then
     231      bgra := TBGRACustomBitmap(Img)
     232    else
     233      bgra := BGRABitmapFactory.Create;
     234    vsize := svg.GetViewSize(cuPixel);
     235    bgra.SetSize(ceil(vsize.x*scale),ceil(vsize.y*scale));
     236    bgra.FillTransparent;
     237    vmin := svg.GetViewMin(cuPixel);
     238    c2d := TBGRACanvas2D.Create(bgra);
     239    c2d.scale(Scale);
     240    c2d.translate(-vmin.x,-vmin.y);
     241    svg.Draw(c2d,0,0);
     242    c2d.Free;
     243    if bgra<>Img then
     244    begin
     245      Img.SetSize(bgra.Width,bgra.Height);
     246      for y := 0 to bgra.Height-1 do
     247      begin
     248        p := bgra.ScanLine[y];
     249        for x := 0 to bgra.Width-1 do
     250        begin
     251          Img.Colors[x,y] := BGRAToFPColor(p^);
     252          inc(p);
     253        end;
     254      end;
     255    end;
     256    FWidth:= bgra.Width;
     257    FHeight:= bgra.Height;
     258  finally
     259    if bgra<>Img then bgra.Free;
     260    svg.Free;
     261  end;
     262end;
     263
     264constructor TFPReaderSVG.Create;
     265begin
     266  inherited Create;
     267  FRenderDpi:= 96;
     268  FScale := 1;
     269end;
     270
     271function TFPReaderSVG.GetQuickInfo(AStream: TStream): TQuickImageInfo;
     272var
     273  svg: TBGRASVG;
     274  vsize: TPointF;
     275begin
     276  svg := TBGRASVG.Create(AStream);
     277  svg.DefaultDpi:= RenderDpi;
     278  vsize := svg.GetViewSize(cuPixel);
     279  svg.Free;
     280  result.Width:= ceil(vsize.x);
     281  result.Height:= ceil(vsize.y);
     282  result.AlphaDepth:= 8;
     283  result.ColorDepth:= 24;
     284end;
     285
     286function TFPReaderSVG.GetBitmapDraft(AStream: TStream; AMaxWidth,
     287  AMaxHeight: integer; out AOriginalWidth, AOriginalHeight: integer): TBGRACustomBitmap;
     288var
     289  svg: TBGRASVG;
     290  vmin,vsize: TPointF;
     291  c2d: TBGRACanvas2D;
     292  ratio: Single;
     293begin
     294  svg := TBGRASVG.Create(AStream);
     295  result := nil;
     296  try
     297    svg.DefaultDpi:= RenderDpi;
     298    vsize := svg.GetViewSize(cuPixel);
     299    AOriginalWidth:= ceil(vsize.x);
     300    AOriginalHeight:= ceil(vsize.y);
     301    if (vsize.x = 0) or (vsize.y = 0) then exit;
     302    ratio := min(AMaxWidth/vsize.x, AMaxHeight/vsize.y);
     303    result := BGRABitmapFactory.Create(ceil(vsize.x*ratio),ceil(vsize.y*ratio));
     304    if ratio <> 0 then
     305    begin
     306      vmin := svg.GetViewMin(cuPixel);
     307      c2d := TBGRACanvas2D.Create(result);
     308      c2d.scale(ratio);
     309      c2d.translate(-vmin.x,-vmin.y);
     310      svg.Draw(c2d,0,0);
     311      c2d.Free;
     312    end;
     313  finally
     314    svg.Free;
     315  end;
     316end;
     317
     318var AlreadyRegistered: boolean;
     319
     320procedure RegisterSvgFormat;
     321begin
     322  if AlreadyRegistered then exit;
     323  ImageHandlers.RegisterImageReader ('Scalable Vector Graphic', 'svg', TFPReaderSVG);
     324  AlreadyRegistered:= True;
     325end;
    134326
    135327function TSVGUnits.GetCustomDpiX: single;
    136328var pixSize: single;
    137329begin
    138   pixSize := Convert(FDefaultUnitWidth.value,FDefaultUnitWidth.CSSUnit,cuInch,FDefaultDpi^);
     330  with GetDefaultUnitWidth do
     331    pixSize := Convert(value,CSSUnit,cuInch,FDefaultDpi^);
    139332  if pixSize = 0 then
    140333    result := 0
     
    146339var pixSize: single;
    147340begin
    148   pixSize := Convert(FDefaultUnitHeight.value,FDefaultUnitHeight.CSSUnit,cuInch,FDefaultDpi^);
     341  with GetDefaultUnitHeight do
     342    pixSize := Convert(value,CSSUnit,cuInch,FDefaultDpi^);
    149343  if pixSize = 0 then
    150344    result := 0
     
    194388  FViewBox.size.y := parseNextFloat;
    195389
    196   FViewSize.width := parseValue(FSvg.GetAttribute('width'), FloatWithCSSUnit(FViewBox.size.x, cuPixel));
    197   if FViewSize.width.CSSUnit = cuCustom then FViewSize.width.CSSUnit := cuPixel;
    198   FViewSize.height := parseValue(FSvg.GetAttribute('height'), FloatWithCSSUnit(FViewBox.size.y, cuPixel));
    199   if FViewSize.height.CSSUnit = cuCustom then FViewSize.height.CSSUnit := cuPixel;
     390  FOriginalViewSize.width := parseValue(FSvg.GetAttribute('width'), FloatWithCSSUnit(FViewBox.size.x, cuPixel));
     391  if FOriginalViewSize.width.CSSUnit = cuCustom then FOriginalViewSize.width.CSSUnit := cuPixel;
     392  if FOriginalViewSize.width.CSSUnit = cuPercent then
     393  begin
     394    FOriginalViewSize.width.value := FOriginalViewSize.width.value/100*FContainerWidth.value;
     395    FOriginalViewSize.width.CSSUnit := FContainerWidth.CSSUnit;
     396  end;
     397  FOriginalViewSize.height := parseValue(FSvg.GetAttribute('height'), FloatWithCSSUnit(FViewBox.size.y, cuPixel));
     398  if FOriginalViewSize.height.CSSUnit = cuCustom then FOriginalViewSize.height.CSSUnit := cuPixel;
     399  if FOriginalViewSize.height.CSSUnit = cuPercent then
     400  begin
     401    FOriginalViewSize.height.value := FOriginalViewSize.height.value/100*FContainerHeight.value;
     402    FOriginalViewSize.height.CSSUnit := FContainerHeight.CSSUnit;
     403  end;
     404  if FOriginalViewSize.height.CSSUnit <> FOriginalViewSize.width.CSSUnit then
     405    FOriginalViewSize.height := ConvertHeight(FOriginalViewSize.height, FOriginalViewSize.width.CSSUnit);
     406
     407  FProportionalViewSize := FOriginalViewSize;
     408  with GetStretchRectF(RectF(0,0,FOriginalViewSize.width.value,FOriginalViewSize.height.value), TSVGPreserveAspectRatio.DefaultValue) do
     409  begin
     410    FProportionalViewSize.width.value := Right-Left;
     411    FProportionalViewSize.height.value := Bottom-Top;
     412  end;
    200413
    201414  if (FViewBox.size.x <= 0) and (FViewBox.size.y <= 0) then
     
    209422      FDpiScaleY := 1;
    210423      FViewBox.min := PointF(0,0);
    211       FViewBox.size.x := ConvertWidth(FViewSize.width,cuCustom).value;
    212       FViewBox.size.y := ConvertHeight(FViewSize.height,cuCustom).value;
     424      FViewBox.size.x := ConvertWidth(FProportionalViewSize.width,cuCustom).value;
     425      FViewBox.size.y := ConvertHeight(FProportionalViewSize.height,cuCustom).value;
    213426    end else
    214427    begin
    215       FDefaultUnitWidth.value := FViewSize.width.value/FViewBox.size.x;
    216       FDefaultUnitWidth.CSSUnit := FViewSize.width.CSSUnit;
     428      FDefaultUnitWidth.value := FProportionalViewSize.width.value/FViewBox.size.x;
     429      FDefaultUnitWidth.CSSUnit := FProportionalViewSize.width.CSSUnit;
    217430      if FDefaultUnitWidth.CSSUnit = cuCustom then
    218431        begin
     
    220433          FDefaultUnitWidth.CSSUnit := cuInch;
    221434        end;
    222       FDefaultUnitHeight.value := FViewSize.height.value/FViewBox.size.y;
    223       FDefaultUnitHeight.CSSUnit := FViewSize.height.CSSUnit;
     435      FDefaultUnitHeight.value := FProportionalViewSize.height.value/FViewBox.size.y;
     436      FDefaultUnitHeight.CSSUnit := FProportionalViewSize.height.CSSUnit;
    224437      if FDefaultUnitHeight.CSSUnit = cuCustom then
    225438        begin
     
    231444      FDpiScaleY := CustomDpiY/DpiY;
    232445    end;
     446
     447  if Assigned(FOnRecompute) then FOnRecompute(self);
     448end;
     449
     450procedure TSVGUnits.SetOnRecompute(AValue: TSVGRecomputeEvent);
     451begin
     452  if FOnRecompute=AValue then Exit;
     453  FOnRecompute:=AValue;
     454end;
     455
     456procedure TSVGUnits.SetContainerHeight(AValue: TFloatWithCSSUnit);
     457begin
     458  if CompareMem(@FContainerHeight,@AValue,sizeof(TFloatWithCSSUnit)) then Exit;
     459  FContainerHeight:=AValue;
     460  Recompute;
     461end;
     462
     463procedure TSVGUnits.SetContainerWidth(AValue: TFloatWithCSSUnit);
     464begin
     465  if CompareMem(@FContainerWidth,@AValue,sizeof(TFloatWithCSSUnit)) then Exit;
     466  FContainerWidth:=AValue;
     467  Recompute;
    233468end;
    234469
     
    238473begin
    239474  vb := ViewBox;
    240   vs := FViewSize;
     475  vs := FProportionalViewSize;
    241476  if (vs.width.value > 0) and (vs.height.value > 0) then
    242477    begin
     
    303538  FSvg := ASvg;
    304539  FDefaultDpi := ADefaultDpi;
     540  FContainerWidth := FloatWithCSSUnit(640,cuPixel);
     541  FContainerHeight := FloatWithCSSUnit(480,cuPixel);
    305542  Recompute;
    306543end;
    307544
     545function TSVGUnits.GetStretchRectF(AViewSize: TRectF; par: TSVGPreserveAspectRatio): TRectF;
     546var w0,h0,w,h: single;
     547begin
     548  result := AViewSize;
     549  w0 := AViewSize.Right-AViewSize.Left;
     550  h0 := AViewSize.Bottom-AViewSize.Top;
     551  w := w0;
     552  h := h0;
     553
     554  if par.Preserve and
     555     (FViewBox.size.x > 0) and (FViewBox.size.y > 0) and
     556     (w > 0) and (h > 0) then
     557  begin
     558    //viewBox wider than viewSize
     559    if (FViewBox.size.x/FViewBox.size.y > w/h) xor par.Slice then
     560      h := w * FViewBox.size.y / FViewBox.size.x
     561    else
     562      w := h * FViewBox.size.x / FViewBox.size.y;
     563    case par.HorizAlign of
     564      taCenter: result.Left += (w0-w)/2;
     565      taRightJustify: result.Left += w0-w;
     566    end;
     567    case par.VertAlign of
     568      tlCenter: result.Top += (h0-h)/2;
     569      tlBottom: result.Top += h0-h;
     570    end;
     571  end;
     572  result.Right := result.Left+w;
     573  result.Bottom := result.Top+h;
     574end;
     575
    308576{ TBGRASVG }
    309577
    310578function TBGRASVG.GetAttribute(AName: string): string;
    311579begin
    312   result := FRoot.GetAttribute(AName);
     580  result := Trim(FRoot.GetAttribute(AName));
     581end;
     582
     583function TBGRASVG.GetAttribute(AName: string; ADefault: string): string;
     584begin
     585  result := GetAttribute(AName);
     586  if result = '' then result := ADefault;
    313587end;
    314588
     
    320594function TBGRASVG.GetHeight: TFloatWithCSSUnit;
    321595begin
    322   result := TCSSUnitConverter.parseValue(Attribute['height'],FloatWithCSSUnit(0,cuCustom));
     596  result := TCSSUnitConverter.parseValue(Attribute['height'],FloatWithCSSUnit(FUnits.ViewBox.size.y,cuCustom));
    323597end;
    324598
     
    333607end;
    334608
    335 function TBGRASVG.GetPreserveAspectRatio: string;
    336 begin
    337   result := Attribute['preserveAspectRatio'];
     609function TBGRASVG.GetPreserveAspectRatio: TSVGPreserveAspectRatio;
     610begin
     611  result := TSVGPreserveAspectRatio.Parse(Attribute['preserveAspectRatio','xMidYMid']);
     612end;
     613
     614function TBGRASVG.GetUTF8String: utf8string;
     615var str: TMemoryStream;
     616begin
     617  str := TMemoryStream.Create;
     618  SaveToStream(str);
     619  setlength(result, str.Size);
     620  str.Position := 0;
     621  str.Read(result[1], length(result));
     622  str.Free;
    338623end;
    339624
     
    357642end;
    358643
     644function TBGRASVG.GetViewMin(AUnit: TCSSUnit): TPointF;
     645var
     646  vb: TSVGViewBox;
     647begin
     648  GetViewBoxIndirect(AUnit,vb);
     649  result:= vb.min;
     650end;
     651
     652function TBGRASVG.GetViewSize(AUnit: TCSSUnit): TPointF;
     653var
     654  vb: TSVGViewBox;
     655begin
     656  GetViewBoxIndirect(AUnit,vb);
     657  result:= vb.size;
     658end;
     659
    359660function TBGRASVG.GetWidth: TFloatWithCSSUnit;
    360661begin
    361   result := TCSSUnitConverter.parseValue(Attribute['width'],FloatWithCSSUnit(0,cuCustom));
     662  result := TCSSUnitConverter.parseValue(Attribute['width'],FloatWithCSSUnit(FUnits.ViewBox.size.x,cuCustom));
    362663end;
    363664
     
    374675function TBGRASVG.GetZoomable: boolean;
    375676begin
    376   result := trim(Attribute['zoomAndPan'])<>'disable';
     677  result := AttributeDef['zoomAndPan','magnify']<>'disable';
    377678end;
    378679
     
    392693  FUnits.CustomDpi := AValue;
    393694  if AValue.x <> AValue.y then
    394     preserveAspectRatio := 'none';
     695    preserveAspectRatio := TSVGPreserveAspectRatio.Parse('none');
    395696end;
    396697
     
    417718end;
    418719
    419 procedure TBGRASVG.SetPreserveAspectRatio(AValue: string);
    420 begin
    421   Attribute['preserveAspectRatio'] := AValue;
     720procedure TBGRASVG.SetPreserveAspectRatio(AValue: TSVGPreserveAspectRatio);
     721begin
     722  Attribute['preserveAspectRatio'] := AValue.ToString;
     723  Units.Recompute;
     724end;
     725
     726procedure TBGRASVG.SetUTF8String(AValue: utf8string);
     727var str: TMemoryStream;
     728begin
     729  str:= TMemoryStream.Create;
     730  str.Write(AValue[1],length(AValue));
     731  str.Position:= 0;
     732  LoadFromStream(str);
     733  str.Free;
    422734end;
    423735
     
    460772    FRoot := FXml.CreateElement('svg');
    461773    FUnits := TSVGUnits.Create(FRoot,@FDefaultDpi);
    462     FContent := TSVGContent.Create(FXml,FRoot,FUnits);
     774    FUnits.OnRecompute:= @UnitsRecompute;
     775    FDataLink := TSVGDataLink.Create;
     776    FContent := TSVGContent.Create(FXml,FRoot,FUnits,FDataLink,nil);
    463777    FXml.AppendChild(FRoot);
    464778  end;
     
    487801end;
    488802
     803procedure TBGRASVG.UnitsRecompute(Sender: TObject);
     804begin
     805  FContent.Recompute;
     806end;
     807
    489808constructor TBGRASVG.Create;
    490809begin
     
    523842end;
    524843
     844constructor TBGRASVG.CreateFromString(AUTF8String: string);
     845begin
     846  Init(False);
     847  AsUTF8String:= AUTF8String;
     848end;
     849
    525850destructor TBGRASVG.Destroy;
    526851begin
     852  FreeAndNil(FDataLink);
    527853  FreeAndNil(FContent);
    528854  FreeAndNil(FUnits);
     
    565891    raise exception.Create('Root node not found');
    566892  end;
     893  FreeAndNil(FDataLink);
    567894  FreeAndNil(FContent);
    568895  FreeAndNil(FUnits);
     
    571898  FRoot := root as TDOMElement;
    572899  FUnits := TSVGUnits.Create(FRoot,@FDefaultDpi);
    573   FContent := TSVGContent.Create(FXml,FRoot,FUnits);
     900  FUnits.OnRecompute:= @UnitsRecompute;
     901  FDataLink := TSVGDataLink.Create;
     902  FContent := TSVGContent.Create(FXml,FRoot,FUnits,FDataLink,nil);
     903end;
     904
     905procedure TBGRASVG.LoadFromResource(AFilename: string);
     906var
     907  stream: TStream;
     908begin
     909  stream := BGRAResource.GetResourceStream(AFilename);
     910  try
     911    LoadFromStream(stream);
     912  finally
     913    stream.Free;
     914  end;
    574915end;
    575916
     
    614955  ACanvas2d.translate(x,y);
    615956  ACanvas2d.scale(destDpi.x/Units.DpiX,destDpi.y/Units.DpiY);
    616   ACanvas2d.strokeResetTransform;
    617   ACanvas2d.strokeScale(destDpi.x/Units.DpiX,destDpi.y/Units.DpiY);
    618957  with GetViewBoxAlignment(AHorizAlign,AVertAlign) do ACanvas2d.translate(x,y);
    619958  Draw(ACanvas2d, 0,0, cuPixel);
     
    628967  ACanvas2d.save;
    629968  ACanvas2d.translate(x,y);
     969  ACanvas2d.strokeMatrix := ACanvas2d.matrix;
    630970  Content.Draw(ACanvas2d,AUnit);
    631971  ACanvas2d.restore;
     
    643983  ACanvas2d.translate(x,y);
    644984  ACanvas2d.scale(destDpi.x/Units.DpiX,destDpi.y/Units.DpiY);
    645   ACanvas2d.strokeResetTransform;
    646   ACanvas2d.strokeScale(destDpi.x/Units.DpiX,destDpi.y/Units.DpiY);
    647985  Draw(ACanvas2d, 0,0, cuPixel);
    648986  ACanvas2d.restore;
    649987end;
    650988
    651 procedure TBGRASVG.StretchDraw(ACanvas2d: TBGRACanvas2D; x, y, w, h: single);
     989procedure TBGRASVG.StretchDraw(ACanvas2d: TBGRACanvas2D; x, y, w, h: single; useSvgAspectRatio: boolean);
    652990var vb: TSVGViewBox;
    653991begin
     992  if useSvgAspectRatio then
     993  begin
     994    with preserveAspectRatio do
     995      StretchDraw(ACanvas2d, HorizAlign, VertAlign, x,y,w,h);
     996    exit;
     997  end;
    654998  ACanvas2d.save;
    655999  ACanvas2d.translate(x,y);
     
    6601004    ACanvas2d.translate(-min.x,-min.y);
    6611005    if size.x <> 0 then
    662     begin
    6631006      ACanvas2d.scale(w/size.x,1);
    664       ACanvas2d.strokeScale(w/size.x,1);
    665     end;
    6661007    if size.y <> 0 then
    667     begin
    6681008      ACanvas2d.scale(1,h/size.y);
    669       ACanvas2d.strokeScale(1,h/size.y);
    670     end;
    6711009  end;
    6721010  Draw(ACanvas2d, 0,0);
     
    6741012end;
    6751013
     1014procedure TBGRASVG.StretchDraw(ACanvas2d: TBGRACanvas2D; r: TRectF; useSvgAspectRatio: boolean);
     1015begin
     1016  StretchDraw(ACanvas2d, r.Left,r.Top,r.Right-r.Left,r.Bottom-r.Top, useSvgAspectRatio);
     1017end;
     1018
    6761019procedure TBGRASVG.StretchDraw(ACanvas2d: TBGRACanvas2D;
    6771020  AHorizAlign: TAlignment; AVertAlign: TTextLayout; x, y, w, h: single);
     1021var r: TRectF;
     1022begin
     1023  r := GetStretchRectF(AHorizAlign,AVertAlign, x, y, w, h);
     1024  StretchDraw(ACanvas2d, r.Left,r.Top,r.Right-r.Left,r.Bottom-r.Top);
     1025end;
     1026
     1027function TBGRASVG.GetStretchRectF(AHorizAlign: TAlignment;
     1028  AVertAlign: TTextLayout; x, y, w, h: single): TRectF;
    6781029var ratio,stretchRatio,zoom: single;
    679   vb: TSVGViewBox;
    6801030  sx,sy,sw,sh: single;
    681 begin
    682   GetViewBoxIndirect(cuPixel,vb);
    683   if (h = 0) or (w = 0) or (vb.size.x = 0) or (vb.size.y = 0) then exit;
    684   ratio := vb.size.x/vb.size.y;
     1031  size: TSVGSize;
     1032begin
     1033  //determine global ratio according to viewSize
     1034  size := Units.OriginalViewSize;
     1035  size.width := Units.ConvertWidth(size.Width,cuPixel);
     1036  size.height := Units.ConvertHeight(size.height,cuPixel);
     1037  if (h = 0) or (w = 0) or (size.width.value = 0) or (size.height.value = 0) then
     1038  begin
     1039    result := RectF(x,y,w,h);
     1040    exit;
     1041  end;
     1042  ratio := size.width.value/size.height.value;
    6851043  stretchRatio := w/h;
    6861044  if ratio > stretchRatio then
    687     zoom := w / vb.size.x
     1045    zoom := w / size.width.value
    6881046  else
    689     zoom := h / vb.size.y;
     1047    zoom := h / size.height.value;
    6901048
    6911049  sx := x;
    6921050  sy := y;
    693   sw := vb.size.x*zoom;
    694   sh := vb.size.y*zoom;
     1051  sw := size.width.value*zoom;
     1052  sh := size.height.value*zoom;
    6951053
    6961054  case AHorizAlign of
     
    7021060    tlBottom: sy += h - sh;
    7031061  end;
    704   StretchDraw(ACanvas2d, sx,sy,sw,sh);
    705 end;
     1062
     1063  result := Units.GetStretchRectF(RectF(sx,sy,sx+sw,sy+sh), preserveAspectRatio);
     1064end;
     1065
     1066initialization
     1067
     1068  DefaultBGRAImageReader[ifSvg] := TFPReaderSVG;
    7061069
    7071070end.
  • GraphicTest/Packages/bgrabitmap/bgrasvgshapes.pas

    r494 r521  
    1010
    1111type
     12  TSVGGradient = class;
     13 
     14  { TSVGElementWithGradient }
     15
     16  TSVGElementWithGradient = class(TSVGElement)
     17    private
     18      FGradientElement: TSVGGradient;
     19      FGradientElementDefined: boolean;
     20      FCanvasGradient: IBGRACanvasGradient2D;
     21      function EvaluatePercentage(fu: TFloatWithCSSUnit): single; { fu is a percentage of a number [0.0..1.0] }
     22      function GetGradientElement: TSVGGradient;
     23      procedure ResetGradient;
     24      function FindGradientElement: boolean;
     25    protected
     26      procedure Initialize; override;
     27      procedure AddStopElements(canvas: IBGRACanvasGradient2D);
     28      procedure CreateCanvasLinearGradient(ACanvas2d: TBGRACanvas2D; ASVGGradient: TSVGGradient;
     29        const origin: TPointF; const w,h: single; AUnit: TCSSUnit);
     30      procedure CreateCanvasRadialGradient(ACanvas2d: TBGRACanvas2D; ASVGGradient: TSVGGradient;
     31        const origin: TPointF; const w,h: single; AUnit: TCSSUnit);
     32      procedure ApplyFillStyle(ACanvas2D: TBGRACanvas2D; AUnit: TCSSUnit); override;
     33    public
     34      procedure InitializeGradient(ACanvas2d: TBGRACanvas2D;
     35                const origin: TPointF; const w,h: single; AUnit: TCSSUnit);
     36      property GradientElement: TSVGGradient read GetGradientElement;
     37  end;       
     38 
    1239  { TSVGLine }
    1340
     
    2552      procedure InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); override;
    2653    public
    27       constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter); override;
     54      constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); override;
    2855      property x1: TFloatWithCSSUnit read GetX1 write SetX1;
    2956      property y1: TFloatWithCSSUnit read GetY1 write SetY1;
     
    3461  { TSVGRectangle }
    3562
    36   TSVGRectangle = class(TSVGElement)
     63  TSVGRectangle = class(TSVGElementWithGradient)
    3764    private
    3865      function GetX: TFloatWithCSSUnit;
     
    5178      procedure InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); override;
    5279    public
    53       constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter); override;
     80      constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); override;
    5481      property x: TFloatWithCSSUnit read GetX write SetX;
    5582      property y: TFloatWithCSSUnit read GetY write SetY;
     
    6289  { TSVGCircle }
    6390
    64   TSVGCircle = class(TSVGElement)
     91  TSVGCircle = class(TSVGElementWithGradient)
    6592    private
    6693      function GetCX: TFloatWithCSSUnit;
     
    73100      procedure InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); override;
    74101    public
    75       constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter); override;
     102      constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); override;
    76103      property cx: TFloatWithCSSUnit read GetCX write SetCX;
    77104      property cy: TFloatWithCSSUnit read GetCY write SetCY;
     
    81108  { TSVGEllipse }
    82109
    83   TSVGEllipse = class(TSVGElement)
     110  TSVGEllipse = class(TSVGElementWithGradient)
    84111    private
    85112      function GetCX: TFloatWithCSSUnit;
     
    94121      procedure InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); override;
    95122    public
    96       constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter); override;
     123      constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); override;
    97124      property cx: TFloatWithCSSUnit read GetCX write SetCX;
    98125      property cy: TFloatWithCSSUnit read GetCY write SetCY;
     
    103130  { TSVGPath }
    104131
    105   TSVGPath = class(TSVGElement)
     132  TSVGPath = class(TSVGElementWithGradient)
    106133    private
    107134      FPath: TBGRAPath;
     135      FBoundingBox: TRectF;
     136      FBoundingBoxComputed: boolean;
     137      function GetBoundingBoxF: TRectF;
    108138      function GetPath: TBGRAPath;
    109139      function GetPathLength: TFloatWithCSSUnit;
     
    115145      procedure InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); override;
    116146    public
    117       constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter); override;
    118       constructor Create(ADocument: TXMLDocument; AElement: TDOMElement; AUnits: TCSSUnitConverter); override;
     147      constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); override;
     148      constructor Create(ADocument: TXMLDocument; AElement: TDOMElement; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); override;
    119149      destructor Destroy; override;
    120150      property d: string read GetData write SetData;
    121151      property path: TBGRAPath read GetPath;
    122152      property pathLength: TFloatWithCSSUnit read GetPathLength write SetPathLength;
     153      property boundingBoxF: TRectF read GetBoundingBoxF;
    123154  end;
    124155
    125156  { TSVGPolypoints }
    126157
    127   TSVGPolypoints = class(TSVGElement)
     158  TSVGPolypoints = class(TSVGElementWithGradient)
    128159    private
     160      FBoundingBox: TRectF;
     161      FBoundingBoxComputed: boolean;
     162      function GetBoundingBoxF: TRectF;
    129163      function GetClosed: boolean;
    130164      function GetPoints: string;
     
    132166      procedure SetPoints(AValue: string);
    133167      procedure SetPointsF(AValue: ArrayOfTPointF);
     168      procedure ComputeBoundingBox(APoints: ArrayOfTPointF);
    134169    protected
    135170      procedure InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); override;
    136171    public
    137       constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; AClosed: boolean); overload;
     172      constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; AClosed: boolean; ADataLink: TSVGDataLink); overload;
    138173      destructor Destroy; override;
    139174      property points: string read GetPoints write SetPoints;
    140175      property pointsF: ArrayOfTPointF read GetPointsF write SetPointsF;
    141176      property closed: boolean read GetClosed;
     177      property boundingBoxF: TRectF read GetBoundingBoxF;
    142178  end;
    143179
    144180  { TSVGText }
    145181
    146   TSVGText = class(TSVGElement)
     182  TSVGText = class(TSVGElementWithGradient)
    147183    private
    148184      function GetFontBold: boolean;
     
    169205      procedure InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); override;
    170206    public
    171       constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter); override;
     207      constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); override;
    172208      property x: TFloatWithCSSUnit read GetX write SetX;
    173209      property y: TFloatWithCSSUnit read GetY write SetY;
     
    183219
    184220  TSVGContent = class;
     221 
     222  TConvMethod = (cmNone,cmHoriz,cmVertical,cmOrtho);
     223 
     224  { TSVGGradient }
     225
     226  TSVGGradient = class(TSVGElement)
     227    private
     228      FContent: TSVGContent;
     229      function GetGradientMatrix(AUnit: TCSSUnit): TAffineMatrix;
     230      function GetGradientTransform: string;
     231      function GetGradientUnits: string;
     232      function GetHRef: string;
     233      function GetUseObjectBoundingBox: boolean;
     234      procedure SetGradientTransform(AValue: string);
     235      procedure SetGradientUnits(AValue: string);
     236      procedure SetHRef(AValue: string);
     237      function HRefToGradientID(const AValue: string): string;
     238      function FindGradientRef(const AGradientID: string): integer;
     239    protected
     240      InheritedGradients: TSVGElementList;//(for HRef)
     241      procedure Initialize; override;
     242      function GetInheritedAttribute(AValue: string;
     243        AConvMethod: TConvMethod; ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit;
     244    public
     245      constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter;
     246        ADataLink: TSVGDataLink); override;
     247      constructor Create(ADocument: TXMLDocument; AElement: TDOMElement;
     248        AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); override;
     249      destructor Destroy; override;
     250      procedure Recompute; override;
     251      procedure ScanInheritedGradients(const forceScan: boolean = false);
     252      property Content: TSVGContent read FContent;
     253      property hRef: string read GetHRef write SetHRef;
     254      property gradientUnits: string read GetGradientUnits write SetGradientUnits;
     255      property gradientTransform: string read GetGradientTransform write SetGradientTransform;
     256      property useObjectBoundingBox: boolean read GetUseObjectBoundingBox;
     257      property gradientMatrix[AUnit: TCSSUnit]: TAffineMatrix read GetGradientMatrix;
     258  end;       
     259
     260  { TSVGGradientLinear }
     261
     262  TSVGLinearGradient = class(TSVGGradient)
     263    private
     264      function GetX1: TFloatWithCSSUnit;
     265      function GetX2: TFloatWithCSSUnit;
     266      function GetY1: TFloatWithCSSUnit;
     267      function GetY2: TFloatWithCSSUnit;
     268      procedure SetX1(AValue: TFloatWithCSSUnit);
     269      procedure SetX2(AValue: TFloatWithCSSUnit);
     270      procedure SetY1(AValue: TFloatWithCSSUnit);
     271      procedure SetY2(AValue: TFloatWithCSSUnit);
     272    public
     273      constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter;
     274        ADataLink: TSVGDataLink); override;
     275      property x1: TFloatWithCSSUnit read GetX1 write SetX1;
     276      property y1: TFloatWithCSSUnit read GetY1 write SetY1;
     277      property x2: TFloatWithCSSUnit read GetX2 write SetX2;
     278      property y2: TFloatWithCSSUnit read GetY2 write SetY2;
     279  end;
     280
     281  { TSVGRadialGradient }
     282
     283  TSVGRadialGradient = class(TSVGGradient)
     284    private
     285      function GetCX: TFloatWithCSSUnit;
     286      function GetCY: TFloatWithCSSUnit;
     287      function GetR: TFloatWithCSSUnit;
     288      function GetFX: TFloatWithCSSUnit;
     289      function GetFY: TFloatWithCSSUnit;
     290      function GetFR: TFloatWithCSSUnit;
     291      procedure SetCX(AValue: TFloatWithCSSUnit);
     292      procedure SetCY(AValue: TFloatWithCSSUnit);
     293      procedure SetR(AValue: TFloatWithCSSUnit);
     294      procedure SetFX(AValue: TFloatWithCSSUnit);
     295      procedure SetFY(AValue: TFloatWithCSSUnit);
     296      procedure SetFR(AValue: TFloatWithCSSUnit);
     297    public
     298      constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter;
     299        ADataLink: TSVGDataLink); override;
     300      property cx: TFloatWithCSSUnit read GetCX write SetCX;
     301      property cy: TFloatWithCSSUnit read GetCY write SetCY;
     302      property r: TFloatWithCSSUnit read GetR write SetR;
     303      property fx: TFloatWithCSSUnit read GetFX write SetFX;
     304      property fy: TFloatWithCSSUnit read GetFY write SetFY;
     305      property fr: TFloatWithCSSUnit read GetFR write SetFR;
     306  end;
     307
     308  { TSVGStopGradient }
     309
     310  TSVGStopGradient = class(TSVGElement)
     311    private
     312      function GetOffset: TFloatWithCSSUnit;
     313      procedure SetOffset(AValue: TFloatWithCSSUnit);
     314    public
     315      constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter;
     316        ADataLink: TSVGDataLink); override;
     317      property Offset: TFloatWithCSSUnit read GetOffset write SetOffset;
     318  end;
     319
     320  { TSVGDefine }
     321
     322  TSVGDefine = class(TSVGElement)
     323  protected
     324    FContent: TSVGContent;
     325  public
     326    constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter;
     327      ADataLink: TSVGDataLink); override;
     328    constructor Create(ADocument: TXMLDocument; AElement: TDOMElement;
     329      AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); override;
     330    destructor Destroy; override;
     331    procedure Recompute; override;
     332    property Content: TSVGContent read FContent;
     333  end;
    185334
    186335  { TSVGGroup }
     
    191340    procedure InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); override;
    192341  public
    193     constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter); override;
     342    constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); override;
    194343    constructor Create(ADocument: TXMLDocument; AElement: TDOMElement;
    195       AUnits: TCSSUnitConverter); override;
     344      AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); override;
    196345    destructor Destroy; override;
     346    procedure Recompute; override;
    197347    property Content: TSVGContent read FContent;
    198348  end;
     349 
     350  { TSVGStyle }
     351
     352  TSVGStyleItem = record
     353    name,
     354    attribute: string;
     355  end;
     356  ArrayOfTSVGStyleItem = array of TSVGStyleItem;
     357
     358  TSVGStyle = class(TSVGElement)
     359   private
     360     FStyles: ArrayOfTSVGStyleItem;
     361     procedure Parse(const s: String);
     362     function IsValidID(const sid: integer): boolean;
     363     function GetStyle(const sid: integer): TSVGStyleItem;
     364     procedure SetStyle(const sid: integer; sr: TSVGStyleItem);
     365     function Find(sr: TSVGStyleItem): integer; overload;
     366   protected
     367     procedure Initialize; override;
     368   public
     369     constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); overload; override;
     370     constructor Create(ADocument: TXMLDocument; AElement: TDOMElement;
     371       AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); overload; override;
     372     destructor Destroy; override;
     373     function Count: Integer;
     374     function Find(const AName: string): integer; overload;
     375     function Add(sr: TSVGStyleItem): integer;
     376     procedure Remove(sr: TSVGStyleItem);
     377     procedure Clear;
     378     procedure ReParse;
     379     property Styles[sid: integer]: TSVGStyleItem read GetStyle write SetStyle;
     380  end;                 
    199381
    200382  { TSVGContent }
     
    202384  TSVGContent = class
    203385    protected
     386      FDataLink: TSVGDataLink;
    204387      FDomElem: TDOMElement;
    205388      FDoc: TXMLDocument;
    206       FElements: TList;
     389      FElements: TFPList;
    207390      FUnits: TCSSUnitConverter;
    208391      procedure AppendElement(AElement: TSVGElement);
     
    212395      function GetUnits: TCSSUnitConverter;
    213396    public
    214       constructor Create(ADocument: TXMLDocument; AElement: TDOMElement; AUnits: TCSSUnitConverter);
     397      constructor Create(ADocument: TXMLDocument; AElement: TDOMElement; AUnits: TCSSUnitConverter;
     398        ADataLink: TSVGDataLink; ADataParent: TSVGElement);
    215399      destructor Destroy; override;
     400      procedure Recompute;
    216401      procedure Draw(ACanvas2d: TBGRACanvas2D; x,y: single; AUnit: TCSSUnit); overload;
    217402      procedure Draw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); overload;
     
    239424function GetSVGFactory(ATagName: string): TSVGFactory;
    240425function CreateSVGElementFromNode(ADocument: TXMLDocument;
    241   AElement: TDOMElement; AUnits: TCSSUnitConverter): TSVGElement;
     426  AElement: TDOMElement; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink; ADataParent: TSVGElement): TSVGElement;
    242427
    243428implementation
     
    263448  if tag='text' then
    264449    result := TSVGText else
     450  if tag='lineargradient' then
     451    result := TSVGLinearGradient else
     452  if tag='radialgradient' then
     453    result := TSVGRadialGradient else
     454  if tag='stop' then
     455    result := TSVGStopGradient else
     456  if tag='defs' then
     457    result := TSVGDefine else
    265458  if tag='g' then
    266459    result := TSVGGroup else
     460  if tag='style' then
     461    result := TSVGStyle else
    267462    result := TSVGElement;
    268463end;
    269464
    270465function CreateSVGElementFromNode(ADocument: TXMLDocument;
    271   AElement: TDOMElement; AUnits: TCSSUnitConverter): TSVGElement;
     466  AElement: TDOMElement; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink; ADataParent: TSVGElement): TSVGElement;
    272467var
    273468  factory: TSVGFactory;
    274469begin
    275470  factory := GetSVGFactory(AElement.TagName);
    276   result := factory.Create(ADocument,AElement,AUnits);
    277 end;
     471  result := factory.Create(ADocument,AElement,AUnits,ADataLink);
     472 
     473  ADataLink.Link(result,ADataParent);
     474end;
     475
     476{ TSVGElementWithGradient }
     477
     478procedure TSVGElementWithGradient.Initialize;
     479begin
     480  inherited Initialize;
     481  ResetGradient;
     482end;
     483
     484procedure TSVGElementWithGradient.ResetGradient;
     485begin
     486  FGradientElementDefined := false;
     487  FGradientElement        := nil;
     488  FCanvasGradient         := nil;
     489end;
     490
     491function TSVGElementWithGradient.FindGradientElement: boolean;
     492var
     493  i: integer;
     494  s: string;
     495begin
     496  Result:= false;
     497  s:= fill;
     498  if s <> '' then
     499    if Pos('url(#',s) = 1 then
     500    begin
     501      s:= System.Copy(s,6,Length(s)-6);
     502      with FDataLink do
     503        for i:= GradientCount-1 downto 0 do
     504          if (Gradients[i] as TSVGGradient).ID = s then
     505          begin
     506            FGradientElement:= TSVGGradient(Gradients[i]);
     507            Result:= true;
     508            Exit;
     509          end;
     510    end;
     511end;
     512
     513function TSVGElementWithGradient.EvaluatePercentage(fu: TFloatWithCSSUnit): single;
     514begin
     515  Result:= fu.value;
     516  if fu.CSSUnit <> cuPercent then
     517  begin
     518    if Result < 0 then
     519      Result:= 0
     520    else if Result > 1 then
     521      Result:= 1;
     522    Result:= Result * 100;
     523  end;
     524end;
     525
     526function TSVGElementWithGradient.GetGradientElement: TSVGGradient;
     527begin
     528  if not FGradientElementDefined then
     529  begin
     530    FindGradientElement;
     531    FGradientElementDefined:= true;
     532    if FGradientElement <> nil then
     533      FGradientElement.ScanInheritedGradients;
     534  end;
     535  result := FGradientElement;
     536end;
     537
     538procedure TSVGElementWithGradient.AddStopElements(canvas: IBGRACanvasGradient2D);
     539
     540  function AddStopElementFrom(el: TSVGElement): integer;
     541  var
     542    i: integer;
     543    col: TBGRAPixel;
     544  begin
     545    result:= 0;
     546    with el.DataChildList do
     547      for i:= 0 to Count-1 do
     548        if Items[i] is TSVGStopGradient then
     549          with (Items[i] as TSVGStopGradient) do
     550          begin
     551            col:= StrToBGRA( AttributeOrStyleDef['stop-color','black'] );
     552            col.alpha:= Round( Units.parseValue(AttributeOrStyleDef['stop-opacity','1'],1) * col.alpha );
     553            canvas.addColorStop(EvaluatePercentage(offset)/100, col);
     554            Inc(result);
     555          end;
     556  end;
     557
     558var
     559  i: integer;
     560begin
     561  if not Assigned(GradientElement) then exit;
     562  with GradientElement.InheritedGradients do
     563    for i:= 0 to Count-1 do
     564      AddStopElementFrom(Items[i]);
     565end;
     566
     567procedure TSVGElementWithGradient.CreateCanvasLinearGradient(
     568  ACanvas2d: TBGRACanvas2D; ASVGGradient: TSVGGradient;
     569  const origin: TPointF; const w,h: single; AUnit: TCSSUnit);
     570var p1,p2: TPointF;
     571  g: TSVGLinearGradient;
     572  m: TAffineMatrix;
     573begin
     574  g := ASVGGradient as TSVGLinearGradient;
     575  if g.useObjectBoundingBox then
     576  begin
     577    p1.x:= EvaluatePercentage(g.x1)/100;
     578    p1.y:= EvaluatePercentage(g.y1)/100;
     579    p2.x:= EvaluatePercentage(g.x2)/100;
     580    p2.y:= EvaluatePercentage(g.y2)/100;
     581    m := ACanvas2d.matrix;
     582    ACanvas2d.translate(origin.x,origin.y);
     583    ACanvas2d.scale(w,h);
     584    ACanvas2d.transform(g.gradientMatrix[cuCustom]);
     585    FCanvasGradient:= ACanvas2d.createLinearGradient(p1,p2);
     586    ACanvas2d.matrix := m;
     587  end else
     588  begin
     589    p1.x:= Units.ConvertWidth(g.x1,AUnit,w).value;
     590    p1.y:= Units.ConvertHeight(g.y1,AUnit,h).value;
     591    p2.x:= Units.ConvertWidth(g.x1,AUnit,w).value;
     592    p2.y:= Units.ConvertHeight(g.y1,AUnit,h).value;
     593    m := ACanvas2d.matrix;
     594    ACanvas2d.transform(g.gradientMatrix[AUnit]);
     595    FCanvasGradient:= ACanvas2d.createLinearGradient(p1,p2);
     596    ACanvas2d.matrix := m;
     597  end;
     598
     599  AddStopElements(FCanvasGradient);
     600end;
     601
     602procedure TSVGElementWithGradient.CreateCanvasRadialGradient(
     603  ACanvas2d: TBGRACanvas2D; ASVGGradient: TSVGGradient; const origin: TPointF;
     604  const w, h: single; AUnit: TCSSUnit);
     605var c,f: TPointF;
     606  r,fr: single;
     607  g: TSVGRadialGradient;
     608  m: TAffineMatrix;
     609
     610  procedure CheckFocalAndCreate(c: TPointF; r: single; f: TPointF; fr: single);
     611  var u: TPointF;
     612    d: single;
     613  begin
     614    u := f-c;
     615    d := VectLen(u);
     616    if d >= r then
     617    begin
     618      u *= (r/d)*0.99999;
     619      f := c+u;
     620    end;
     621    FCanvasGradient:= ACanvas2d.createRadialGradient(c,r,f,fr,true);
     622    AddStopElements(FCanvasGradient);
     623  end;
     624
     625begin
     626  g := ASVGGradient as TSVGRadialGradient;
     627  if g.useObjectBoundingBox then
     628  begin
     629    c.x:= EvaluatePercentage(g.cx)/100;
     630    c.y:= EvaluatePercentage(g.cy)/100;
     631    r:= abs(EvaluatePercentage(g.r))/100;
     632    f.x:= EvaluatePercentage(g.fx)/100;
     633    f.y:= EvaluatePercentage(g.fy)/100;
     634    fr:= abs(EvaluatePercentage(g.fr))/100;
     635
     636    m := ACanvas2d.matrix;
     637    ACanvas2d.translate(origin.x,origin.y);
     638    ACanvas2d.scale(w,h);
     639    ACanvas2d.transform(g.gradientMatrix[cuCustom]);
     640    CheckFocalAndCreate(c,r,f,fr);
     641    ACanvas2d.matrix := m;
     642  end else
     643  begin
     644    c.x:= Units.ConvertWidth(g.cx,AUnit,w).value;
     645    c.y:= Units.ConvertHeight(g.cy,AUnit,h).value;
     646    r:= abs(Units.ConvertWidth(g.r,AUnit,w).value);
     647    f.x:= Units.ConvertWidth(g.fx,AUnit,w).value;
     648    f.y:= Units.ConvertHeight(g.fy,AUnit,h).value;
     649    fr:= abs(Units.ConvertWidth(g.fr,AUnit,w).value);
     650
     651    m := ACanvas2d.matrix;
     652    ACanvas2d.transform(g.gradientMatrix[AUnit]);
     653    CheckFocalAndCreate(c,r,f,fr);
     654    ACanvas2d.matrix := m;
     655  end;
     656end;
     657
     658procedure TSVGElementWithGradient.InitializeGradient(ACanvas2d: TBGRACanvas2D;
     659  const origin: TPointF; const w,h: single; AUnit: TCSSUnit);
     660begin
     661  if GradientElement <> nil then
     662  begin
     663    if GradientElement is TSVGLinearGradient then
     664      CreateCanvasLinearGradient(ACanvas2d, GradientElement, origin, w,h, AUnit)
     665    else
     666    if GradientElement is TSVGRadialGradient then
     667      CreateCanvasRadialGradient(ACanvas2d, GradientElement, origin, w,h, AUnit);
     668  end;
     669end;
     670
     671procedure TSVGElementWithGradient.ApplyFillStyle(ACanvas2D: TBGRACanvas2D; AUnit: TCSSUnit);
     672begin
     673  if FCanvasGradient = nil then
     674    inherited ApplyFillStyle(ACanvas2D,AUnit)
     675  else
     676  begin
     677    ACanvas2D.fillStyle(FCanvasGradient);
     678    ACanvas2D.fillMode:= TFillMode(fillMode);
     679  end;
     680end; 
    278681
    279682{ TSVGText }
     
    290693function TSVGText.GetFontFamily: string;
    291694begin
    292   result := AttributeOrStyle['font-family'];
    293   if result = '' then result := 'Arial';
     695  result := AttributeOrStyleDef['font-family','Arial'];
    294696end;
    295697
     
    303705function TSVGText.GetFontSize: TFloatWithCSSUnit;
    304706begin
    305   if AttributeOrStyle['font-size']='' then
    306     result := FloatWithCSSUnit(12,cuPoint)
    307   else
    308     result := VerticalAttributeOrStyleWithUnit['font-size'];
     707  result:= VerticalAttributeOrStyleWithUnit['font-size',FloatWithCSSUnit(12,cuPoint)];
    309708end;
    310709
    311710function TSVGText.GetFontStyle: string;
    312711begin
    313   result := AttributeOrStyle['font-style'];
    314   if result = '' then result := 'normal';
     712  result := AttributeOrStyleDef['font-style','normal'];
    315713end;
    316714
    317715function TSVGText.GetFontWeight: string;
    318716begin
    319   result := AttributeOrStyle['font-weight'];
    320   if result = '' then result := 'normal';
     717  result := AttributeOrStyleDef['font-weight','normal'];
    321718end;
    322719
     
    328725function TSVGText.GetTextDecoration: string;
    329726begin
    330   result := AttributeOrStyle['text-decoration'];
    331   if result='' then result := 'none';
     727  result := AttributeOrStyleDef['text-decoration','none'];
    332728end;
    333729
     
    397793
    398794procedure TSVGText.InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit);
    399 var fs:TFontStyles;
     795var
     796  fs:TFontStyles;
     797  vx,vy: single;
    400798begin
    401799  ACanvas2d.beginPath;
    402   ACanvas2d.fontEmHeight := Units.ConvertWidth(fontSize,AUnit).value;
     800  ACanvas2d.fontEmHeight := Units.ConvertHeight(fontSize,AUnit).value;
    403801  ACanvas2d.fontName := fontFamily;
    404802  fs := [];
     
    406804  if fontItalic then fs += [fsItalic];
    407805  ACanvas2d.fontStyle := fs;
    408   ACanvas2d.text(SimpleText,Units.ConvertWidth(x,AUnit).value,Units.ConvertWidth(y,AUnit).value);
     806  vx:= Units.ConvertWidth(x,AUnit).value;
     807  vy:= Units.ConvertHeight(y,AUnit).value;
     808  ACanvas2d.text(SimpleText,vx,vy);
     809
     810  if Assigned(GradientElement) then
     811    with ACanvas2d.measureText(SimpleText) do
     812      InitializeGradient(ACanvas2d, PointF(vx,vy),width,height,AUnit);
     813             
    409814  if not isFillNone then
    410815  begin
    411     ACanvas2d.fillStyle(fillColor);
     816    ApplyFillStyle(ACanvas2D,AUnit);
    412817    ACanvas2d.fill;
    413818  end;
     
    419824end;
    420825
    421 constructor TSVGText.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter);
    422 begin
     826constructor TSVGText.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink);
     827begin
     828  inherited Create(ADocument, AUnits, ADataLink);
    423829  Init(ADocument,'text',AUnits);
    424830end;
     
    426832{ TSVGGroup }
    427833
    428 constructor TSVGGroup.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter);
    429 begin
    430   inherited Create(ADocument, AUnits);
    431   FContent := TSVGContent.Create(ADocument,FDomElem,AUnits);
     834constructor TSVGGroup.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink);
     835begin
     836  inherited Create(ADocument, AUnits, ADataLink);
     837  FContent := TSVGContent.Create(ADocument,FDomElem,AUnits,ADataLink,Self);
    432838end;
    433839
    434840constructor TSVGGroup.Create(ADocument: TXMLDocument; AElement: TDOMElement;
    435   AUnits: TCSSUnitConverter);
    436 begin
    437   inherited Create(ADocument, AElement, AUnits);
    438   FContent := TSVGContent.Create(ADocument,AElement,AUnits);
     841  AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink);
     842begin
     843  inherited Create(ADocument, AElement, AUnits, ADataLink);
     844  FContent := TSVGContent.Create(ADocument,AElement,AUnits,ADataLink,Self);
    439845end;
    440846
     
    450856end;
    451857
     858procedure TSVGGroup.Recompute;
     859begin
     860  inherited Recompute;
     861  FContent.Recompute;
     862end;
     863
     864{ TSVGStyle } 
     865
     866constructor TSVGStyle.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink);
     867begin
     868  inherited Create(ADocument, AUnits, ADataLink);
     869  Init(ADocument,'style',AUnits);
     870end;
     871
     872constructor TSVGStyle.Create(ADocument: TXMLDocument; AElement: TDOMElement;
     873  AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink);
     874begin
     875  inherited Create(ADocument, AElement, AUnits, ADataLink);
     876  Parse(AElement.TextContent);
     877end;
     878
     879procedure TSVGStyle.Initialize;
     880begin
     881  inherited Initialize;
     882  Clear;
     883end;
     884
     885destructor TSVGStyle.Destroy;
     886begin
     887  Clear;
     888  inherited Destroy;
     889end;
     890
     891procedure TSVGStyle.Parse(const s: String);
     892
     893  function IsValidAttribute(const sa: string): boolean;
     894  var
     895    i: integer;
     896  begin
     897    //(for case example "{ ; ;}")
     898    for i:= 1 to Length(sa) do
     899     if not (sa[i] in [' ',';']) then
     900      exit(true);
     901    result:= false;
     902  end;
     903
     904const
     905  EmptyRec: TSVGStyleItem = (name: ''; attribute: '');
     906var
     907  i,l,pg: integer;
     908  st: String;
     909  rec: TSVGStyleItem;
     910begin
     911  (*
     912    Example of internal style block
     913    circle {..}         
     914    circle.type1 {..}   
     915    .pic1 {..}         
     916  *)
     917  Clear;
     918  l:= 0;
     919  pg:= 0;
     920  st:= '';
     921  rec:= EmptyRec;
     922  for i:= 1 to Length(s) do
     923  begin
     924    if s[i] = '{' then
     925    begin
     926      Inc(pg);
     927      if (pg = 1) and (Length(st) <> 0) then
     928      begin
     929       rec.name:= Trim(st);
     930       st:= '';
     931      end;
     932    end
     933    else if s[i] = '}' then
     934    begin
     935      Dec(pg);
     936      if (pg = 0) and (Length(st) <> 0) then
     937      begin
     938        if IsValidAttribute(st) then
     939        begin
     940          rec.attribute:= Trim(st);
     941          Inc(l);
     942          SetLength(FStyles,l);
     943          FStyles[l-1]:= rec;
     944          rec:= EmptyRec;
     945        end;
     946        st:= '';
     947      end;
     948    end
     949    else
     950      st:= st + s[i];
     951  end;
     952end;
     953
     954function TSVGStyle.IsValidID(const sid: integer): boolean;
     955begin
     956  result:= (sid >= 0) and (sid < Length(FStyles));
     957end;
     958
     959function TSVGStyle.GetStyle(const sid: integer): TSVGStyleItem;
     960begin
     961  if IsValidID(sid) then
     962    result:= FStyles[sid]
     963  else
     964    raise exception.Create(rsInvalidId);
     965end;
     966
     967procedure TSVGStyle.SetStyle(const sid: integer; sr: TSVGStyleItem);
     968begin
     969  if IsValidID(sid) then
     970    FStyles[sid]:= sr
     971  else
     972    raise exception.Create(rsInvalidId);
     973end;
     974
     975function TSVGStyle.Count: Integer;
     976begin
     977  result:= Length(FStyles);
     978end;
     979
     980function TSVGStyle.Find(sr: TSVGStyleItem): integer;
     981var
     982  i: integer;
     983begin
     984  for i:= 0 to Length(FStyles)-1 do
     985    with FStyles[i] do
     986      if (name = sr.name) and
     987         (attribute = sr.attribute) then
     988      begin
     989        result:= i;
     990        Exit;
     991      end;
     992  result:= -1;
     993end;
     994
     995function TSVGStyle.Find(const AName: string): integer;
     996var
     997  i: integer;
     998begin
     999  for i:= 0 to Length(FStyles)-1 do
     1000    with FStyles[i] do
     1001      if name = AName then
     1002      begin
     1003        result:= i;
     1004        Exit;
     1005      end;
     1006  result:= -1;
     1007end;
     1008
     1009function TSVGStyle.Add(sr: TSVGStyleItem): integer;
     1010var
     1011  l: integer;
     1012begin
     1013  l:= Length(FStyles);
     1014  SetLength(FStyles,l+1);
     1015  FStyles[l]:= sr;
     1016  result:= l;
     1017end;
     1018
     1019procedure TSVGStyle.Remove(sr: TSVGStyleItem);
     1020var
     1021  l,p: integer;
     1022begin
     1023  p:= Find(sr);
     1024  l:= Length(FStyles);
     1025  if p <> -1 then
     1026  begin
     1027    Finalize(FStyles[p]);
     1028    System.Move(FStyles[p+1], FStyles[p], (l-p)*SizeOf(TSVGStyleItem));
     1029    SetLength(FStyles,l-1);
     1030  end;
     1031end;
     1032
     1033procedure TSVGStyle.Clear;
     1034begin
     1035  SetLength(FStyles,0);
     1036end;
     1037
     1038procedure TSVGStyle.ReParse;
     1039begin
     1040 Parse(FDomElem.TextContent);
     1041end;           
     1042
    4521043{ TSVGRectangle }
    4531044
     
    5131104
    5141105constructor TSVGRectangle.Create(ADocument: TXMLDocument;
    515   AUnits: TCSSUnitConverter);
    516 begin
     1106  AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink);
     1107begin
     1108  inherited Create(ADocument, AUnits, ADataLink);
    5171109  Init(ADocument,'rect',AUnits);
    5181110end;
    5191111
    5201112procedure TSVGRectangle.InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit);
     1113var
     1114  vx,vy,vw,vh: Single;
    5211115begin
    5221116  if not isStrokeNone or not isFillNone then
    5231117  begin
     1118    vx:= Units.ConvertWidth(x,AUnit).value;
     1119    vy:= Units.ConvertHeight(y,AUnit).value;
     1120    vw:= Units.ConvertWidth(width,AUnit).value;
     1121    vh:= Units.ConvertHeight(height,AUnit).value;
    5241122    ACanvas2d.beginPath;
    525     ACanvas2d.roundRect(Units.ConvertWidth(x,AUnit).value,Units.ConvertWidth(y,AUnit).value,
    526        Units.ConvertWidth(width,AUnit).value,Units.ConvertWidth(height,AUnit).value,
    527        Units.ConvertWidth(rx,AUnit).value,Units.ConvertWidth(ry,AUnit).value);
     1123    ACanvas2d.roundRect(vx,vy, vw,vh,
     1124       Units.ConvertWidth(rx,AUnit).value,Units.ConvertHeight(ry,AUnit).value);
     1125    if Assigned(GradientElement) then
     1126      InitializeGradient(ACanvas2d, PointF(vx,vy),vw,vh,AUnit);
    5281127    if not isFillNone then
    5291128    begin
    530       ACanvas2d.fillStyle(fillColor);
     1129      ApplyFillStyle(ACanvas2D,AUnit);
    5311130      ACanvas2d.fill;
    5321131    end;
     
    5441143begin
    5451144  result := FDomElem.TagName = 'polygon';
     1145end;
     1146
     1147function TSVGPolypoints.GetBoundingBoxF: TRectF;
     1148begin
     1149  if not FBoundingBoxComputed then
     1150    ComputeBoundingBox(pointsF);
     1151  result := FBoundingBox;
    5461152end;
    5471153
     
    5701176    result[i].y := parser.ParseFloat;
    5711177  end;
     1178  parser.Free;
    5721179end;
    5731180
     
    5891196  end;
    5901197  points := s;
     1198  ComputeBoundingBox(AValue);
     1199end;
     1200
     1201procedure TSVGPolypoints.ComputeBoundingBox(APoints: ArrayOfTPointF);
     1202var
     1203  i: Integer;
     1204begin
     1205  if length(APoints) > 1 then
     1206  begin
     1207    with APoints[0] do
     1208      FBoundingBox:= RectF(x,y,x,y);
     1209    for i:= 1 to high(APoints) do
     1210      with APoints[i] do
     1211      begin
     1212        if x < FBoundingBox.Left then
     1213         FBoundingBox.Left:= x
     1214        else if x > FBoundingBox.Right then
     1215         FBoundingBox.Right:= x;
     1216        if y < FBoundingBox.Top then
     1217         FBoundingBox.Top:= y
     1218        else if y > FBoundingBox.Bottom then
     1219         FBoundingBox.Bottom:= y;
     1220      end;
     1221    FBoundingBoxComputed := true;
     1222  end else
     1223  begin
     1224    FBoundingBox := RectF(0,0,0,0);
     1225    FBoundingBoxComputed := true;
     1226  end;
    5911227end;
    5921228
    5931229constructor TSVGPolypoints.Create(ADocument: TXMLDocument;
    594   AUnits: TCSSUnitConverter; AClosed: boolean);
    595 begin
     1230  AUnits: TCSSUnitConverter; AClosed: boolean; ADataLink: TSVGDataLink);
     1231begin
     1232  inherited Create(ADocument, AUnits, ADataLink);
    5961233  if AClosed then
    5971234    Init(ADocument, 'polygon', AUnits)
     
    6081245var
    6091246  prevMatrix: TAffineMatrix;
     1247  pts: ArrayOfTPointF;
    6101248begin
    6111249  if isFillNone and isStrokeNone then exit;
     
    6201258  begin
    6211259    ACanvas2d.beginPath;
    622     ACanvas2d.polylineTo(pointsF);
     1260    pts := pointsF;
     1261    ACanvas2d.polylineTo(pts);
    6231262    if closed then ACanvas2d.closePath;
     1263   
     1264    with boundingBoxF do
     1265      InitializeGradient(ACanvas2d,
     1266        PointF(Left,Top),abs(Right-Left),abs(Bottom-Top),AUnit);
     1267   
    6241268    if not isFillNone then
    6251269    begin
    626       ACanvas2d.fillStyle(fillColor);
     1270      ApplyFillStyle(ACanvas2D,AUnit);
    6271271      ACanvas2d.fill;
    6281272    end;
     
    6491293end;
    6501294
     1295function TSVGPath.GetBoundingBoxF: TRectF;
     1296begin
     1297  if not FBoundingBoxComputed then
     1298  begin
     1299    FBoundingBox := path.GetBounds;
     1300    FBoundingBoxComputed := true;
     1301  end;
     1302  result := FBoundingBox;
     1303end;
     1304
    6511305function TSVGPath.GetData: string;
    6521306begin
     
    6681322  else
    6691323    FPath.SvgString := AValue;
     1324  FBoundingBoxComputed := false;
    6701325end;
    6711326
     
    6761331end;
    6771332
    678 constructor TSVGPath.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter);
    679 begin
     1333constructor TSVGPath.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink);
     1334begin
     1335  inherited Create(ADocument, AUnits, ADataLink);
    6801336  Init(ADocument,'path',AUnits);
    6811337  FPath := nil;
     1338  FBoundingBoxComputed := false;
     1339  FBoundingBox := rectF(0,0,0,0);
    6821340end;
    6831341
    6841342constructor TSVGPath.Create(ADocument: TXMLDocument; AElement: TDOMElement;
    685   AUnits: TCSSUnitConverter);
    686 begin
     1343  AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink);
     1344begin
     1345  inherited Create(ADocument, AElement, AUnits, ADataLink);
    6871346  Init(ADocument, AElement, AUnits);
    6881347  FPath := nil;
     1348  FBoundingBoxComputed := false;
     1349  FBoundingBox := rectF(0,0,0,0);
    6891350end;
    6901351
     
    7101371  begin
    7111372    ACanvas2d.path(path);
     1373    if Assigned(GradientElement) then
     1374      with boundingBoxF do
     1375        InitializeGradient(ACanvas2d,
     1376          PointF(Left,Top),abs(Right-Left),abs(Bottom-Top),AUnit);
    7121377    if not isFillNone then
    7131378    begin
    714       ACanvas2d.fillStyle(fillColor);
     1379      ApplyFillStyle(ACanvas2D,AUnit);
    7151380      ACanvas2d.fill;
    7161381    end;
     
    7661431
    7671432constructor TSVGEllipse.Create(ADocument: TXMLDocument;
    768   AUnits: TCSSUnitConverter);
    769 begin
     1433  AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink);
     1434begin
     1435  inherited Create(ADocument, AUnits, ADataLink);
    7701436  Init(ADocument,'ellipse',AUnits);
    7711437end;
    7721438
    7731439procedure TSVGEllipse.InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit);
     1440var
     1441  vcx,vcy,vrx,vry: Single;
    7741442begin
    7751443  if not isFillNone or not isStrokeNone then
    7761444  begin
     1445    vcx:= Units.ConvertWidth(cx,AUnit).value;
     1446    vcy:= Units.ConvertHeight(cy,AUnit).value;
     1447    vrx:= Units.ConvertWidth(rx,AUnit).value;
     1448    vry:= Units.ConvertHeight(ry,AUnit).value;
    7771449    ACanvas2d.beginPath;
    778     ACanvas2d.ellipse(Units.ConvertWidth(cx,AUnit).value,Units.ConvertWidth(cy,AUnit).value,
    779          Units.ConvertWidth(rx,AUnit).value,Units.ConvertWidth(ry,AUnit).value);
     1450    ACanvas2d.ellipse(vcx,vcy,vrx,vry);
     1451    if Assigned(GradientElement) then
     1452      InitializeGradient(ACanvas2d, PointF(vcx-vrx,vcy-vry),vrx*2,vry*2,AUnit);     
    7801453    if not isFillNone then
    7811454    begin
    782       ACanvas2d.fillStyle(fillColor);
     1455      ApplyFillStyle(ACanvas2D,AUnit);
    7831456      ACanvas2d.fill;
    7841457    end;
     
    8231496end;
    8241497
    825 constructor TSVGCircle.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter);
    826 begin
     1498constructor TSVGCircle.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink);
     1499begin
     1500  inherited Create(ADocument, AUnits, ADataLink);
    8271501  Init(ADocument,'circle',AUnits);
    8281502end;
    8291503
    8301504procedure TSVGCircle.InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit);
     1505var
     1506  vcx,vcy,vr: Single;
    8311507begin
    8321508  if not isFillNone or not isStrokeNone then
    8331509  begin
     1510    vcx:= Units.ConvertWidth(cx,AUnit).value;
     1511    vcy:= Units.ConvertHeight(cy,AUnit).value;
     1512    vr:= Units.ConvertWidth(r,AUnit).value;
    8341513    ACanvas2d.beginPath;
    835     ACanvas2d.circle(Units.ConvertWidth(cx,AUnit).value,Units.ConvertWidth(cy,AUnit).value,
    836          Units.ConvertWidth(r,AUnit).value);
     1514    ACanvas2d.circle(vcx,vcy,vr);
     1515    if Assigned(GradientElement) then
     1516      InitializeGradient(ACanvas2d, PointF(vcx-vr,vcy-vr),vr*2,vr*2,AUnit);
    8371517    if not isFillNone then
    8381518    begin
    839       ACanvas2d.fillStyle(fillColor);
     1519      ApplyFillStyle(ACanvas2D,AUnit);
    8401520      ACanvas2d.fill;
    8411521    end;
     
    8901570end;
    8911571
    892 constructor TSVGLine.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter);
    893 begin
     1572constructor TSVGLine.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink);
     1573begin
     1574  inherited Create(ADocument, AUnits, ADataLink);
    8941575  Init(ADocument,'line',AUnits);
    8951576end;
     
    9011582    ApplyStrokeStyle(ACanvas2D,AUnit);
    9021583    ACanvas2d.beginPath;
    903     ACanvas2d.moveTo(Units.ConvertWidth(x1,AUnit).value,Units.ConvertWidth(y1,AUnit).value);
    904     ACanvas2d.lineTo(Units.ConvertWidth(x2,AUnit).value,Units.ConvertWidth(y2,AUnit).value);
     1584    ACanvas2d.moveTo(Units.ConvertWidth(x1,AUnit).value,Units.ConvertHeight(y1,AUnit).value);
     1585    ACanvas2d.lineTo(Units.ConvertWidth(x2,AUnit).value,Units.ConvertHeight(y2,AUnit).value);
    9051586    ACanvas2d.stroke;
    9061587  end;
     1588end;
     1589
     1590{ TSVGGradient } //##
     1591
     1592function TSVGGradient.GetHRef: string;
     1593begin
     1594  result := Attribute['xlink:href'];
     1595  if result = '' then
     1596    result := Attribute['href'];//(Note: specific for svg 2)
     1597end;
     1598
     1599function TSVGGradient.GetUseObjectBoundingBox: boolean;
     1600begin
     1601  result := (gradientUnits = 'objectBoundingBox');
     1602end;
     1603
     1604procedure TSVGGradient.SetGradientTransform(AValue: string);
     1605begin
     1606  Attribute['gradientTransform'] := AValue;
     1607end;
     1608
     1609function TSVGGradient.GetGradientUnits: string;
     1610begin
     1611  result := AttributeDef['gradientUnits','objectBoundingBox'];
     1612end;
     1613
     1614function TSVGGradient.GetGradientTransform: string;
     1615begin
     1616  result := Attribute['gradientTransform'];
     1617end;
     1618
     1619function TSVGGradient.GetGradientMatrix(AUnit: TCSSUnit): TAffineMatrix;
     1620var parser: TSVGParser;
     1621  s: string;
     1622begin
     1623  s := gradientTransform;
     1624  if s = '' then
     1625  begin
     1626    result := AffineMatrixIdentity;
     1627    exit;
     1628  end;
     1629  parser := TSVGParser.Create(s);
     1630  result := parser.ParseTransform;
     1631  parser.Free;
     1632  result[1,3] := Units.ConvertWidth(result[1,3],cuCustom,AUnit);
     1633  result[2,3] := Units.ConvertHeight(result[2,3],cuCustom,AUnit);
     1634end;
     1635
     1636procedure TSVGGradient.SetGradientUnits(AValue: string);
     1637begin
     1638  Attribute['gradientUnits'] := AValue;
     1639end;
     1640
     1641procedure TSVGGradient.SetHRef(AValue: string);
     1642begin
     1643  Attribute['xlink:href'] := AValue;
     1644end;
     1645
     1646constructor TSVGGradient.Create(ADocument: TXMLDocument;
     1647  AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink);
     1648begin
     1649  inherited Create(ADocument, AUnits, ADataLink);
     1650  FContent := TSVGContent.Create(ADocument,FDomElem,AUnits,ADataLink,Self);
     1651end;
     1652
     1653function TSVGGradient.HRefToGradientID(const AValue: string): string;
     1654var
     1655  l: integer;
     1656begin
     1657  //(example input: "#gradient1")
     1658  l:= Length(AValue);
     1659  if l < 2 then
     1660    result:= ''
     1661  else
     1662    result:= System.Copy(AValue,2,l-1);
     1663end;
     1664
     1665function TSVGGradient.FindGradientRef(const AGradientID: string): integer;
     1666var
     1667  i: integer;
     1668begin
     1669  with FDataLink do
     1670    for i:= 0 to GradientCount-1 do
     1671      if (Gradients[i] as TSVGGradient).ID = AGradientID then
     1672      begin
     1673        result:= i;
     1674        exit;
     1675      end;
     1676  result:= -1;
     1677end;
     1678
     1679procedure TSVGGradient.Initialize;
     1680begin
     1681  inherited;
     1682  InheritedGradients:= TSVGElementList.Create;
     1683end;
     1684
     1685function TSVGGradient.GetInheritedAttribute(AValue: string;
     1686  AConvMethod: TConvMethod; ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit;
     1687var
     1688  i: integer;
     1689  el: TSVGGradient;
     1690  invalidDef: TFloatWithCSSUnit;
     1691begin
     1692  invalidDef:= FloatWithCSSUnit(EmptySingle,cuPercent);
     1693  //find valid inherited attribute (start from "self": item[0])
     1694  for i:= 0 to InheritedGradients.Count-1 do
     1695  begin
     1696    el:= TSVGGradient( InheritedGradients[i] );
     1697    with el do
     1698    begin
     1699      if AConvMethod = cmHoriz then
     1700        result:= HorizAttributeWithUnitDef[AValue,invalidDef]
     1701      else if AConvMethod = cmVertical then
     1702        result:= VerticalAttributeWithUnitDef[AValue,invalidDef]
     1703      else if AConvMethod = cmOrtho then
     1704        result:= OrthoAttributeWithUnitDef[AValue,invalidDef]
     1705      else
     1706        result:= AttributeWithUnitDef[AValue,invalidDef];
     1707
     1708      if (result.value <> invalidDef.value) or
     1709         (result.CSSUnit <> invalidDef.CSSUnit) then
     1710        exit;
     1711    end;
     1712  end;
     1713  result:= ADefault;
     1714end;
     1715
     1716constructor TSVGGradient.Create(ADocument: TXMLDocument; AElement: TDOMElement;
     1717  AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink);
     1718begin
     1719  inherited Create(ADocument, AElement, AUnits, ADataLink);
     1720  FContent := TSVGContent.Create(ADocument,AElement,AUnits,ADataLink,Self);
     1721end;
     1722
     1723destructor TSVGGradient.Destroy;
     1724begin
     1725  FreeAndNil(FContent);
     1726  FreeAndNil(InheritedGradients);
     1727  inherited Destroy;
     1728end;
     1729
     1730procedure TSVGGradient.Recompute;
     1731begin
     1732  inherited Recompute;
     1733  FContent.Recompute;
     1734end;
     1735
     1736procedure TSVGGradient.ScanInheritedGradients(const forceScan: boolean = false);
     1737var
     1738  el: TSVGGradient;
     1739  pos: integer;
     1740  gradientID: string;
     1741begin
     1742  //(if list empty = not scan)
     1743  if (InheritedGradients.Count <> 0) and (not forceScan) then
     1744    exit;
     1745
     1746  InheritedGradients.Clear;
     1747  InheritedGradients.Add(Self);//(important)
     1748  el:= Self;
     1749  while el.hRef <> '' do
     1750  begin
     1751    gradientID:= HRefToGradientID(el.hRef);
     1752    pos:= FindGradientRef(gradientID);
     1753    if pos = -1 then
     1754      exit
     1755    else
     1756    begin
     1757      el:= TSVGGradient(FDataLink.Gradients[pos]);
     1758      InheritedGradients.Add(el);
     1759    end;
     1760  end;
     1761end;       
     1762
     1763{ TSVGLinearGradient }
     1764
     1765function TSVGLinearGradient.GetX1: TFloatWithCSSUnit;
     1766begin
     1767  result := GetInheritedAttribute('x1',cmNone,FloatWithCSSUnit(0,cuPercent));
     1768end;
     1769
     1770function TSVGLinearGradient.GetX2: TFloatWithCSSUnit;
     1771begin
     1772  result := GetInheritedAttribute('x2',cmNone,FloatWithCSSUnit(100,cuPercent));
     1773end;
     1774
     1775function TSVGLinearGradient.GetY1: TFloatWithCSSUnit;
     1776begin
     1777  result := GetInheritedAttribute('y1',cmNone,FloatWithCSSUnit(0,cuPercent));
     1778end;
     1779
     1780function TSVGLinearGradient.GetY2: TFloatWithCSSUnit;
     1781begin
     1782  result := GetInheritedAttribute('y2',cmNone,FloatWithCSSUnit(0,cuPercent));
     1783end;
     1784
     1785procedure TSVGLinearGradient.SetX1(AValue: TFloatWithCSSUnit);
     1786begin
     1787  AttributeWithUnit['x1']:= AValue;
     1788end;
     1789
     1790procedure TSVGLinearGradient.SetX2(AValue: TFloatWithCSSUnit);
     1791begin
     1792  AttributeWithUnit['x2']:= AValue;
     1793end;
     1794
     1795procedure TSVGLinearGradient.SetY1(AValue: TFloatWithCSSUnit);
     1796begin
     1797  AttributeWithUnit['y1']:= AValue;
     1798end;
     1799
     1800procedure TSVGLinearGradient.SetY2(AValue: TFloatWithCSSUnit);
     1801begin
     1802  AttributeWithUnit['y2']:= AValue;
     1803end;
     1804
     1805constructor TSVGLinearGradient.Create(ADocument: TXMLDocument;
     1806  AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink);
     1807begin
     1808  inherited Create(ADocument, AUnits, ADataLink);
     1809  Init(ADocument,'linearGradient',AUnits);
     1810end;
     1811
     1812{ TSVGRadialGradient }
     1813
     1814function TSVGRadialGradient.GetCX: TFloatWithCSSUnit;
     1815begin
     1816  result := GetInheritedAttribute('cx',cmHoriz,FloatWithCSSUnit(50,cuPercent));
     1817end;
     1818
     1819function TSVGRadialGradient.GetCY: TFloatWithCSSUnit;
     1820begin
     1821  result := GetInheritedAttribute('cy',cmVertical,FloatWithCSSUnit(50,cuPercent));
     1822end;
     1823
     1824function TSVGRadialGradient.GetR: TFloatWithCSSUnit;
     1825begin
     1826  result := GetInheritedAttribute('r',cmOrtho,FloatWithCSSUnit(50,cuPercent));
     1827end;
     1828
     1829function TSVGRadialGradient.GetFX: TFloatWithCSSUnit;
     1830begin
     1831  result := GetInheritedAttribute('fx',cmHoriz,cx);
     1832end;
     1833
     1834function TSVGRadialGradient.GetFY: TFloatWithCSSUnit;
     1835begin
     1836  result := GetInheritedAttribute('fy',cmVertical,cy);
     1837end;         
     1838
     1839function TSVGRadialGradient.GetFR: TFloatWithCSSUnit;
     1840begin
     1841  result := GetInheritedAttribute('fr',cmHoriz,FloatWithCSSUnit(0,cuPercent));
     1842end;
     1843
     1844procedure TSVGRadialGradient.SetCX(AValue: TFloatWithCSSUnit);
     1845begin
     1846  HorizAttributeWithUnit['cx'] := AValue;
     1847end;
     1848
     1849procedure TSVGRadialGradient.SetCY(AValue: TFloatWithCSSUnit);
     1850begin
     1851  VerticalAttributeWithUnit['cy'] := AValue;
     1852end;
     1853
     1854procedure TSVGRadialGradient.SetR(AValue: TFloatWithCSSUnit);
     1855begin
     1856  OrthoAttributeWithUnit['r'] := AValue;
     1857end;
     1858
     1859procedure TSVGRadialGradient.SetFX(AValue: TFloatWithCSSUnit);
     1860begin
     1861  HorizAttributeWithUnit['fx'] := AValue;
     1862end;
     1863
     1864procedure TSVGRadialGradient.SetFY(AValue: TFloatWithCSSUnit);
     1865begin
     1866  VerticalAttributeWithUnit['fy'] := AValue;
     1867end;
     1868
     1869procedure TSVGRadialGradient.SetFR(AValue: TFloatWithCSSUnit);
     1870begin
     1871  HorizAttributeWithUnit['fr'] := AValue;
     1872end;
     1873
     1874constructor TSVGRadialGradient.Create(ADocument: TXMLDocument;
     1875  AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink);
     1876begin
     1877  inherited Create(ADocument, AUnits, ADataLink);
     1878  Init(ADocument,'radialGradient',AUnits);
     1879end;
     1880
     1881{ TSVGStopGradient }
     1882
     1883function TSVGStopGradient.GetOffset: TFloatWithCSSUnit;
     1884begin
     1885  result := AttributeWithUnit['offset'];
     1886end;
     1887
     1888procedure TSVGStopGradient.SetOffset(AValue: TFloatWithCSSUnit);
     1889begin
     1890  AttributeWithUnit['offset'] := AValue;
     1891end;
     1892
     1893constructor TSVGStopGradient.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter;
     1894  ADataLink: TSVGDataLink);
     1895begin
     1896  inherited Create(ADocument, AUnits, ADataLink);
     1897  Init(ADocument,'stop',AUnits);
     1898end;
     1899
     1900{ TSVGDefine }
     1901
     1902constructor TSVGDefine.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter;
     1903  ADataLink: TSVGDataLink);
     1904begin
     1905  inherited Create(ADocument, AUnits, ADataLink);
     1906  FContent := TSVGContent.Create(ADocument,FDomElem,AUnits,ADataLink,Self);
     1907end;
     1908
     1909constructor TSVGDefine.Create(ADocument: TXMLDocument; AElement: TDOMElement;
     1910  AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink);
     1911begin
     1912  inherited Create(ADocument, AElement, AUnits, ADataLink);
     1913  FContent := TSVGContent.Create(ADocument,AElement,AUnits,ADataLink,Self);
     1914end;
     1915
     1916destructor TSVGDefine.Destroy;
     1917begin
     1918  FreeAndNil(FContent);
     1919  inherited Destroy;
     1920end;
     1921
     1922procedure TSVGDefine.Recompute;
     1923begin
     1924  inherited Recompute;
     1925  FContent.Recompute;
    9071926end;
    9081927
     
    9481967
    9491968constructor TSVGContent.Create(ADocument: TXMLDocument; AElement: TDOMElement;
    950   AUnits: TCSSUnitConverter);
     1969  AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink; ADataParent: TSVGElement);
    9511970var cur: TDOMNode;
    9521971begin
    9531972  FDoc := ADocument;
    9541973  FDomElem := AElement;
    955   FElements := TList.Create;
     1974  FDataLink := ADataLink;
     1975  FElements := TFPList.Create;
    9561976  FUnits := AUnits;
    9571977  cur := FDomElem.FirstChild;
     
    9591979  begin
    9601980    if cur is TDOMElement then
    961       FElements.Add(CreateSVGElementFromNode(ADocument,TDOMElement(cur),FUnits));
     1981      FElements.Add(CreateSVGElementFromNode(
     1982        ADocument,TDOMElement(cur),FUnits,ADataLink,ADataParent));
    9621983    cur := cur.NextSibling;
    9631984  end;
     
    9711992  FreeAndNil(FElements);
    9721993  inherited Destroy;
     1994end;
     1995
     1996procedure TSVGContent.Recompute;
     1997var
     1998  i: Integer;
     1999begin
     2000  for i := 0 to ElementCount-1 do
     2001    Element[i].Recompute;
    9732002end;
    9742003
     
    9962025  ): TSVGLine;
    9972026begin
    998   result := TSVGLine.Create(FDoc,Units);
     2027  result := TSVGLine.Create(FDoc,Units,FDataLink);
    9992028  result.x1 := FloatWithCSSUnit(x1,AUnit);
    10002029  result.y1 := FloatWithCSSUnit(y1,AUnit);
     
    10142043  if (AUnit <> cuCustom) and (Units.DpiScaleX <> Units.DpiScaleY) then
    10152044  begin
    1016     result := TSVGCircle.Create(FDoc,Units);
     2045    result := TSVGCircle.Create(FDoc,Units,FDataLink);
    10172046    result.cx := FloatWithCSSUnit(Units.Convert(cx,AUnit,cuCustom,Units.DpiX),cuCustom);
    10182047    result.cy := FloatWithCSSUnit(Units.Convert(cy,AUnit,cuCustom,Units.DpiY),cuCustom);
     
    10222051  end else
    10232052  begin
    1024     result := TSVGCircle.Create(FDoc,Units);
     2053    result := TSVGCircle.Create(FDoc,Units,FDataLink);
    10252054    result.cx := FloatWithCSSUnit(cx,AUnit);
    10262055    result.cy := FloatWithCSSUnit(cy,AUnit);
     
    10392068  ): TSVGEllipse;
    10402069begin
    1041   result := TSVGEllipse.Create(FDoc,Units);
     2070  result := TSVGEllipse.Create(FDoc,Units,FDataLink);
    10422071  result.cx := FloatWithCSSUnit(cx,AUnit);
    10432072  result.cy := FloatWithCSSUnit(cy,AUnit);
     
    10622091  end else
    10632092  begin
    1064     result := TSVGPath.Create(FDoc,Units);
     2093    result := TSVGPath.Create(FDoc,Units,FDataLink);
    10652094    result.d := data;
    10662095    AppendElement(result);
     
    10722101  if (AUnit <> cuCustom) and (Units.DpiScaleX <> Units.DpiScaleY) then
    10732102  begin
    1074     result := TSVGPath.Create(FDoc,Units);
     2103    result := TSVGPath.Create(FDoc,Units,FDataLink);
    10752104    result.path.scale(Units.Convert(1,AUnit,cuCustom,Units.DpiX));
    10762105    path.copyTo(result.path);
     
    10792108  end else
    10802109  begin
    1081     result := TSVGPath.Create(FDoc,Units);
     2110    result := TSVGPath.Create(FDoc,Units,FDataLink);
    10822111    result.path.scale(Units.ConvertWidth(1,AUnit,cuCustom));
    10832112    path.copyTo(result.path);
     
    10922121  i: integer;
    10932122begin
    1094   result := TSVGPolypoints.Create(FDoc,FUnits,true);
     2123  result := TSVGPolypoints.Create(FDoc,FUnits,true,FDataLink);
    10952124  setlength(pts, length(points) div 2);
    10962125  for i := 0 to high(pts) do
     
    11062135  i: integer;
    11072136begin
    1108   result := TSVGPolypoints.Create(FDoc,FUnits,true);
     2137  result := TSVGPolypoints.Create(FDoc,FUnits,true,FDataLink);
    11092138  setlength(pts, length(points));
    11102139  for i := 0 to high(pts) do
     
    11172146  ): TSVGRectangle;
    11182147begin
    1119   result := TSVGRectangle.Create(FDoc,Units);
     2148  result := TSVGRectangle.Create(FDoc,Units,FDataLink);
    11202149  result.x := FloatWithCSSUnit(x,AUnit);
    11212150  result.y := FloatWithCSSUnit(y,AUnit);
     
    11342163  ): TSVGText;
    11352164begin
    1136   result := TSVGText.Create(FDoc,Units);
     2165  result := TSVGText.Create(FDoc,Units,FDataLink);
    11372166  result.x := FloatWithCSSUnit(x,AUnit);
    11382167  result.y := FloatWithCSSUnit(y,AUnit);
     
    11502179  AUnit: TCSSUnit): TSVGRectangle;
    11512180begin
    1152   result := TSVGRectangle.Create(FDoc,Units);
     2181  result := TSVGRectangle.Create(FDoc,Units,FDataLink);
    11532182  result.x := FloatWithCSSUnit(x,AUnit);
    11542183  result.y := FloatWithCSSUnit(y,AUnit);
  • GraphicTest/Packages/bgrabitmap/bgrasvgtype.pas

    r494 r521  
    22
    33{$mode objfpc}{$H+}
     4{$MODESWITCH ADVANCEDRECORDS}
    45
    56interface
     
    78uses
    89  Classes, SysUtils, BGRATransform, BGRABitmapTypes, BGRAUnits,
    9   laz2_DOM, BGRACanvas2D;
     10  laz2_DOM, BGRACanvas2D, fgl, BGRAGraphics;
    1011
    1112type
     13  ArrayOfFloat = array of single;
     14 
    1215  TSVGElement = class;
     16  TSVGElementList = specialize TFPGList<TSVGElement>;
    1317  TSVGFactory = class of TSVGElement;
     18 
     19  TSVGFillMode = (
     20     sfmEvenOdd = Ord(fmAlternate),
     21     sfmNonZero = Ord(fmWinding)
     22   );
     23   
     24  TFindStyleState = (fssNotSearch,
     25                     fssNotFind,
     26                     fssFind);
     27  TStyleAttribute = record
     28     attr  : string;
     29     pos   : integer;
     30  end;
     31  ArrayOfTStyleAttribute = array of TStyleAttribute;
     32
     33  { TSVGPreserveAspectRatio }
     34
     35  TSVGPreserveAspectRatio = record
     36     Preserve, Slice: boolean;
     37     HorizAlign: TAlignment;
     38     VertAlign: TTextLayout;
     39     function ToString: string;
     40     class function Parse(AValue: string): TSVGPreserveAspectRatio; static;
     41     class function DefaultValue: TSVGPreserveAspectRatio; static;
     42  end;
     43
     44  TSVGRecomputeEvent = procedure(Sender: TObject) of object;
     45 
     46  { TSVGDataLink }
     47
     48  TSVGDataLink = class
     49   private
     50     FElements,
     51     FGradients,
     52     FStyles,
     53     FRootElements: TSVGElementList;
     54     function IsValidID(const id: integer; list: TSVGElementList): boolean;
     55     function GetElement(id: integer): TSVGElement;
     56     function GetGradient(id: integer): TSVGElement;
     57     function GetStyle(id: integer): TSVGElement;
     58     function GetRootElement(id: integer): TSVGElement;
     59     function FindElement(el: TSVGElement; list: TSVGElementList): integer;
     60     function Find(el: TSVGElement): integer;//(find on FElements)
     61     procedure InternalLink(const id: integer; parent: TSVGElement);
     62     procedure InternalUnLink(const id: integer);
     63     procedure InternalReLink(const id: integer; parent: TSVGElement);
     64   public
     65     constructor Create;
     66     destructor Destroy; override;
     67
     68     function ElementCount: integer;
     69     function GradientCount: integer;
     70     function StyleCount: integer;
     71     //contains the elements at the root of the link tree (having parent = nil)
     72     function RootElementCount: integer;
     73     function IsLink(el: TSVGElement): boolean;
     74     //(Note: assumes that the valid parent is present in the list or added later)
     75     function Link(el: TSVGElement; parent: TSVGElement = nil): integer;
     76     //excludes el from the list (+ restores validity of links)
     77     procedure Unlink(el: TSVGElement);
     78     //(faster method than a "for.. Unlink()")
     79     procedure UnlinkAll;
     80     //Method needed to change the parent of an item without removing it
     81     function ReLink(el: TSVGElement; parent: TSVGElement): boolean;
     82
     83     //(useful for testing support)
     84     function GetInternalState: TStringList;
     85
     86     property Elements[ID: integer]: TSVGElement read GetElement;
     87     property Gradients[ID: integer]: TSVGElement read GetGradient;
     88     property Styles[ID: integer]: TSVGElement read GetStyle;
     89     property RootElements[ID: integer]: TSVGElement read GetRootElement;
     90  end;
    1491
    1592  { TSVGElement }
     
    1794  TSVGElement = class
    1895    private
    19       function GetAttributeOrStyle(AName: string): string;
     96      findStyleState: TFindStyleState;
     97      styleAttributes: ArrayOfTStyleAttribute;
     98      FDataParent: TSVGElement;
     99      FDataChildList: TSVGElementList;
     100      function GetAttributeOrStyle(AName,ADefault: string): string; overload;
     101      function GetAttributeOrStyle(AName: string): string; overload;
    20102      function GetFill: string;
    21103      function GetFillColor: TBGRAPixel;
    22104      function GetFillOpacity: single;
    23       function GetHorizAttributeOrStyleWithUnit(AName: string
    24         ): TFloatWithCSSUnit;
     105      function GetFillRule: string;
     106      function GetHorizAttributeOrStyleWithUnit(AName: string;
     107        ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit;
    25108      function GetIsFillNone: boolean;
    26109      function GetIsStrokeNone: boolean;
    27110      function GetMatrix(AUnit: TCSSUnit): TAffineMatrix;
    28111      function GetOpacity: single;
    29       function GetOrthoAttributeOrStyleWithUnit(AName: string
    30         ): TFloatWithCSSUnit;
     112      function GetOrthoAttributeOrStyleWithUnit(AName: string;
     113        ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit;
    31114      function GetStroke: string;
    32115      function GetStrokeColor: TBGRAPixel;
     
    36119      function GetStrokeOpacity: single;
    37120      function GetStrokeWidth: TFloatWithCSSUnit;
    38       function GetStyle(const AName: string): string;
     121      function GetStrokeDashArray: string;
     122      function GetStrokeDashArrayF: ArrayOfFloat;
     123      function GetStrokeDashOffset: TFloatWithCSSUnit;
     124      function GetStyle(const AName,ADefault: string): string; overload;
     125      function GetStyle(const AName: string): string; overload;
    39126      function GetTransform: string;
    40127      function GetUnits: TCSSUnitConverter;
    41       function GetAttribute(AName: string): string;
    42       function GetVerticalAttributeOrStyleWithUnit(AName: string
    43         ): TFloatWithCSSUnit;
     128      function GetAttribute(AName,ADefault: string; ACanInherit: boolean): string; overload;
     129      function GetAttribute(AName,ADefault: string): string; overload;
     130      function GetAttribute(AName: string): string; overload;
     131      function GetVerticalAttributeOrStyleWithUnit(AName: string;
     132        ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit;
    44133      procedure SetAttribute(AName: string; AValue: string);
    45       function GetAttributeWithUnit(AName: string): TFloatWithCSSUnit;
    46       function GetAttributeOrStyleWithUnit(AName: string): TFloatWithCSSUnit;
    47       function GetOrthoAttributeWithUnit(AName: string): TFloatWithCSSUnit;
    48       function GetHorizAttributeWithUnit(AName: string): TFloatWithCSSUnit;
    49       function GetVerticalAttributeWithUnit(AName: string): TFloatWithCSSUnit;
     134      function GetAttributeWithUnit(AName: string; ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit; overload;
     135      function GetAttributeWithUnit(AName: string): TFloatWithCSSUnit; overload;
     136      function GetAttributeOrStyleWithUnit(AName: string;
     137        ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit; overload;
     138      function GetAttributeOrStyleWithUnit(AName: string): TFloatWithCSSUnit; overload;
     139      function GetOrthoAttributeWithUnit(AName: string; ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit; overload;
     140      function GetOrthoAttributeWithUnit(AName: string): TFloatWithCSSUnit; overload;
     141      function GetHorizAttributeWithUnit(AName: string; ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit; overload;
     142      function GetHorizAttributeWithUnit(AName: string): TFloatWithCSSUnit; overload;
     143      function GetVerticalAttributeWithUnit(AName: string; ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit; overload;
     144      function GetVerticalAttributeWithUnit(AName: string): TFloatWithCSSUnit; overload;
     145      function GetID: string;
     146      function GetClassAt: string;
    50147      procedure SetAttributeWithUnit(AName: string; AValue: TFloatWithCSSUnit);
    51148      procedure SetFill(AValue: string);
    52149      procedure SetFillColor(AValue: TBGRAPixel);
    53150      procedure SetFillOpacity(AValue: single);
     151      procedure SetFillRule(AValue: string);
    54152      procedure SetHorizAttributeWithUnit(AName: string; AValue: TFloatWithCSSUnit);
    55153      procedure SetMatrix(AUnit: TCSSUnit; const AValue: TAffineMatrix);
     
    62160      procedure SetStrokeOpacity(AValue: single);
    63161      procedure SetStrokeWidth(AValue: TFloatWithCSSUnit);
     162      procedure SetStrokeDashArray(AValue: string);
     163      procedure SetStrokeDashArrayF(AValue: ArrayOfFloat);
     164      procedure SetStrokeDashOffset(AValue: TFloatWithCSSUnit);
    64165      procedure SetStyle(AName: string; AValue: string);
    65166      procedure SetTransform(AValue: string);
    66167      procedure SetVerticalAttributeWithUnit(AName: string; AValue: TFloatWithCSSUnit);
    67168      procedure SetOrthoAttributeWithUnit(AName: string; AValue: TFloatWithCSSUnit);
     169      procedure SetID(AValue: string);
     170      procedure SetClassAt(AValue: string);
     171      function FindStyleElementInternal(const classStr: string;
     172        out attributesStr: string): integer;
     173      procedure FindStyleElement;
    68174    protected
     175      FDataLink: TSVGDataLink;
    69176      FDomElem: TDOMElement;
    70177      FUnits: TCSSUnitConverter;
     
    74181      procedure InternalDraw({%H-}ACanvas2d: TBGRACanvas2D; {%H-}AUnit: TCSSUnit); virtual;
    75182      procedure LocateStyleDeclaration(AText: string; AProperty: string; out AStartPos,AColonPos,AValueLength: integer);
     183      procedure ApplyFillStyle(ACanvas2D: TBGRACanvas2D; {%H-}AUnit: TCSSUnit); virtual;
    76184      procedure ApplyStrokeStyle(ACanvas2D: TBGRACanvas2D; AUnit: TCSSUnit);
     185      procedure Initialize; virtual;
    77186    public
    78       constructor Create({%H-}ADocument: TXMLDocument; AElement: TDOMElement; AUnits: TCSSUnitConverter); virtual;
    79       constructor Create({%H-}ADocument: TXMLDocument; {%H-}AUnits: TCSSUnitConverter); virtual;
     187      constructor Create({%H-}ADocument: TXMLDocument; AElement: TDOMElement; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); overload; virtual;
     188      constructor Create({%H-}ADocument: TXMLDocument; {%H-}AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); overload; virtual;
     189      destructor Destroy; override;
     190      procedure Recompute; virtual;
    80191      procedure Draw({%H-}ACanvas2d: TBGRACanvas2D; {%H-}AUnit: TCSSUnit);
    81192      procedure fillNone;
     
    83194      procedure transformNone;
    84195      procedure RemoveStyle(const AName: string);
     196      function HasAttribute(AName: string): boolean;
     197      function fillMode: TSVGFillMode;
     198      function DataChildList: TSVGElementList;
     199      property DataLink: TSVGDataLink read FDataLink write FDataLink;
     200      property AttributeDef[AName,ADefault: string]: string read GetAttribute;
    85201      property Attribute[AName: string]: string read GetAttribute write SetAttribute;
     202      property AttributeOrStyleDef[AName,ADefault: string]: string read GetAttributeOrStyle;
    86203      property AttributeOrStyle[AName: string]: string read GetAttributeOrStyle;
     204      property StyleDef[AName,ADefault: string]: string read GetStyle;
    87205      property Style[AName: string]: string read GetStyle write SetStyle;
     206      property AttributeWithUnitDef[AName: string; ADefault: TFloatWithCSSUnit]: TFloatWithCSSUnit read GetAttributeWithUnit;
     207      property AttributeWithUnit[AName: string]: TFloatWithCSSUnit read GetAttributeWithUnit write SetAttributeWithUnit;
     208      property OrthoAttributeWithUnitDef[AName: string; ADefault: TFloatWithCSSUnit]: TFloatWithCSSUnit read GetOrthoAttributeWithUnit;
    88209      property OrthoAttributeWithUnit[AName: string]: TFloatWithCSSUnit read GetOrthoAttributeWithUnit write SetOrthoAttributeWithUnit;
     210      property HorizAttributeWithUnitDef[AName: string; ADefault: TFloatWithCSSUnit]: TFloatWithCSSUnit read GetHorizAttributeWithUnit;
    89211      property HorizAttributeWithUnit[AName: string]: TFloatWithCSSUnit read GetHorizAttributeWithUnit write SetHorizAttributeWithUnit;
     212      property VerticalAttributeWithUnitDef[AName: string; ADefault: TFloatWithCSSUnit]: TFloatWithCSSUnit read GetVerticalAttributeWithUnit;
    90213      property VerticalAttributeWithUnit[AName: string]: TFloatWithCSSUnit read GetVerticalAttributeWithUnit write SetVerticalAttributeWithUnit;
    91       property OrthoAttributeOrStyleWithUnit[AName: string]: TFloatWithCSSUnit read GetOrthoAttributeOrStyleWithUnit;
    92       property HorizAttributeOrStyleWithUnit[AName: string]: TFloatWithCSSUnit read GetHorizAttributeOrStyleWithUnit;
    93       property VerticalAttributeOrStyleWithUnit[AName: string]: TFloatWithCSSUnit read GetVerticalAttributeOrStyleWithUnit;
     214      property OrthoAttributeOrStyleWithUnit[AName: string; ADefault: TFloatWithCSSUnit]: TFloatWithCSSUnit read GetOrthoAttributeOrStyleWithUnit;
     215      property HorizAttributeOrStyleWithUnit[AName: string; ADefault: TFloatWithCSSUnit]: TFloatWithCSSUnit read GetHorizAttributeOrStyleWithUnit;
     216      property VerticalAttributeOrStyleWithUnit[AName: string; ADefault: TFloatWithCSSUnit]: TFloatWithCSSUnit read GetVerticalAttributeOrStyleWithUnit;
    94217      property DOMElement: TDOMElement read GetDOMElement;
    95218      property Units: TCSSUnitConverter read GetUnits;
     
    105228      property strokeLineJoin: string read GetStrokeLineJoin write SetStrokeLineJoin;
    106229      property strokeLineCap: string read GetStrokeLineCap write SetStrokeLineCap;
     230      property strokeDashArray: string read GetStrokeDashArray write SetStrokeDashArray;
     231      property strokeDashArrayF: ArrayOfFloat read GetStrokeDashArrayF write SetStrokeDashArrayF;
     232      property strokeDashOffset: TFloatWithCSSUnit read GetStrokeDashOffset write SetStrokeDashOffset;
    107233      property fill: string read GetFill write SetFill;
    108234      property fillColor: TBGRAPixel read GetFillColor write SetFillColor;
    109235      property fillOpacity: single read GetFillOpacity write SetFillOpacity;
     236      property fillRule: string read GetFillRule write SetFillRule;
    110237      property opacity: single read GetOpacity write SetOpacity;
     238      property ID: string read GetID write SetID;
     239      property classAt: string read GetClassAt write SetClassAt;//Attribute "class"
     240      property DataParent: TSVGElement read FDataParent write FDataParent;
    111241  end;
    112242
     
    125255    function ParseId: string;
    126256    function ParseSymbol: char;
     257    function ParseTransform: TAffineMatrix;
    127258    procedure SkipSymbol(ASymbol: char);
    128259    procedure SkipUpToSymbol(ASymbol:char);
     
    133264    property Done: boolean read GetDone;
    134265  end;
     266 
     267  resourcestring
     268    rsInvalidId = 'invalid id';
    135269
    136270implementation
     271
     272uses BGRASVGShapes;
     273
     274{ TSVGPreserveAspectRatio }
     275
     276function TSVGPreserveAspectRatio.ToString: string;
     277begin
     278  if not Preserve then result := 'none' else
     279  begin
     280    result := '';
     281    case HorizAlign of
     282    taCenter: result += 'xMid';
     283    taRightJustify: result += 'xMax';
     284    else result += 'xMin';
     285    end;
     286    case VertAlign of
     287    tlCenter: result += 'YMid';
     288    tlBottom: result += 'YMax';
     289    else result += 'YMin';
     290    end;
     291    if Slice then result += ' slice' else result += ' meet';
     292  end;
     293end;
     294
     295class function TSVGPreserveAspectRatio.Parse(AValue: string
     296  ): TSVGPreserveAspectRatio;
     297var p: TSVGParser;
     298  id: string;
     299begin
     300  p := TSVGParser.Create(AValue);
     301  result := DefaultValue;
     302  repeat
     303    id := p.ParseId;
     304    if id = 'none' then
     305    begin
     306      result.Preserve := false;
     307      //set other parameters for intermediate value of ViewSize (before stretching non-proportionaly)
     308      result.Slice := false;
     309      result.HorizAlign := taCenter;
     310      result.VertAlign := tlCenter;
     311      exit;
     312    end else
     313    if id = 'slice' then result.Slice := true
     314    else if (length(id)=8) and (id[1] = 'x') and (id[5] = 'Y') then
     315    begin
     316      case copy(id,2,3) of
     317      'Min': result.HorizAlign := taLeftJustify;
     318      'Mid': result.HorizAlign := taCenter;
     319      'Max': result.HorizAlign := taRightJustify;
     320      end;
     321      case copy(id,6,3) of
     322      'Min': result.VertAlign := tlTop;
     323      'Mid': result.VertAlign := tlCenter;
     324      'Max': result.VertAlign := tlBottom;
     325      end;
     326    end;
     327  until id = '';
     328  p.Free;
     329end;
     330
     331class function TSVGPreserveAspectRatio.DefaultValue: TSVGPreserveAspectRatio;
     332begin
     333  result.Preserve := true;
     334  result.Slice := false;
     335  result.HorizAlign := taCenter;
     336  result.VertAlign := tlCenter;
     337end;
    137338
    138339{ TSVGParser }
     
    194395end;
    195396
     397function TSVGParser.ParseTransform: TAffineMatrix;
     398var
     399  kind: String;
     400  m : TAffineMatrix;
     401  angle,tx,ty: single;
     402begin
     403  result := AffineMatrixIdentity;
     404  while not Done do
     405  begin
     406    kind := ParseId;
     407    if kind = '' then break;
     408    if ParseSymbol <> '(' then break;
     409    if compareText(kind,'matrix')=0 then
     410    begin
     411      m[1,1] := ParseFloat;
     412      SkipSymbol(',');
     413      m[2,1] := ParseFloat;
     414      SkipSymbol(',');
     415      m[1,2] := ParseFloat;
     416      SkipSymbol(',');
     417      m[2,2] := ParseFloat;
     418      SkipSymbol(',');
     419      m[1,3] := ParseFloat;
     420      SkipSymbol(',');
     421      m[2,3] := ParseFloat;
     422      result *= m;
     423    end else
     424    if compareText(kind,'translate')=0 then
     425    begin
     426      tx := ParseFloat;
     427      SkipSymbol(',');
     428      ty := ParseFloat;
     429      result *= AffineMatrixTranslation(tx,ty);
     430    end else
     431    if compareText(kind,'scale')=0 then
     432    begin
     433      tx := ParseFloat;
     434      SkipSymbol(',');
     435      ClearError;
     436      ty := ParseFloat;
     437      if NumberError then ty := tx;
     438      result *= AffineMatrixScale(tx,ty);
     439    end else
     440    if compareText(kind,'rotate')=0 then
     441    begin
     442      angle := ParseFloat;
     443      SkipSymbol(',');
     444      tx := ParseFloat;
     445      SkipSymbol(',');
     446      ty := ParseFloat;
     447      result *= AffineMatrixTranslation(tx,ty)*AffineMatrixRotationDeg(angle)*
     448                AffineMatrixTranslation(-tx,-ty);
     449    end else
     450    if compareText(kind,'skewx')=0 then
     451    begin
     452      angle := ParseFloat;
     453      result *= AffineMatrixSkewXDeg(angle);
     454    end else
     455    if compareText(kind,'skewy')=0 then
     456    begin
     457      angle := ParseFloat;
     458      result *= AffineMatrixSkewYDeg(angle);
     459    end;
     460    SkipUpToSymbol(')');
     461  end;
     462end;
     463
    196464procedure TSVGParser.SkipSymbol(ASymbol: char);
    197465begin
     
    211479end;
    212480
     481{ TSVGDataLink }
     482
     483constructor TSVGDataLink.Create;
     484begin
     485  FElements:= TSVGElementList.Create;
     486  FGradients:= TSVGElementList.Create;
     487  FStyles:= TSVGElementList.Create;
     488  FRootElements:= TSVGElementList.Create;
     489end;
     490
     491destructor TSVGDataLink.Destroy;
     492begin
     493  FreeAndNil(FRootElements);
     494  FreeAndNil(FGradients);
     495  FreeAndNil(FElements);
     496  FreeAndNil(FStyles);
     497  inherited Destroy;
     498end;
     499
     500function TSVGDataLink.IsValidID(const id: integer; list: TSVGElementList): boolean;
     501begin
     502  result:= (id >= 0) and (id < list.Count);
     503end;
     504
     505function TSVGDataLink.GetElement(id: integer): TSVGElement;
     506begin
     507  if not IsValidID(id,FElements) then
     508   raise exception.Create(rsInvalidId);
     509  result:= FElements[id];
     510end;
     511
     512function TSVGDataLink.GetGradient(id: integer): TSVGElement;
     513begin
     514  if not IsValidID(id,FGradients) then
     515   raise exception.Create(rsInvalidId);
     516  result:= FGradients[id];
     517end;
     518
     519function TSVGDataLink.GetStyle(id: integer): TSVGElement;
     520begin
     521  if not IsValidID(id,FStyles) then
     522   raise exception.Create(rsInvalidId);
     523  result:= FStyles[id];
     524end; 
     525
     526function TSVGDataLink.GetRootElement(id: integer): TSVGElement;
     527begin
     528  if not IsValidID(id,FRootElements) then
     529   raise exception.Create(rsInvalidId);
     530  result:= FRootElements[id];
     531end;
     532
     533function TSVGDataLink.FindElement(el: TSVGElement; list: TSVGElementList): integer;
     534var
     535  i: integer;
     536begin
     537  for i:= 0 to list.Count-1 do
     538    if list[i] = el then
     539    begin
     540      result:= i;
     541      Exit;
     542    end;
     543  result:= -1;
     544end;
     545
     546function TSVGDataLink.Find(el: TSVGElement): integer;
     547begin
     548  result:= FindElement(el,FElements);
     549end;
     550
     551procedure TSVGDataLink.InternalLink(const id: integer; parent: TSVGElement);
     552var
     553  el: TSVGElement;
     554begin
     555  el:= FElements.Items[id];
     556  with el do
     557  begin
     558    DataParent:= parent;
     559    if parent = nil then
     560     FRootElements.Add(el);
     561    //Update DataChildList of "parent" before add it
     562    //(not use el.DataChildList.Clear here!!)
     563    if parent <> nil then
     564      parent.DataChildList.Add(el);
     565  end;
     566end;
     567
     568procedure TSVGDataLink.InternalUnLink(const id: integer);
     569var
     570  i,pos_root: integer;
     571  el: TSVGElement;
     572begin
     573  el:= FElements.Items[id];
     574  with el do
     575  begin
     576    //se root need remove (use pos for add child as new root)
     577    if DataParent = nil then
     578     pos_root:= FRootElements.Remove(el)
     579    else
     580     pos_root:= FRootElements.Count;
     581    //i have to assign a parent of a upper level
     582    //and update child list of new parent (if not nil)
     583    with DataChildList do
     584    begin
     585      for i:= 0 to Count-1 do
     586      begin
     587       Items[i].DataParent:= el.DataParent;
     588       if el.DataParent = nil then
     589        //with parent nil = new root
     590        FRootElements.Insert(pos_root+i, Items[i])
     591       else
     592        el.DataParent.DataChildList.Add( Items[i] );
     593      end;
     594      Clear;
     595    end;
     596    //if he has a parent, I have to remove his reference as a child
     597    if DataParent <> nil then
     598    begin
     599      DataParent.DataChildList.Remove(el);
     600      DataParent:= nil;
     601    end;
     602  end;
     603end;
     604
     605procedure TSVGDataLink.InternalReLink(const id: integer; parent: TSVGElement);
     606begin
     607  InternalUnLink(id);
     608  InternalLink(id,parent);
     609end;
     610
     611function TSVGDataLink.ElementCount: integer;
     612begin
     613  result:= FElements.Count;
     614end;
     615
     616function TSVGDataLink.GradientCount: integer;
     617begin
     618  result:= FGradients.Count;
     619end;
     620
     621function TSVGDataLink.StyleCount: integer;
     622begin
     623  result:= FStyles.Count;
     624end;
     625
     626function TSVGDataLink.RootElementCount: integer;
     627begin
     628  result:= FRootElements.Count;
     629end;
     630
     631function TSVGDataLink.IsLink(el: TSVGElement): boolean;
     632begin
     633  result:= Find(el) <> -1;
     634end;
     635
     636function TSVGDataLink.Link(el: TSVGElement; parent: TSVGElement = nil): integer;
     637begin
     638  FElements.Add(el);
     639  result:= FElements.Count-1;
     640  InternalLink(result,parent);
     641  if el is TSVGGradient then
     642    FGradients.Add(el)
     643  else if el is TSVGStyle then
     644    FStyles.Add(el);
     645end;
     646
     647procedure TSVGDataLink.Unlink(el: TSVGElement);
     648var
     649  id: integer;
     650begin
     651  id:= FindElement(el,FElements);
     652  if id <> -1 then
     653  begin
     654    if el is TSVGGradient then
     655      FGradients.Remove(el)
     656    else if el is TSVGStyle then
     657      FStyles.Remove(el);
     658    InternalUnLink(id);
     659    FElements.Delete(id);
     660  end
     661  else
     662   raise exception.Create('element not find');
     663end;
     664
     665procedure TSVGDataLink.UnlinkAll;
     666var
     667  i: integer;
     668begin
     669  FGradients.Clear;
     670  FStyles.Clear;
     671
     672  for i:= 0 to FElements.Count-1 do
     673    InternalUnLink(i);
     674  FRootElements.Clear;
     675  FElements.Clear;
     676end;
     677
     678function TSVGDataLink.ReLink(el: TSVGElement; parent: TSVGElement): boolean;
     679var
     680  id: integer;
     681begin
     682  id:= FindElement(el,FElements);
     683  if id <> -1 then
     684  begin
     685    result:= true;
     686    if el.DataParent <> parent then
     687      InternalReLink(id,parent);
     688  end
     689  else
     690    result:= false;
     691end;
     692
     693function TSVGDataLink.GetInternalState: TStringList;
     694var
     695  nid: integer;
     696  sl: TStringList;
     697
     698  function SpaceStr(const level: integer): string;
     699  var
     700    i: integer;
     701  begin
     702    result:= '';
     703    for i:= 1 to level do
     704      result:= result + ' ';
     705  end;
     706
     707  procedure AddStr(s: string; const level: integer);
     708  begin
     709    sl.Add( SpaceStr(level) + s );
     710  end;
     711
     712  function ElementIdentity(el: TSVGElement): string;
     713  begin
     714   if el = nil then
     715     result:= 'nil'
     716   else
     717   begin
     718     result:= el.ID;
     719     if Trim(Result) = '' then
     720       result:= 'unknow';
     721     result:= result + ' - ' + el.ClassName +
     722       //(slow: for test ok)
     723       ' | (pos: ' + IntToStr( Find(el) ) + ')';
     724   end;
     725  end;
     726
     727  procedure ElementToInfo(el: TSVGElement; const level: integer);
     728  Var
     729   i: integer;
     730   sep: string;
     731  begin
     732   if el.DataParent = nil then
     733    sep:= '###'
     734   else
     735    sep:= '***';
     736   AddStr('{'+sep+' '+ElementIdentity(el)+' '+sep+'}', level);
     737   AddStr('[Parent: ' + ElementIdentity(el.DataParent) + ']', level);
     738   for i:= 0 to el.DataChildList.Count-1 do
     739     AddStr('[Child: ' + ElementIdentity(el.DataChildList[i]) + ']', level);
     740  end;
     741
     742  procedure BuildInfo(el: TSVGElement; const level: integer = 1);
     743  const
     744    kspace = 5;
     745  var
     746    i: Integer;
     747  begin
     748   ElementToInfo(el,level);
     749   Inc(nid);
     750   for i:= 0 to el.DataChildList.Count-1 do
     751     BuildInfo(el.DataChildList[i],level+kspace);
     752  end;
     753
     754var
     755 i: integer;
     756begin
     757  nid:= 0;
     758  sl:= TStringList.Create;
     759  for i:= 0 to FRootElements.Count-1 do
     760    BuildInfo( FRootElements[i] );
     761  result:= sl;
     762end;     
     763
    213764{ TSVGElement }
    214765
     766function TSVGElement.GetAttribute(AName,ADefault: string; ACanInherit: boolean): string;
     767var
     768  curNode: TDOMElement;
     769begin
     770  curNode := FDomElem;
     771  repeat
     772    result := Trim(curNode.GetAttribute(AName));
     773    if (result = 'currentColor') and (AName <> 'color') then
     774    begin
     775      AName := 'color';
     776      curNode := FDomElem; //get from the current element
     777      ACanInherit:= true;
     778      result := Trim(curNode.GetAttribute(AName));
     779    end;
     780    if ((result = '') or (result = 'inherit')) and ACanInherit and
     781      (curNode.ParentNode is TDOMElement) then
     782      curNode := curNode.ParentNode as TDOMElement
     783    else
     784      curNode := nil;
     785  until curNode = nil;
     786
     787  if (result = '') or (result = 'inherit') then
     788    result:= ADefault;
     789end;
     790
     791function TSVGElement.GetAttribute(AName, ADefault: string): string;
     792begin
     793  result := GetAttribute(AName, ADefault, False);
     794end;
     795
    215796function TSVGElement.GetAttribute(AName: string): string;
    216797begin
    217   result := FDomElem.GetAttribute(AName);
    218 end;
    219 
    220 function TSVGElement.GetVerticalAttributeOrStyleWithUnit(AName: string
    221   ): TFloatWithCSSUnit;
    222 begin
    223   result := GetAttributeOrStyleWithUnit(AName);
     798  result:= GetAttribute(AName,'');
     799end; 
     800
     801function TSVGElement.GetVerticalAttributeOrStyleWithUnit(AName: string;
     802  ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit;
     803begin
     804  result := GetAttributeOrStyleWithUnit(AName,ADefault);
    224805  if result.CSSUnit <> cuCustom then
    225806    if units.DpiScaleY = 0 then
     
    229810end;
    230811
     812function TSVGElement.GetAttributeWithUnit(AName: string; ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit;
     813begin
     814  result := TCSSUnitConverter.parseValue(Attribute[AName],ADefault);
     815end;
     816
    231817function TSVGElement.GetAttributeWithUnit(AName: string): TFloatWithCSSUnit;
    232818begin
    233   result := TCSSUnitConverter.parseValue(Attribute[AName],FloatWithCSSUnit(0,cuCustom));
    234 end;
    235 
    236 function TSVGElement.GetAttributeOrStyleWithUnit(AName: string
    237   ): TFloatWithCSSUnit;
    238 var valueText: string;
     819  result := GetAttributeWithUnit(AName,FloatWithCSSUnit(0,cuCustom));
     820end; 
     821
     822function TSVGElement.GetAttributeOrStyleWithUnit(AName: string; ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit;
     823var
     824  valueText: string;
    239825begin
    240826  valueText := Style[AName];
    241   if valueText = '' then valueText := Attribute[AName];
    242   result := TCSSUnitConverter.parseValue(valueText,FloatWithCSSUnit(0,cuCustom));
    243 end;
    244 
    245 function TSVGElement.GetOrthoAttributeWithUnit(AName: string
    246   ): TFloatWithCSSUnit;
    247 begin
    248   result := GetHorizAttributeWithUnit(AName);
     827  if valueText = '' then
     828    valueText := GetAttribute(AName,'',True);
     829  result := TCSSUnitConverter.parseValue(valueText,ADefault);
     830end;
     831
     832function TSVGElement.GetAttributeOrStyleWithUnit(AName: string): TFloatWithCSSUnit;
     833begin
     834  result := GetAttributeOrStyleWithUnit(AName,FloatWithCSSUnit(0,cuCustom));
     835end;
     836
     837function TSVGElement.GetOrthoAttributeWithUnit(AName: string;
     838  ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit;
     839begin
     840  result := GetHorizAttributeWithUnit(AName,ADefault);
    249841  //value will be inconsistent if scaling is inconsistent
    250842end;
    251843
    252 function TSVGElement.GetHorizAttributeWithUnit(AName: string
    253   ): TFloatWithCSSUnit;
    254 begin
    255   result := GetAttributeWithUnit(AName);
     844function TSVGElement.GetOrthoAttributeWithUnit(AName: string): TFloatWithCSSUnit;
     845begin
     846  result := GetOrthoAttributeWithUnit(AName,FloatWithCSSUnit(0,cuCustom));
     847end;
     848
     849function TSVGElement.GetHorizAttributeWithUnit(AName: string;
     850  ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit;
     851begin
     852  result := GetAttributeWithUnit(AName,ADefault);
     853  if result.value <> EmptySingle then
     854  begin
     855    if result.CSSUnit <> cuCustom then
     856      if units.DpiScaleX = 0 then
     857        result.value := 0
     858      else
     859        result.value /= Units.DpiScaleX;
     860  end;
     861end;
     862
     863function TSVGElement.GetHorizAttributeWithUnit(AName: string): TFloatWithCSSUnit;
     864begin
     865  result := GetHorizAttributeWithUnit(AName,FloatWithCSSUnit(0,cuCustom));
     866end;
     867
     868function TSVGElement.GetAttributeOrStyle(AName,ADefault: string): string;
     869begin
     870  result := GetStyle(AName,ADefault);
     871  if result = '' then
     872    result := GetAttribute(AName,ADefault,True);
     873end;
     874
     875function TSVGElement.GetAttributeOrStyle(AName: string): string;
     876begin
     877  result:= GetAttributeOrStyle(AName,'');
     878end;   
     879
     880function TSVGElement.GetFill: string;
     881begin
     882  result := AttributeOrStyleDef['fill','black'];
     883end;
     884
     885function TSVGElement.GetFillColor: TBGRAPixel;
     886begin
     887  result := StrToBGRA(fill,BGRABlack);
     888  result.alpha := round(result.alpha*fillOpacity*opacity);
     889  if result.alpha = 0 then result := BGRAPixelTransparent;
     890end;
     891
     892function TSVGElement.GetFillOpacity: single;
     893var errPos: integer;
     894begin
     895  val(AttributeOrStyleDef['fill-opacity','1'], result, errPos);
     896  if errPos <> 0 then result := 1 else
     897    if result < 0 then result := 0 else
     898      if result > 1 then result := 1;
     899end;
     900
     901function TSVGElement.GetFillRule: string;
     902begin
     903  result := AttributeOrStyleDef['fill-rule','nonzero'];
     904end;
     905
     906function TSVGElement.GetHorizAttributeOrStyleWithUnit(AName: string;
     907  ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit;
     908begin
     909  result := GetAttributeOrStyleWithUnit(AName,ADefault);
    256910  if result.CSSUnit <> cuCustom then
    257911    if units.DpiScaleX = 0 then
     
    261915end;
    262916
    263 function TSVGElement.GetAttributeOrStyle(AName: string): string;
    264 begin
    265   result := GetStyle(AName);
    266   if result = '' then result := GetAttribute(AName);
    267 end;
    268 
    269 function TSVGElement.GetFill: string;
    270 begin
    271   result := AttributeOrStyle['fill'];
    272 end;
    273 
    274 function TSVGElement.GetFillColor: TBGRAPixel;
    275 begin
    276   result := StrToBGRA(fill,BGRABlack);
    277   result.alpha := round(result.alpha*fillOpacity*opacity);
    278   if result.alpha = 0 then result := BGRAPixelTransparent;
    279 end;
    280 
    281 function TSVGElement.GetFillOpacity: single;
     917function TSVGElement.GetIsFillNone: boolean;
     918begin
     919  result := compareText(trim(fill),'none')=0;
     920end;
     921
     922function TSVGElement.GetIsStrokeNone: boolean;
     923var strokeStr: string;
     924begin
     925  strokeStr := stroke;
     926  result := (trim(strokeStr)='') or (compareText(trim(strokeStr),'none')=0);
     927end;
     928
     929function TSVGElement.GetMatrix(AUnit: TCSSUnit): TAffineMatrix;
     930var parser: TSVGParser;
     931    s: string;
     932begin
     933  s := transform;
     934  if s='' then
     935  begin
     936    result := AffineMatrixIdentity;
     937    exit;
     938  end;
     939  parser := TSVGParser.Create(s);
     940  result := parser.ParseTransform;
     941  result[1,3] := Units.ConvertWidth(result[1,3],cuCustom,AUnit);
     942  result[2,3] := Units.ConvertHeight(result[2,3],cuCustom,AUnit);
     943  parser.Free;
     944end;
     945
     946function TSVGElement.GetOpacity: single;
    282947var errPos: integer;
    283948begin
    284   val(AttributeOrStyle['fill-opacity'], result, errPos);
     949  val(AttributeOrStyleDef['opacity','1'], result, errPos);
    285950  if errPos <> 0 then result := 1 else
    286951    if result < 0 then result := 0 else
     
    288953end;
    289954
    290 function TSVGElement.GetHorizAttributeOrStyleWithUnit(AName: string
    291   ): TFloatWithCSSUnit;
    292 begin
    293   result := GetAttributeOrStyleWithUnit(AName);
    294   if result.CSSUnit <> cuCustom then
    295     if units.DpiScaleX = 0 then
    296       result.value := 0
    297     else
    298       result.value /= Units.DpiScaleX;
    299 end;
    300 
    301 function TSVGElement.GetIsFillNone: boolean;
    302 begin
    303   result := compareText(trim(fill),'none')=0;
    304 end;
    305 
    306 function TSVGElement.GetIsStrokeNone: boolean;
    307 var strokeStr: string;
    308 begin
    309   strokeStr := stroke;
    310   result := (trim(strokeStr)='') or (compareText(trim(strokeStr),'none')=0);
    311 end;
    312 
    313 function TSVGElement.GetMatrix(AUnit: TCSSUnit): TAffineMatrix;
    314 var parser: TSVGParser;
    315     s,kind: string;
    316     m : TAffineMatrix;
    317     angle,tx,ty: single;
    318 begin
    319   result := AffineMatrixIdentity;
    320   s := transform;
    321   if s='' then exit;
    322   parser := TSVGParser.Create(s);
    323   while not parser.Done do
    324   begin
    325     kind := parser.ParseId;
    326     if kind = '' then break;
    327     if parser.ParseSymbol <> '(' then break;
    328     if compareText(kind,'matrix')=0 then
    329     begin
    330       m[1,1] := parser.ParseFloat;
    331       parser.SkipSymbol(',');
    332       m[2,1] := parser.ParseFloat;
    333       parser.SkipSymbol(',');
    334       m[1,2] := parser.ParseFloat;
    335       parser.SkipSymbol(',');
    336       m[2,2] := parser.ParseFloat;
    337       parser.SkipSymbol(',');
    338       m[1,3] := parser.ParseFloat;
    339       parser.SkipSymbol(',');
    340       m[2,3] := parser.ParseFloat;
    341       result *= m;
    342     end else
    343     if compareText(kind,'translate')=0 then
    344     begin
    345       tx := parser.ParseFloat;
    346       parser.SkipSymbol(',');
    347       ty := parser.ParseFloat;
    348       result *= AffineMatrixTranslation(tx,ty);
    349     end else
    350     if compareText(kind,'scale')=0 then
    351     begin
    352       tx := parser.ParseFloat;
    353       parser.SkipSymbol(',');
    354       parser.ClearError;
    355       ty := parser.ParseFloat;
    356       if parser.NumberError then ty := tx;
    357       result *= AffineMatrixScale(tx,ty);
    358     end else
    359     if compareText(kind,'rotate')=0 then
    360     begin
    361       angle := parser.ParseFloat;
    362       parser.SkipSymbol(',');
    363       tx := parser.ParseFloat;
    364       parser.SkipSymbol(',');
    365       ty := parser.ParseFloat;
    366       result *= AffineMatrixTranslation(tx,ty)*AffineMatrixRotationDeg(angle)*
    367                 AffineMatrixTranslation(-tx,-ty);
    368     end else
    369     if compareText(kind,'skewx')=0 then
    370     begin
    371       angle := parser.ParseFloat;
    372       result *= AffineMatrixSkewXDeg(angle);
    373     end else
    374     if compareText(kind,'skewy')=0 then
    375     begin
    376       angle := parser.ParseFloat;
    377       result *= AffineMatrixSkewYDeg(angle);
    378     end;
    379     parser.SkipUpToSymbol(')');
    380   end;
    381   parser.free;
    382   result[1,3] := Units.ConvertWidth(result[1,3],cuCustom,AUnit);
    383   result[2,3] := Units.ConvertHeight(result[2,3],cuCustom,AUnit);
    384 end;
    385 
    386 function TSVGElement.GetOpacity: single;
     955function TSVGElement.GetOrthoAttributeOrStyleWithUnit(AName: string;
     956  ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit;
     957begin
     958  result := GetHorizAttributeOrStyleWithUnit(AName,ADefault);
     959  //value will be inconsistent if scaling is inconsistent
     960end;
     961
     962function TSVGElement.GetStroke: string;
     963begin
     964  result := AttributeOrStyleDef['stroke','none'];
     965end;
     966
     967function TSVGElement.GetStrokeColor: TBGRAPixel;
     968begin
     969  result := StrToBGRA(stroke);
     970  result.alpha := round(result.alpha*strokeOpacity*opacity);
     971  if result.alpha = 0 then result := BGRAPixelTransparent;
     972end;
     973
     974function TSVGElement.GetStrokeLineCap: string;
     975begin
     976  result := AttributeOrStyleDef['stroke-linecap','butt'];
     977end;
     978
     979function TSVGElement.GetStrokeLineJoin: string;
     980begin
     981  result := AttributeOrStyleDef['stroke-linejoin','miter'];
     982end;
     983
     984function TSVGElement.GetStrokeMiterLimit: single;
    387985var errPos: integer;
    388986begin
    389   val(AttributeOrStyle['opacity'], result, errPos);
     987  val(AttributeOrStyleDef['stroke-miterlimit','4'], result, errPos);
     988  if errPos <> 0 then result := 4 else
     989    if result < 1 then result := 1;
     990end;
     991
     992function TSVGElement.GetStrokeOpacity: single;
     993var errPos: integer;
     994begin
     995  val(AttributeOrStyleDef['stroke-opacity','1'], result, errPos);
    390996  if errPos <> 0 then result := 1 else
    391997    if result < 0 then result := 0 else
     
    393999end;
    3941000
    395 function TSVGElement.GetOrthoAttributeOrStyleWithUnit(AName: string
    396   ): TFloatWithCSSUnit;
    397 begin
    398   result := GetHorizAttributeOrStyleWithUnit(AName);
    399   //value will be inconsistent if scaling is inconsistent
    400 end;
    401 
    402 function TSVGElement.GetStroke: string;
    403 begin
    404   result := AttributeOrStyle['stroke'];
    405 end;
    406 
    407 function TSVGElement.GetStrokeColor: TBGRAPixel;
    408 begin
    409   result := StrToBGRA(stroke);
    410   result.alpha := round(result.alpha*strokeOpacity*opacity);
    411   if result.alpha = 0 then result := BGRAPixelTransparent;
    412 end;
    413 
    414 function TSVGElement.GetStrokeLineCap: string;
    415 begin
    416   result := AttributeOrStyle['stroke-linecap'];
    417   if result = '' then result := 'butt';
    418 end;
    419 
    420 function TSVGElement.GetStrokeLineJoin: string;
    421 begin
    422   result := AttributeOrStyle['stroke-linejoin'];
    423   if result = '' then result := 'miter';
    424 end;
    425 
    426 function TSVGElement.GetStrokeMiterLimit: single;
    427 var errPos: integer;
    428 begin
    429   val(AttributeOrStyle['stroke-miterlimit'], result, errPos);
    430   if errPos <> 0 then result := 4 else
    431     if result < 1 then result := 1;
    432 end;
    433 
    434 function TSVGElement.GetStrokeOpacity: single;
    435 var errPos: integer;
    436 begin
    437   val(AttributeOrStyle['stroke-opacity'], result, errPos);
    438   if errPos <> 0 then result := 1 else
    439     if result < 0 then result := 0 else
    440       if result > 1 then result := 1;
    441 end;
    442 
    4431001function TSVGElement.GetStrokeWidth: TFloatWithCSSUnit;
    4441002begin
    445   result := OrthoAttributeOrStyleWithUnit['stroke-width'];
    446 end;
     1003  result := OrthoAttributeOrStyleWithUnit['stroke-width',FloatWithCSSUnit(1,cuCustom)];
     1004end;
     1005
     1006function TSVGElement.GetStrokeDashArray: string;
     1007begin
     1008  result := AttributeDef['stroke-dasharray','none'];
     1009end;
     1010
     1011function TSVGElement.GetStrokeDashArrayF: ArrayOfFloat;
     1012var
     1013  parser: TSVGParser;
     1014  nvalue,i: integer;
     1015  s_array: String;
     1016begin
     1017  s_array:= strokeDashArray;
     1018  if s_array = 'none' then
     1019  begin
     1020    setlength(Result,0);
     1021    exit;
     1022  end;
     1023  parser:=TSVGParser.Create(s_array);
     1024  nvalue := 0;
     1025  repeat
     1026    parser.ParseFloat;
     1027    if not parser.NumberError then
     1028      inc(nvalue);
     1029  until parser.NumberError or parser.Done;
     1030  parser.ClearError;
     1031  setlength(Result,nvalue);
     1032  parser.Position := 1;
     1033  for i := 0 to high(result) do
     1034    result[i] := parser.ParseFloat;
     1035  parser.Free;
     1036end;
     1037
     1038function TSVGElement.GetStrokeDashOffset: TFloatWithCSSUnit;
     1039begin
     1040  result := OrthoAttributeWithUnit['stroke-dashoffset'];
     1041end;   
     1042
     1043function TSVGElement.GetStyle(const AName,ADefault: string): string;
     1044
     1045  function GetInternal(const ruleset: string): string;
     1046  var
     1047    startPos, colonPos, valueLength: integer;
     1048  begin
     1049    LocateStyleDeclaration(ruleset, AName, startPos,colonPos, valueLength);
     1050    if valueLength <> -1 then
     1051      result := trim(copy(ruleset, colonPos+1, valueLength))
     1052    else
     1053      result := '';
     1054  end;
     1055
     1056var
     1057  i: integer;
     1058begin
     1059  result:= '';
     1060
     1061  //Find on <style> block (priority!)
     1062  //if "not search"..search
     1063  if findStyleState = fssNotSearch then
     1064    FindStyleElement;
     1065  //if "find"..use
     1066  if findStyleState <> fssNotFind then
     1067    for i:= Length(styleAttributes)-1 downto 0 do
     1068    begin
     1069      result:= GetInternal(styleAttributes[i].attr);
     1070      if result <> '' then
     1071        Break;
     1072    end;
     1073
     1074  if result = '' then
     1075    result:= GetInternal( Attribute['style',ADefault] );
     1076end;     
    4471077
    4481078function TSVGElement.GetStyle(const AName: string): string;
    449 var
    450     startPos, colonPos, valueLength: integer;
    451     ruleset: string;
    452 begin
    453   ruleset := Attribute['style'];
    454   LocateStyleDeclaration(ruleset, AName, startPos,colonPos, valueLength);
    455   if valueLength <> -1 then
    456   begin
    457     result := trim(copy(ruleset, colonPos+1, valueLength));
    458   end else
    459     result := '';
    460 end;
     1079begin
     1080  result:= GetStyle(AName,'');
     1081end;
    4611082
    4621083function TSVGElement.GetTransform: string;
     
    4701091end;
    4711092
     1093function TSVGElement.GetVerticalAttributeWithUnit(AName: string; ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit;
     1094begin
     1095  result := GetAttributeWithUnit(AName,ADefault);
     1096  if result.value <> EmptySingle then
     1097  begin
     1098    if result.CSSUnit <> cuCustom then
     1099      if units.DpiScaleY = 0 then
     1100        result.value := 0
     1101      else
     1102        result.value /= Units.DpiScaleY;
     1103  end;
     1104end;
     1105
    4721106function TSVGElement.GetVerticalAttributeWithUnit(AName: string): TFloatWithCSSUnit;
    4731107begin
    474   result := GetAttributeWithUnit(AName);
    475   if result.CSSUnit <> cuCustom then
    476     if units.DpiScaleY = 0 then
    477       result.value := 0
    478     else
    479       result.value /= Units.DpiScaleY;
    480 end;
     1108  result := GetVerticalAttributeWithUnit(AName,FloatWithCSSUnit(0,cuCustom));
     1109end; 
    4811110
    4821111function TSVGElement.GetDOMElement: TDOMElement;
     
    4841113  result := FDomElem;
    4851114end;
     1115
     1116function TSVGElement.GetID: string;
     1117begin
     1118  result := Attribute['id'];
     1119end;
     1120
     1121function TSVGElement.GetClassAt: string;
     1122begin
     1123  result := Attribute['class'];
     1124end; 
    4861125
    4871126procedure TSVGElement.SetAttribute(AName: string; AValue: string);
     
    5141153  RemoveStyle('fill-opacity');
    5151154end;
     1155
     1156procedure TSVGElement.SetFillRule(AValue: string);
     1157begin
     1158  Attribute['fill-rule'] := AValue;
     1159  RemoveStyle('fill-rule');
     1160end; 
    5161161
    5171162procedure TSVGElement.SetHorizAttributeWithUnit(AName: string;
     
    6131258end;
    6141259
     1260procedure TSVGElement.SetStrokeDashArray(AValue: string);
     1261begin
     1262  Attribute['stroke-dasharray'] := AValue;
     1263end;
     1264
     1265procedure TSVGElement.SetStrokeDashArrayF(AValue: ArrayOfFloat);
     1266var
     1267  s: string;
     1268  i: integer;
     1269begin
     1270  s:= '';
     1271  for i := 0 to high(AValue) do
     1272  begin
     1273    if s <> '' then s += ' ';
     1274    s += TCSSUnitConverter.formatValue(AValue[i])+' ';
     1275  end;
     1276  strokeDashArray := s;
     1277end;
     1278
     1279procedure TSVGElement.SetStrokeDashOffset(AValue: TFloatWithCSSUnit);
     1280begin
     1281  OrthoAttributeWithUnit['stroke-dashoffset'] := AValue;
     1282end;     
     1283
    6151284procedure TSVGElement.SetStyle(AName: string; AValue: string);
    6161285var
     
    6681337    SetHorizAttributeWithUnit(AName,AValue);
    6691338end;
     1339
     1340procedure TSVGElement.SetID(AValue: string);
     1341begin
     1342  Attribute['id'] := AValue;
     1343end;
     1344
     1345procedure TSVGElement.SetClassAt(AValue: string);
     1346begin
     1347  Attribute['class'] := AValue;
     1348end;
    6701349
    6711350procedure TSVGElement.Init(ADocument: TXMLDocument; ATag: string;
     
    7481427end;
    7491428
     1429procedure TSVGElement.ApplyFillStyle(ACanvas2D: TBGRACanvas2D; AUnit: TCSSUnit);
     1430begin
     1431  ACanvas2D.fillStyle(fillColor);
     1432
     1433  ACanvas2D.fillMode := TFillMode(fillMode);
     1434end;   
     1435
    7501436procedure TSVGElement.ApplyStrokeStyle(ACanvas2D: TBGRACanvas2D; AUnit: TCSSUnit);
     1437var
     1438  a: ArrayOfFloat;
     1439  lw: single;
     1440  i: Integer;
    7511441begin
    7521442  ACanvas2d.strokeStyle(strokeColor);
    753   ACanvas2d.lineWidth := Units.ConvertWidth(strokeWidth,AUnit).value;
     1443  lw := Units.ConvertWidth(strokeWidth,AUnit).value;
     1444  ACanvas2d.lineWidth := lw;
    7541445  ACanvas2d.lineCap := strokeLineCap;
    7551446  ACanvas2d.lineJoin := strokeLineJoin;
    7561447  ACanvas2d.miterLimit := strokeMiterLimit;
     1448 
     1449  a:= strokeDashArrayF;
     1450  if (Length(a) <> 0) and (lw > 0) then
     1451  begin
     1452    for i := 0 to high(a) do
     1453      a[i] /= lw;
     1454    ACanvas2d.lineStyle(a);
     1455  end
     1456  else
     1457    ACanvas2d.lineStyle(psSolid);
     1458end;
     1459
     1460procedure TSVGElement.Initialize;
     1461begin
     1462  SetLength(styleAttributes,0);
     1463  findStyleState   := fssNotSearch;
     1464  FDataParent      := nil;
     1465  FDataChildList   := TSVGElementList.Create;
    7571466end;
    7581467
    7591468constructor TSVGElement.Create(ADocument: TXMLDocument; AElement: TDOMElement;
    760   AUnits: TCSSUnitConverter);
    761 begin
     1469  AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink);
     1470begin
     1471  FDataLink:= ADataLink;
     1472  Initialize;
    7621473  Init(ADocument,AElement,AUnits);
    7631474end;
    7641475
    7651476constructor TSVGElement.Create(ADocument: TXMLDocument;
    766   AUnits: TCSSUnitConverter);
    767 begin
    768   raise exception.Create('Cannot create a generic element');
     1477  AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink);
     1478begin
     1479  FDataLink:= ADataLink;
     1480  Initialize;
     1481  //raise exception.Create('Cannot create a generic element');
     1482end;
     1483
     1484destructor TSVGElement.Destroy;
     1485begin
     1486  SetLength(styleAttributes,0);
     1487  FreeAndNil(FDataChildList);
     1488  inherited Destroy;
     1489end;
     1490
     1491procedure TSVGElement.Recompute;
     1492begin
     1493
    7691494end;
    7701495
     
    8091534end;
    8101535
     1536function TSVGElement.HasAttribute(AName: string): boolean;
     1537begin
     1538  result := FDomElem.hasAttribute(AName);
     1539end;
     1540
     1541function TSVGElement.fillMode: TSVGFillMode;
     1542begin
     1543  if fillRule = 'evenodd' then
     1544    result := sfmEvenOdd
     1545  else
     1546    result := sfmNonZero;
     1547end;
     1548
     1549function TSVGElement.DataChildList: TSVGElementList;
     1550begin
     1551   result:= FDataChildList;
     1552end;
     1553
     1554function TSVGElement.FindStyleElementInternal(const classStr: string;
     1555  out attributesStr: string): integer;
     1556var
     1557  i: integer;
     1558begin
     1559  attributesStr:= '';
     1560  with FDataLink do
     1561    for i:= 0 to StyleCount-1 do
     1562    begin
     1563      result:= (Styles[i] as TSVGStyle).Find(classStr);
     1564      if result <> -1 then
     1565      begin
     1566        attributesStr:= (Styles[i] as TSVGStyle).Styles[result].attribute;
     1567        Exit;
     1568      end;
     1569    end;
     1570  result:= -1;
     1571end;
     1572
     1573procedure TSVGElement.FindStyleElement;
     1574
     1575  procedure AddStyle(const s: string; const id: integer);
     1576  var
     1577    l: integer;
     1578  begin
     1579    findStyleState:= fssFind;
     1580    l:= Length(styleAttributes);
     1581    SetLength(styleAttributes,l+1);
     1582    with styleAttributes[l] do
     1583    begin
     1584     attr:= s;
     1585     pos:= id;
     1586    end;
     1587  end;
     1588
     1589var
     1590  fid: integer;
     1591  tag,styleC,s: string;
     1592begin
     1593  findStyleState:= fssNotFind;
     1594  SetLength(styleAttributes,0);
     1595  tag:= FDomElem.TagName;
     1596  styleC:= classAt;
     1597  (*
     1598    if style element is:
     1599    <style>
     1600     circle.test{fill:red; fill-opacity: 0.8;}
     1601     circle{fill:blue; fill-opacity: 0.4;}
     1602     circle.style1{fill:yellow;}
     1603    </style>
     1604    and circle declare:
     1605    <circle class = "style1" cx="160" cy="160" r="35" stroke="black" />
     1606
     1607    styleAttributes[0] = 'fill:blue; fill-opacity: 0.4;'
     1608    styleAttributes[1] = 'fill:yellow;'
     1609
     1610    fill-opacity for "style1" = 0.4 not default 1!
     1611  *)
     1612
     1613  //Find as: "[tag]" example "circle"
     1614  fid:= FindStyleElementInternal(tag,s);
     1615  if fid <> -1 then
     1616    AddStyle(s,fid);
     1617  if styleC <> '' then
     1618  begin
     1619    //Find as: "[tag].[class]" example "circle.style1"
     1620    fid:= FindStyleElementInternal(tag+'.'+styleC,s);
     1621    if fid <> -1 then
     1622      AddStyle(s,fid)
     1623    else
     1624    begin
     1625      //Find as: ".[class]" example ".style1"
     1626      fid:= FindStyleElementInternal('.'+styleC,s);
     1627      if fid <> -1 then
     1628        AddStyle(s,fid);
     1629    end;
     1630  end;
     1631end;     
     1632
    8111633end.
    8121634
  • GraphicTest/Packages/bgrabitmap/bgratext.pas

    r494 r521  
    88  {$DEFINE LCL_RENDERER_IS_FINE}
    99  {$DEFINE LCL_CLEARTYPE_RENDERER_IS_FINE}
     10  {$DEFINE RENDER_TEXT_ON_TBITMAP}
    1011{$ENDIF}
    1112{$IFDEF FREEBSD}
     
    1718  {$DEFINE RENDER_TEXT_ON_TBITMAP}
    1819{$ENDIF}
     20{$IFDEF WINDOWS}
     21  {$IFNDEF LEGACY_FONT_VERTICAL_OFFSET}
     22    {$DEFINE FIX_FONT_VERTICAL_OFFSET}
     23  {$ENDIF}
     24{$ENDIF}
    1925
    2026{
     
    3238
    3339uses
    34   Classes, Types, SysUtils, BGRAGraphics, BGRABitmapTypes, InterfaceBase, BGRAPen, BGRAGrayscaleMask;
     40  Classes, Types, SysUtils, BGRAGraphics, BGRABitmapTypes, InterfaceBase, BGRAPen, BGRAGrayscaleMask,
     41  LCLVersion;
    3542
    3643type
     
    4451    FWordBreakHandler: TWordBreakHandler;
    4552    procedure UpdateFont; virtual;
    46     function TextSizeNoUpdateFont(sUTF8: string): TSize;
    47     procedure InternalTextWordBreak(ADest: TBGRACustomBitmap; ATextUTF8: string; x, y, AMaxWidth: integer; AColor: TBGRAPixel; ATexture: IBGRAScanner; AHorizAlign: TAlignment; AVertAlign: TTextLayout);
     53    function InternalTextSize(sUTF8: string; AShowPrefix: boolean): TSize;
     54    procedure InternalTextWordBreak(ADest: TBGRACustomBitmap; ATextUTF8: string;
     55                                    x, y, AMaxWidth: integer; AColor: TBGRAPixel; ATexture: IBGRAScanner;
     56                                    AHorizAlign: TAlignment; AVertAlign: TTextLayout; ARightToLeft: boolean);
    4857    procedure InternalTextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; c: TBGRAPixel; ATexture: IBGRAScanner);
     58    procedure InternalTextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; c: TBGRAPixel; texture: IBGRAScanner;
     59                              align: TAlignment; AShowPrefix: boolean = false; ARightToLeft: boolean = false);
     60    procedure InternalTextOutEllipse(ADest: TBGRACustomBitmap; x, y, availableWidth: single; sUTF8: string; c: TBGRAPixel; texture: IBGRAScanner;
     61                              align: TAlignment; AShowPrefix: boolean = false; ARightToLeft: boolean = false);
     62    procedure InternalSplitText(var ATextUTF8: string; AMaxWidth: integer; out ARemainsUTF8: string; out ALineEndingBreak: boolean;
     63                                AWordBreak: TWordBreakHandler); overload;
     64    procedure InternalSplitText(var ATextUTF8: string; AMaxWidth: integer; out ARemainsUTF8: string;
     65                                AWordBreak: TWordBreakHandler); overload;
     66    procedure DefaultWorkBreakHandler(var ABeforeUTF8, AAfterUTF8: string);
    4967  public
    5068    procedure SplitText(var ATextUTF8: string; AMaxWidth: integer; out ARemainsUTF8: string);
    5169    function GetFontPixelMetric: TFontPixelMetric; override;
    52     procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; c: TBGRAPixel; align: TAlignment); override;
    53     procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; texture: IBGRAScanner; align: TAlignment); override;
    54     procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment); override;
    55     procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment); override;
    56     procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; c: TBGRAPixel); override;
    57     procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; texture: IBGRAScanner); override;
    58     procedure TextWordBreak(ADest: TBGRACustomBitmap; AText: string; x, y, AMaxWidth: integer; AColor: TBGRAPixel; AHorizAlign: TAlignment; AVertAlign: TTextLayout);
    59     procedure TextWordBreak(ADest: TBGRACustomBitmap; AText: string; x, y, AMaxWidth: integer; ATexture: IBGRAScanner; AHorizAlign: TAlignment; AVertAlign: TTextLayout);
     70    procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; c: TBGRAPixel; align: TAlignment); overload; override;
     71    procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; texture: IBGRAScanner; align: TAlignment); overload; override;
     72    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment); overload; override;
     73    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment); overload; override;
     74    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment; ARightToLeft: boolean); overload; override;
     75    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment; ARightToLeft: boolean); overload; override;
     76    procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; c: TBGRAPixel); overload; override;
     77    procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; texture: IBGRAScanner); overload; override;
     78    procedure TextWordBreak(ADest: TBGRACustomBitmap; AText: string; x, y, AMaxWidth: integer; AColor: TBGRAPixel; AHorizAlign: TAlignment; AVertAlign: TTextLayout; ARightToLeft: boolean = false); overload;
     79    procedure TextWordBreak(ADest: TBGRACustomBitmap; AText: string; x, y, AMaxWidth: integer; ATexture: IBGRAScanner; AHorizAlign: TAlignment; AVertAlign: TTextLayout; ARightToLeft: boolean = false); overload;
    6080    function TextSize(sUTF8: string): TSize; override;
     81    function TextSizeAngle(sUTF8: string; orientationTenthDegCCW: integer): TSize; override;
     82    function TextSize(sUTF8: string; AMaxWidth: integer; {%H-}ARightToLeft: boolean): TSize; override;
     83    function TextFitInfo(sUTF8: string; AMaxWidth: integer): integer; override;
    6184    constructor Create;
    6285    destructor Destroy; override;
     
    6790
    6891  TLCLFontRenderer = class(TCustomLCLFontRenderer)
    69   protected
    70     function TextSurfaceSmaller(sUTF8: string; ARect: TRect): boolean;
    71   public
    72     procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; c: TBGRAPixel); override;
    73     procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; texture: IBGRAScanner); override;
     92
    7493  end;
    7594
     
    7998
    8099procedure BGRATextOut(bmp: TBGRACustomBitmap; Font: TFont; Quality: TBGRAFontQuality; xf, yf: single; sUTF8: string;
    81   c: TBGRAPixel; tex: IBGRAScanner; align: TAlignment; CustomAntialiasingLevel: Integer = 0);
     100  c: TBGRAPixel; tex: IBGRAScanner; align: TAlignment; CustomAntialiasingLevel: Integer = 0;
     101  ShowPrefix: boolean = false; RightToLeft: boolean = false);
    82102
    83103procedure BGRATextOutAngle(bmp: TBGRACustomBitmap; Font: TFont; Quality: TBGRAFontQuality; xf, yf: single; orientationTenthDegCCW: integer;
    84104  sUTF8: string; c: TBGRAPixel; tex: IBGRAScanner; align: TAlignment; CustomAntialiasingLevel: Integer = 0);
    85105
    86 procedure BGRATextRect(bmp: TBGRACustomBitmap; Font: TFont; Quality: TBGRAFontQuality; ARect: TRect; x, y: integer;
     106procedure BGRATextRect(bmp: TBGRACustomBitmap; Font: TFont; Quality: TBGRAFontQuality; ARect: TRect; xf, yf: single;
    87107  sUTF8: string; style: TTextStyle; c: TBGRAPixel; tex: IBGRAScanner; CustomAntialiasingLevel: Integer = 0);
    88108
    89109function BGRATextSize(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer): TSize;
     110function BGRATextFitInfo(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer; AMaxWidth: integer): integer;
    90111function BGRAOriginalTextSize(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: integer): TSize;
    91 function BGRAOriginalTextSizeEx(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer; out actualAntialiasingLevel: integer): TSize;
     112function BGRAOriginalTextSizeEx(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer;
     113                                out actualAntialiasingLevel: integer; out extraVerticalMarginDueToRotation: integer): TSize;
    92114
    93115function BGRATextUnderline(ATopLeft: TPointF; AWidth: Single; AMetrics: TFontPixelMetric): ArrayOfTPointF; overload;
     
    101123function LCLFontAvailable: boolean;
    102124function GetFineClearTypeAuto: TBGRAFontQuality;
     125function FixLCLFontFullHeight({%H-}AFontName: string; AFontHeight: integer): integer;
    103126
    104127procedure BGRAFillClearTypeGrayscaleMask(dest: TBGRACustomBitmap; x,y: integer; xThird: integer; mask: TGrayscaleMask; color: TBGRAPixel; texture: IBGRAScanner = nil; RGBOrder: boolean=true);
     
    116139implementation
    117140
    118 uses GraphType, Math, BGRABlend, BGRAUTF8;
     141uses GraphType, Math, BGRABlend, BGRAUTF8, BGRAUnicode, BGRATextBidi
     142     {$IF lcl_fullversion >= 1070000}, lclplatformdef{$ENDIF};
    119143
    120144const MaxPixelMetricCount = 100;
     
    281305function GetLCLFontPixelMetric(AFont: TFont): TFontPixelMetric;
    282306var i,startPos,endPos: integer;
    283 begin
     307  prevHeight,fixHeight: integer;
     308begin
     309  if (AFont.Height < -200) or (AFont.Height > 150) then
     310  begin
     311    prevHeight := AFont.Height;
     312    if AFont.Height < 0 then
     313      fixHeight := -200
     314    else
     315      fixHeight := 150;
     316    AFont.Height := fixHeight;
     317    result := GetLCLFontPixelMetric(AFont);
     318    AFont.Height := prevHeight;
     319
     320    result.Baseline := round(result.Baseline/fixHeight*prevHeight);
     321    result.CapLine := round(result.CapLine/fixHeight*prevHeight);
     322    result.DescentLine := round(result.DescentLine/fixHeight*prevHeight);
     323    result.Lineheight := round(result.Lineheight/fixHeight*prevHeight);
     324    result.xLine := round(result.xLine/fixHeight*prevHeight);
     325    exit;
     326  end;
     327
    284328  FindPixelMetricPos(AFont,startPos,endPos);
    285329  for i := startPos to endPos-1 do
     
    428472        end else
    429473        if (green = 0) then break;
     474        bgra.Free;
    430475    lclBmp.Free;
    431476  end;
     
    433478  fqFineClearTypeComputed:= true;
    434479end;
     480
     481{$IFNDEF WINDOWS}
     482var LCLFontFullHeightRatio : array of record
     483                          FontName: string;
     484                          Ratio: single;
     485                        end;
     486{$ENDIF}
     487
     488function FixLCLFontFullHeight(AFontName: string; AFontHeight: integer): integer;
     489{$IFNDEF WINDOWS}
     490const TestHeight = 200;
     491var
     492  i: Integer;
     493  ratio : single;
     494  f: TFont;
     495  h: LongInt;
     496begin
     497  if (AFontHeight = 0) or
     498    (AFontHeight*FontEmHeightSign > 0) then
     499      result := AFontHeight
     500  else
     501  begin
     502    ratio := EmptySingle;
     503    for i := 0 to high(LCLFontFullHeightRatio) do
     504      if CompareText(AFontName, LCLFontFullHeightRatio[i].FontName)=0 then
     505      begin
     506        ratio := LCLFontFullHeightRatio[i].Ratio;
     507        break;
     508      end;
     509    if ratio = EmptySingle then
     510    begin
     511      f := TFont.Create;
     512      f.Quality := fqDefault;
     513      f.Name := AFontName;
     514      f.Height := FontFullHeightSign*TestHeight;
     515      h := BGRATextSize(f, fqSystem, 'Hg', 1).cy;
     516      if h = 0 then ratio := 1
     517      else ratio := TestHeight/h;
     518
     519      setlength(LCLFontFullHeightRatio, length(LCLFontFullHeightRatio)+1);
     520      LCLFontFullHeightRatio[high(LCLFontFullHeightRatio)].FontName:= AFontName;
     521      LCLFontFullHeightRatio[high(LCLFontFullHeightRatio)].Ratio:= ratio;
     522    end;
     523    result := round(AFontHeight*ratio);
     524  end;
     525end;
     526{$ELSE}
     527begin
     528  result := AFontHeight;
     529end;
     530{$ENDIF}
    435531
    436532function FontEmHeightSign: integer;
     
    469565end;
    470566
    471 function BGRAOriginalTextSizeEx(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer; out actualAntialiasingLevel: integer): TSize;
     567function BGRAOriginalTextSizeEx(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer;
     568  out actualAntialiasingLevel: integer; out extraVerticalMarginDueToRotation: integer): TSize;
    472569begin
    473570  actualAntialiasingLevel:= CustomAntialiasingLevel;
     571  extraVerticalMarginDueToRotation := 0;
    474572  if not LCLFontAvailable then
    475573    result := Size(0,0)
     
    490588      Result.cy := 0;
    491589      tempBmp.Canvas.Font.GetTextSize(sUTF8, Result.cx, Result.cy);
     590      if Font.Orientation <> 0 then
     591      begin
     592        tempBmp.Canvas.Font.Orientation:= 0;
     593        extraVerticalMarginDueToRotation := result.cy - tempBmp.Canvas.Font.GetTextHeight(sUTF8);
     594      end;
    492595    except
    493596      on ex: exception do
     
    501604end;
    502605
     606function BGRATextFitInfo(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string;
     607  CustomAntialiasingLevel: Integer; AMaxWidth: integer): integer;
     608var
     609  actualAntialiasingLevel: Integer;
     610begin
     611  if AMaxWidth = 0 then exit(0);
     612  actualAntialiasingLevel:= CustomAntialiasingLevel;
     613  if not LCLFontAvailable then
     614    result := 0
     615  else
     616  begin
     617    try
     618      if tempBmp = nil then tempBmp := TBitmap.Create;
     619      tempBmp.Canvas.Font := Font;
     620      if Quality in[fqFineClearTypeBGR,fqFineClearTypeRGB,fqFineAntialiasing] then
     621      begin
     622        tempBmp.Canvas.Font.Height := Font.Height*CustomAntialiasingLevel;
     623      end else
     624      begin
     625        tempBmp.Canvas.Font.Height := Font.Height;
     626        actualAntialiasingLevel:= 1;
     627      end;
     628      result := tempBmp.Canvas.TextFitInfo(sUTF8, AMaxWidth*actualAntialiasingLevel);
     629    except
     630      on ex: exception do
     631      begin
     632        result := 0;
     633        LCLFontDisabledValue := True;
     634      end;
     635    end;
     636
     637  end;
     638end;
     639
    503640function BGRAOriginalTextSize(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer): TSize;
    504 var actualAntialiasingLevel: integer;
    505 begin
    506   result := BGRAOriginalTextSizeEx(Font, Quality, sUTF8, CustomAntialiasingLevel, actualAntialiasingLevel);
     641var actualAntialiasingLevel, extraMargin: integer;
     642begin
     643  result := BGRAOriginalTextSizeEx(Font, Quality, sUTF8, CustomAntialiasingLevel, actualAntialiasingLevel, extraMargin);
     644  {$IFDEF FIX_FONT_VERTICAL_OFFSET}
     645  if extraMargin > 0 then result.cy -= extraMargin;
     646  {$ENDIF}
    507647end;
    508648
     
    515655    result.cy := ceil(Result.cy/CustomAntialiasingLevel);
    516656  end;
     657end;
     658
     659function RemovePrefix(sUTF8: string): string;
     660var i,resLen: integer;
     661begin
     662  setlength(result, length(sUTF8));
     663  resLen := 0;
     664  i := 1;
     665  while i <= length(sUTF8) do
     666  begin
     667    if sUTF8[i] = '&' then
     668    begin // double ('&&') indicate single char '&'
     669      if (i < length(sUTF8)) and (sUTF8[i+1] = '&') then
     670      begin
     671        inc(resLen);
     672        result[resLen] := '&';
     673        inc(i,2);
     674      end else
     675        // single indicate underline
     676        inc(i);
     677    end else
     678    begin
     679      inc(resLen);
     680      result[resLen] := sUTF8[i];
     681      inc(i);
     682    end;
     683  end;
     684  setlength(result,resLen);
    517685end;
    518686
     
    562730      grayscaleMask := TGrayscaleMask.Create(temp, cGreen);
    563731      FreeAndNil(temp);
     732      {$IFNDEF LINUX}
    564733      pb := grayscaleMask.Data;
    565734      for n := grayscaleMask.NbPixels - 1 downto 0 do
     
    568737        Inc(pb);
    569738      end;
     739      {$ENDIF}
    570740    end;
    571741  end;
     
    611781
    612782procedure BGRATextOut(bmp: TBGRACustomBitmap; Font: TFont; Quality: TBGRAFontQuality; xf, yf: single; sUTF8: string;
    613   c: TBGRAPixel; tex: IBGRAScanner; align: TAlignment; CustomAntialiasingLevel: Integer = 0);
     783  c: TBGRAPixel; tex: IBGRAScanner; align: TAlignment; CustomAntialiasingLevel: Integer = 0;
     784  ShowPrefix: boolean = false; RightToLeft: boolean = false);
    614785var
    615786  size: TSize;
    616   temp: TBGRACustomBitmap;
    617   {$IFDEF RENDER_TEXT_ON_TBITMAP}
    618   tempLCL: TBitmap;
    619   {$ENDIF}
    620   xMargin,xThird: integer;
    621   tempSize: TSize;
    622   subX,subY: integer;
    623   x,y :integer;
    624   deltaX: single;
    625   grayscale: TGrayscaleMask;
    626   sizeFactor: integer;
     787  sizeFactor, extraVerticalMargin: integer;
     788  xMarginF: single;
     789  style: TTextStyle;
     790  noPrefix: string;
    627791begin
    628792  if not LCLFontAvailable then exit;
     
    648812  {$ENDIF}
    649813
    650   size := BGRAOriginalTextSizeEx(Font,Quality,sUTF8,CustomAntialiasingLevel,sizeFactor);
     814  if ShowPrefix then
     815    noPrefix := RemovePrefix(sUTF8)
     816  else
     817    noPrefix := sUTF8;
     818
     819  size := BGRAOriginalTextSizeEx(Font,Quality,noPrefix,CustomAntialiasingLevel,sizeFactor,extraVerticalMargin);
    651820  if (size.cx = 0) or (size.cy = 0) then
    652821    exit;
     
    654823  if (size.cy >= 144) and (Quality in[fqFineAntialiasing,fqFineClearTypeBGR,fqFineClearTypeRGB]) and (CustomAntialiasingLevel > 4) then
    655824  begin
    656     BGRATextOut(bmp,Font,Quality,xf,yf,sUTF8,c,tex,align,4);
    657     exit;
     825    CustomAntialiasingLevel:= 4;
     826    size := BGRAOriginalTextSizeEx(Font,Quality,noPrefix,CustomAntialiasingLevel,sizeFactor,extraVerticalMargin);
    658827  end;
    659828
     
    664833  end;
    665834
    666   x := round(xf);
    667   y := round(yf);
    668 
    669   xThird := 0;
    670   tempSize.cx := size.cx;
    671   tempSize.cy := size.cy;
    672   if sizeFactor <> 1 then
    673   begin
    674     tempSize.cx += sizeFactor-1;
    675     tempSize.cx -= tempSize.cx mod sizeFactor;
    676     tempSize.cy += sizeFactor-1;
    677     tempSize.cy -= tempSize.cy mod sizeFactor;
    678 
    679     deltaX := xf-floor(xf);
    680     if Quality in [fqFineClearTypeBGR,fqFineClearTypeRGB] then
    681     begin
    682       xThird := floor(deltaX*3) mod 3;
    683       deltaX -= xThird/3;
    684     end;
    685     subX := round(sizeFactor*deltaX);
    686     x := round(floor(xf));
    687     if subX <> 0 then inc(tempSize.cx, sizeFactor);
    688     subY := round(sizeFactor*(yf-floor(yf)));
    689     y := round(floor(yf));
    690     if subY <> 0 then inc(tempSize.cy, sizeFactor);
    691   end else
    692   begin
    693     subX := 0;
    694     subY := 0;
    695   end;
    696 
    697   xMargin := size.cy div 2;
    698   if sizeFactor <> 1 then
    699   begin
    700     xMargin += sizeFactor-1;
    701     xMargin -= xMargin mod sizeFactor;
    702   end;
    703   tempSize.cx += xMargin*2;
    704 
    705   {$IFDEF RENDER_TEXT_ON_TBITMAP}
    706   tempLCL := TBitmap.Create;
    707   tempLCL.Width := tempSize.cx;
    708   tempLCL.Height := tempSize.cy;
    709   tempLCL.Canvas.Brush.Color := clBlack;
    710   tempLCL.Canvas.FillRect(0,0,tempLCL.Width,tempLCL.Height);
    711   with tempLCL do begin
    712   {$ELSE}
    713   temp := bmp.NewBitmap(tempSize.cx, tempSize.cy, BGRABlack);
    714   with temp do begin
    715   {$ENDIF}
    716     Canvas.Font := Font;
    717     Canvas.Font.Height := Font.Height*sizeFactor;
    718     Canvas.Font.Color := clWhite;
    719     Canvas.Brush.Style := bsClear;
    720     Canvas.TextOut(xMargin+subX, subY, sUTF8);
    721   end;
    722   {$IFDEF RENDER_TEXT_ON_TBITMAP}
    723   temp := BGRABitmapFactory.create(tempLCL,False);
    724   tempLCL.Free;
    725   {$ENDIF}
    726 
    727   FilterOriginalText(Quality,CustomAntialiasingLevel, temp, grayscale);
    728   dec(x,round(xMargin/sizeFactor));
    729   BGRAInternalRenderText(bmp, Quality, grayscale,temp, x,y,xThird, c,tex);
    730   if temp <> nil then temp.Free;
    731   if grayscale <> nil then grayscale.Free;
     835  xMarginF := size.cy/sizeFactor;
     836  fillchar({%H-}style,sizeof(style),0);
     837  style.SingleLine := true;
     838  style.Alignment := taLeftJustify;
     839  style.Layout := tlTop;
     840  style.RightToLeft := RightToLeft;
     841  style.ShowPrefix := ShowPrefix;
     842  BGRATextRect(bmp, Font, Quality,
     843        rect(floor(xf-xMarginF), floor(yf), ceil(xf+size.cx/sizeFactor+xMarginF), ceil(yf+size.cy/sizeFactor)),
     844        xf,yf, sUTF8, style, c, tex, sizeFactor);
    732845end;
    733846
     
    740853  size: TSize;
    741854  temp: TBGRACustomBitmap;
    742   TopRight,BottomRight,BottomLeft: TPointF;
    743   Top: Single;
     855  TopLeft,TopRight,BottomRight,BottomLeft: TPointF;
     856  Top,dy: Single;
    744857  Left: Single;
    745858  cosA,sinA: single;
    746859  rotBounds: TRect;
    747   sizeFactor: integer;
     860  sizeFactor, extraVerticalMargin: integer;
    748861  TempFont: TFont;
    749862  oldOrientation: integer;
     
    781894  TempFont.Orientation := orientationTenthDegCCW;
    782895  TempFont.Height := Font.Height;
    783   size := BGRAOriginalTextSizeEx(TempFont,Quality,sUTF8,CustomAntialiasingLevel,sizeFactor);
     896  size := BGRAOriginalTextSizeEx(TempFont,Quality,sUTF8,CustomAntialiasingLevel,sizeFactor, extraVerticalMargin);
    784897  if (size.cx = 0) or (size.cy = 0) then
    785898  begin
     
    787900    exit;
    788901  end;
     902  {$IFDEF FIX_FONT_VERTICAL_OFFSET}
     903  if extraVerticalMargin > 0 then
     904    dy := -extraVerticalMargin*0.5 -1
     905  else
     906    dy := 0;
     907  {$ELSE}
     908  dy := 0;
     909  {$ENDIF}
    789910  tempFont.Free;
    790911
    791912  cosA := cos(orientationTenthDegCCW*Pi/1800);
    792913  sinA := sin(orientationTenthDegCCW*Pi/1800);
    793   TopRight := PointF(cosA*size.cx,-sinA*size.cx);
    794   BottomRight := PointF(cosA*size.cx+sinA*size.cy,cosA*size.cy-sinA*size.cx);
    795   BottomLeft := PointF(sinA*size.cy,cosA*size.cy);
     914  TopLeft := PointF(sinA*dy,cosA*dy);
     915  xf += TopLeft.x/sizeFactor;
     916  yf += TopLeft.y/sizeFactor;
     917  TopRight := TopLeft + PointF(cosA*size.cx,-sinA*size.cx);
     918  BottomRight := TopRight + PointF(sinA*size.cy,cosA*size.cy);
     919  BottomLeft := TopLeft + PointF(sinA*size.cy,cosA*size.cy);
    796920  rotBounds := rect(0,0,0,0);
    797921  Top := 0;
     
    854978end;
    855979
    856 procedure BGRATextRect(bmp: TBGRACustomBitmap; Font: TFont; Quality: TBGRAFontQuality; ARect: TRect; x, y: integer;
     980procedure BGRATextRect(bmp: TBGRACustomBitmap; Font: TFont; Quality: TBGRAFontQuality; ARect: TRect; xf, yf: single;
    857981  sUTF8: string; style: TTextStyle; c: TBGRAPixel; tex: IBGRAScanner; CustomAntialiasingLevel: Integer = 0);
    858982var
     
    9201044    Canvas.Font.Color := clWhite;
    9211045    Canvas.Brush.Style := bsClear;
    922     Canvas.TextRect(rect(lim.Left-ARect.Left, lim.Top-ARect.Top, (ARect.Right-ARect.Left)*sizeFactor, (ARect.Bottom-ARect.Top)*sizeFactor), (x - lim.Left)*sizeFactor, (y - lim.Top)*sizeFactor, sUTF8, style);
     1046    Canvas.TextRect(rect(lim.Left-ARect.Left, lim.Top-ARect.Top,
     1047                         (ARect.Right-ARect.Left)*sizeFactor, (ARect.Bottom-ARect.Top)*sizeFactor),
     1048                         round((xf - lim.Left)*sizeFactor), round((yf - lim.Top)*sizeFactor), sUTF8, style);
    9231049  end;
    9241050  {$IFDEF RENDER_TEXT_ON_TBITMAP}
     
    9331059end;
    9341060
    935 { TLCLFontRenderer }
    936 
    937 function TLCLFontRenderer.TextSurfaceSmaller(sUTF8: string; ARect: TRect): boolean;
    938 begin
    939   with TextSize(sUTF8) do
    940     result := cx*cy < (ARect.Right-ARect.Left)*(ARect.Bottom-ARect.Top);
    941 end;
    942 
    943 procedure TLCLFontRenderer.TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x,
    944   y: integer; sUTF8: string; style: TTextStyle; c: TBGRAPixel);
    945 begin
    946   if not style.Clipping or TextSurfaceSmaller(sUTF8,ARect) then
    947   begin
    948     InternalTextRect(ADest,ARect,x,y,sUTF8,style,c,nil);
    949     exit;
    950   end;
    951   UpdateFont;
    952   BGRAText.BGRATextRect(ADest,FFont,FontQuality,ARect,x,y,sUTF8,style,c,nil);
    953 end;
    954 
    955 procedure TLCLFontRenderer.TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x,
    956   y: integer; sUTF8: string; style: TTextStyle; texture: IBGRAScanner);
    957 begin
    958   if not style.Clipping or TextSurfaceSmaller(sUTF8,ARect) then
    959   begin
    960     InternalTextRect(ADest,ARect,x,y,sUTF8,style,BGRAPixelTransparent,texture);
    961     exit;
    962   end;
    963   UpdateFont;
    964   BGRAText.BGRATextRect(ADest,FFont,FontQuality,ARect,x,y,sUTF8,style,BGRAPixelTransparent,texture);
    965 end;
    966 
    9671061{ TCustomLCLFontRenderer }
    9681062
    9691063{ Update font properties to internal TFont object }
    9701064procedure TCustomLCLFontRenderer.UpdateFont;
     1065var fixedHeight: integer;
    9711066begin
    9721067  if FFont.Name <> FontName then
     
    9741069  if FFont.Style <> FontStyle then
    9751070    FFont.Style := FontStyle;
    976   if FFont.Height <> FontEmHeight * FontEmHeightSign then
    977     FFont.Height := FontEmHeight * FontEmHeightSign;
     1071  if FontEmHeight < 0 then
     1072    fixedHeight := FixLCLFontFullHeight(FontName, FontEmHeight * FontEmHeightSign)
     1073  else
     1074    fixedHeight := FontEmHeight * FontEmHeightSign;
     1075  if FFont.Height <> fixedHeight then
     1076    FFont.Height := fixedHeight;
    9781077  if FFont.Orientation <> FontOrientation then
    9791078    FFont.Orientation := FontOrientation;
     
    9841083end;
    9851084
    986 function TCustomLCLFontRenderer.TextSizeNoUpdateFont(sUTF8: string): TSize;
    987 begin
     1085function TCustomLCLFontRenderer.InternalTextSize(sUTF8: string; AShowPrefix: boolean): TSize;
     1086begin
     1087  if AShowPrefix then sUTF8 := RemovePrefix(sUTF8);
    9881088  result := BGRAText.BGRATextSize(FFont,FontQuality,sUTF8,FontAntialiasingLevel);
    9891089  if (result.cy >= 24) and (FontQuality in[fqFineAntialiasing,fqFineClearTypeBGR,fqFineClearTypeRGB]) then
     
    9931093procedure TCustomLCLFontRenderer.SplitText(var ATextUTF8: string;
    9941094  AMaxWidth: integer; out ARemainsUTF8: string);
    995 var p,totalWidth: integer;
    996 begin
    997   if ATextUTF8= '' then
    998   begin
    999     ARemainsUTF8 := '';
    1000     exit;
    1001   end;
    1002   if RemoveLineEnding(ATextUTF8,1) then
    1003   begin
    1004     ARemainsUTF8:= ATextUTF8;
    1005     ATextUTF8 := '';
    1006     exit;
    1007   end;
     1095var WordBreakHandler: TWordBreakHandler;
     1096begin
    10081097  UpdateFont;
    1009 
    1010   p := 1;
    1011   inc(p, UTF8CharacterLength(@ATextUTF8[p])); //UTF8 chars may be more than 1 byte long
    1012   while p < length(ATextUTF8)+1 do
    1013   begin
    1014     if RemoveLineEnding(ATextUTF8,p) then
    1015     begin
    1016       ARemainsUTF8:= copy(ATextUTF8,p,length(ATextUTF8)-p+1);
    1017       ATextUTF8 := copy(ATextUTF8,1,p-1);
    1018       exit;
    1019     end;
    1020     totalWidth := TextSizeNoUpdateFont(copy(ATextUTF8,1,p+UTF8CharacterLength(@ATextUTF8[p])-1)).cx; //copy whole last UTF8 char
    1021     if totalWidth > AMaxWidth then
    1022     begin
    1023       ARemainsUTF8:= copy(ATextUTF8,p,length(ATextUTF8)-p+1);
    1024       ATextUTF8 := copy(ATextUTF8,1,p-1); //this includes the whole last UTF8 char
    1025       if Assigned(FWordBreakHandler) then
    1026         FWordBreakHandler(ATextUTF8,ARemainsUTF8) else
    1027           BGRADefaultWordBreakHandler(ATextUTF8,ARemainsUTF8);
    1028       exit;
    1029     end;
    1030     inc(p, UTF8CharacterLength(@ATextUTF8[p]));
    1031   end;
    1032   ARemainsUTF8 := '';
     1098  if Assigned(FWordBreakHandler) then
     1099    WordBreakHandler := FWordBreakHandler
     1100  else
     1101    WordBreakHandler := @DefaultWorkBreakHandler;
     1102
     1103  InternalSplitText(ATextUTF8, AMaxWidth, ARemainsUTF8, WordBreakHandler);
    10331104end;
    10341105
     
    10701141procedure TCustomLCLFontRenderer.TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string;
    10711142  texture: IBGRAScanner; align: TAlignment);
    1072 var mode : TBGRATextOutImproveReadabilityMode;
    10731143begin
    10741144  UpdateFont;
    1075 
    1076   if Assigned(BGRATextOutImproveReadabilityProc) and (FontQuality in[fqFineAntialiasing,fqFineClearTypeBGR,fqFineClearTypeRGB]) and (FFont.Orientation mod 3600 = 0) then
    1077   begin
    1078     case FontQuality of
    1079       fqFineClearTypeBGR: mode := irClearTypeBGR;
    1080       fqFineClearTypeRGB: mode := irClearTypeRGB;
    1081     else
    1082       mode := irNormal;
    1083     end;
    1084     BGRATextOutImproveReadabilityProc(ADest,FFont,x,y,sUTF8,BGRAPixelTransparent,texture,align,mode);
    1085   end else
    1086     BGRAText.BGRATextOut(ADest,FFont,FontQuality,x,y,sUTF8,BGRAPixelTransparent,texture,align);
     1145  InternalTextOut(ADest, x,y, sUTF8, BGRAPixelTransparent,texture, align);
    10871146end;
    10881147
    10891148procedure TCustomLCLFontRenderer.TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; c: TBGRAPixel;
    10901149  align: TAlignment);
    1091 var mode : TBGRATextOutImproveReadabilityMode;
    10921150begin
    10931151  UpdateFont;
    1094 
    1095   if Assigned(BGRATextOutImproveReadabilityProc) and (FontQuality in[fqFineAntialiasing,fqFineClearTypeBGR,fqFineClearTypeRGB]) and (FFont.Orientation mod 3600 = 0) then
    1096   begin
    1097     case FontQuality of
    1098       fqFineClearTypeBGR: mode := irClearTypeBGR;
    1099       fqFineClearTypeRGB: mode := irClearTypeRGB;
    1100     else
    1101       mode := irNormal;
    1102     end;
    1103     BGRATextOutImproveReadabilityProc(ADest,FFont,x,y,sUTF8,c,nil,align,mode);
    1104   end else
    1105     BGRAText.BGRATextOut(ADest,FFont,FontQuality,x,y,sUTF8,c,nil,align);
     1152  InternalTextOut(ADest, x,y, sUTF8, c,nil, align);
     1153end;
     1154
     1155procedure TCustomLCLFontRenderer.TextOut(ADest: TBGRACustomBitmap; x,
     1156  y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment;
     1157  ARightToLeft: boolean);
     1158begin
     1159  UpdateFont;
     1160  InternalTextOut(ADest, x,y, sUTF8, BGRAPixelTransparent,texture, align,
     1161                False, ARightToLeft);
     1162end;
     1163
     1164procedure TCustomLCLFontRenderer.TextOut(ADest: TBGRACustomBitmap; x,
     1165  y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment;
     1166  ARightToLeft: boolean);
     1167begin
     1168  UpdateFont;
     1169  InternalTextOut(ADest, x,y, sUTF8, c,nil, align, false, ARightToLeft);
    11061170end;
    11071171
     
    11091173  style: TTextStyle; c: TBGRAPixel);
    11101174begin
     1175  UpdateFont;
    11111176  InternalTextRect(ADest,ARect,x,y,sUTF8,style,c,nil);
    11121177end;
     
    11151180  style: TTextStyle; texture: IBGRAScanner);
    11161181begin
     1182  UpdateFont;
    11171183  InternalTextRect(ADest,ARect,x,y,sUTF8,style,BGRAPixelTransparent,texture);
    11181184end;
     
    11201186procedure TCustomLCLFontRenderer.TextWordBreak(ADest: TBGRACustomBitmap;
    11211187  AText: string; x, y, AMaxWidth: integer; AColor: TBGRAPixel;
    1122   AHorizAlign: TAlignment; AVertAlign: TTextLayout);
    1123 begin
    1124   InternalTextWordBreak(ADest,AText,x,y,AMaxWidth,AColor,nil,AHorizAlign,AVertAlign);
     1188  AHorizAlign: TAlignment; AVertAlign: TTextLayout; ARightToLeft: boolean);
     1189begin
     1190  UpdateFont;
     1191  InternalTextWordBreak(ADest,AText,x,y,AMaxWidth,AColor,nil,AHorizAlign,AVertAlign,ARightToLeft);
    11251192end;
    11261193
    11271194procedure TCustomLCLFontRenderer.TextWordBreak(ADest: TBGRACustomBitmap;
    11281195  AText: string; x, y, AMaxWidth: integer; ATexture: IBGRAScanner;
    1129   AHorizAlign: TAlignment; AVertAlign: TTextLayout);
    1130 begin
    1131   InternalTextWordBreak(ADest,AText,x,y,AMaxWidth,BGRAPixelTransparent,ATexture,AHorizAlign,AVertAlign);
     1196  AHorizAlign: TAlignment; AVertAlign: TTextLayout; ARightToLeft: boolean);
     1197begin
     1198  UpdateFont;
     1199  InternalTextWordBreak(ADest,AText,x,y,AMaxWidth,BGRAPixelTransparent,ATexture,AHorizAlign,AVertAlign,ARightToLeft);
    11321200end;
    11331201
    11341202procedure TCustomLCLFontRenderer.InternalTextWordBreak(
    11351203  ADest: TBGRACustomBitmap; ATextUTF8: string; x, y, AMaxWidth: integer;
    1136   AColor: TBGRAPixel; ATexture: IBGRAScanner; AHorizAlign: TAlignment; AVertAlign: TTextLayout);
    1137 var ARemains: string;
     1204  AColor: TBGRAPixel; ATexture: IBGRAScanner; AHorizAlign: TAlignment;
     1205  AVertAlign: TTextLayout; ARightToLeft: boolean);
     1206var remains, part, curText,nextText: string;
    11381207  stepX,stepY: integer;
    11391208  lines: TStringList;
    11401209  i: integer;
    11411210  lineShift: single;
     1211  WordBreakHandler: TWordBreakHandler;
     1212  lineEndingBreak: boolean;
     1213  bidiLayout: TBidiTextLayout;
     1214  bidiAlign: TBidiTextAlignment;
    11421215begin
    11431216  if (ATextUTF8 = '') or (AMaxWidth <= 0) then exit;
     1217
     1218  if Assigned(FWordBreakHandler) then
     1219    WordBreakHandler := FWordBreakHandler
     1220  else
     1221    WordBreakHandler := @DefaultWorkBreakHandler;
     1222
     1223  if ContainsBidiIsolateOrFormattingUTF8(ATextUTF8) then
     1224  begin
     1225    bidiLayout := TBidiTextLayout.Create(self, ATextUTF8, ARightToLeft);
     1226    bidiLayout.WordBreakHandler:= WordBreakHandler;
     1227    bidiLayout.AvailableWidth := AMaxWidth;
     1228    case AHorizAlign of
     1229      taLeftJustify: bidiAlign:= btaLeftJustify;
     1230      taRightJustify: begin
     1231        bidiAlign:= btaRightJustify;
     1232        x -= AMaxWidth;
     1233      end
     1234      else
     1235      begin
     1236        bidiAlign:= btaCenter;
     1237        x -= AMaxWidth div 2;
     1238      end;
     1239    end;
     1240    for i := 0 to bidiLayout.ParagraphCount-1 do
     1241      bidiLayout.ParagraphAlignment[i] := bidiAlign;
     1242    case AVertAlign of
     1243      tlBottom: bidiLayout.TopLeft := PointF(x, y - bidiLayout.TotalTextHeight);
     1244      tlCenter: bidiLayout.TopLeft := PointF(x, y - bidiLayout.TotalTextHeight/2);
     1245    end;
     1246    if ATexture <> nil then bidiLayout.DrawText(ADest, ATexture)
     1247    else bidiLayout.DrawText(ADest, AColor);
     1248    bidiLayout.Free;
     1249    exit;
     1250  end;
    11441251
    11451252  stepX := 0;
    11461253  stepY := TextSize('Hg').cy;
    11471254
    1148   if AVertAlign = tlTop then
    1149   begin
    1150     repeat
    1151       SplitText(ATextUTF8, AMaxWidth, ARemains);
    1152       if ATexture <> nil then
    1153         TextOut(ADest,x,y,ATextUTF8,ATexture,AHorizAlign)
    1154       else
    1155         TextOut(ADest,x,y,ATextUTF8,AColor,AHorizAlign);
    1156       ATextUTF8 := ARemains;
    1157       X+= stepX;
    1158       Y+= stepY;
    1159     until ARemains = '';
    1160   end else
    1161   begin
    1162     lines := TStringList.Create;
    1163     repeat
    1164       SplitText(ATextUTF8, AMaxWidth, ARemains);
    1165       lines.Add(ATextUTF8);
    1166       ATextUTF8 := ARemains;
    1167     until ARemains = '';
    1168     if AVertAlign = tlCenter then lineShift := lines.Count/2
    1169     else if AVertAlign = tlBottom then lineShift := lines.Count
    1170     else lineShift := 0;
    1171 
    1172     X -= round(stepX*lineShift);
    1173     Y -= round(stepY*lineShift);
    1174     for i := 0 to lines.Count-1 do
    1175     begin
    1176       if ATexture <> nil then
    1177         TextOut(ADest,x,y,lines[i],ATexture,AHorizAlign)
    1178       else
    1179         TextOut(ADest,x,y,lines[i],AColor,AHorizAlign);
    1180       X+= stepX;
    1181       Y+= stepY;
    1182     end;
    1183     lines.Free;
    1184   end;
     1255  lines := TStringList.Create;
     1256  curText := ATextUTF8;
     1257  repeat
     1258    InternalSplitText(curText, AMaxWidth, remains, lineEndingBreak, WordBreakHandler);
     1259    part := curText;
     1260    if not lineEndingBreak then
     1261      // append following direction to part
     1262      case GetFirstStrongBidiClassUTF8(remains) of
     1263        ubcLeftToRight: if ARightToLeft then part += UnicodeCharToUTF8($200E);
     1264        ubcRightToLeft,ubcArabicLetter: if not ARightToLeft then part += UnicodeCharToUTF8($200F);
     1265      end;
     1266    lines.Add(part);
     1267    // prefix next part with previous direction
     1268    nextText := remains;
     1269    if not lineEndingBreak then
     1270      case GetLastStrongBidiClassUTF8(curText) of
     1271        ubcLeftToRight: if ARightToLeft then nextText := UnicodeCharToUTF8($200E) + nextText;
     1272        ubcRightToLeft,ubcArabicLetter: if not ARightToLeft then nextText := UnicodeCharToUTF8($200F) + nextText;
     1273      end;
     1274    curText := nextText;
     1275  until remains = '';
     1276  if AVertAlign = tlCenter then lineShift := lines.Count/2
     1277  else if AVertAlign = tlBottom then lineShift := lines.Count
     1278  else lineShift := 0;
     1279
     1280  X -= round(stepX*lineShift);
     1281  Y -= round(stepY*lineShift);
     1282  for i := 0 to lines.Count-1 do
     1283  begin
     1284    InternalTextOut(ADest,x,y,lines[i],AColor,ATexture,AHorizAlign,false,ARightToLeft);
     1285    X+= stepX;
     1286    Y+= stepY;
     1287  end;
     1288  lines.Free;
    11851289end;
    11861290
     
    11901294var
    11911295  previousClip, intersected: TRect;
    1192   oldOrientation: integer;
     1296  lines: TStringList;
     1297  iStart,i,h: integer;
     1298  availableWidth: integer;
    11931299begin
    11941300  previousClip := ADest.ClipRect;
     
    11991305    ADest.ClipRect := intersected;
    12001306  end;
    1201   oldOrientation:= FontOrientation;
    1202   FontOrientation:= 0;
     1307  FFont.Orientation := 0;
     1308  if style.SystemFont then FFont.Name := 'default';
    12031309
    12041310  if not (style.Alignment in[taCenter,taRightJustify]) then ARect.Left := x;
    12051311  if not (style.Layout in[tlCenter,tlBottom]) then ARect.top := y;
    1206   if ARect.Right <= ARect.Left then exit;
     1312  if (ARect.Right <= ARect.Left) and style.Clipping then
     1313  begin
     1314    ADest.ClipRect := previousClip;
     1315    exit;
     1316  end;
    12071317  if style.Layout = tlCenter then Y := (ARect.Top+ARect.Bottom) div 2 else
    12081318  if style.Layout = tlBottom then Y := ARect.Bottom else
     
    12121322    X := ARect.Left;
    12131323  if style.Wordbreak then
    1214     InternalTextWordBreak(ADest,sUTF8,X,Y,ARect.Right-ARect.Left,c,ATexture,style.Alignment,style.Layout)
     1324  begin
     1325    if style.ShowPrefix then sUTF8 := RemovePrefix(sUTF8); //prefix not handled
     1326    InternalTextWordBreak(ADest,sUTF8,X,Y,ARect.Right-ARect.Left,c,ATexture,
     1327        style.Alignment,style.Layout,style.RightToLeft);
     1328  end
    12151329  else
    12161330  begin
    1217     if style.Layout = tlCenter then Y -= TextSize(sUTF8).cy div 2;
    1218     if style.Layout = tlBottom then Y -= TextSize(sUTF8).cy;
    1219     if ATexture <> nil then
    1220       TextOut(ADest,X,Y,sUTF8,ATexture,style.Alignment)
     1331    lines := nil;
     1332    iStart := 1;
     1333
     1334    if not style.SingleLine then
     1335    begin
     1336      i := iStart;
     1337      while i <= length(sUTF8) do
     1338      begin
     1339        if sUTF8[i] in[#13,#10] then
     1340        begin
     1341          if not assigned(lines) then lines := TStringList.Create;
     1342          lines.add(copy(sUTF8,iStart,i-iStart));
     1343          if (sUTF8[i]=#13) and (i < length(sUTF8)) and (sUTF8[i+1]=#10) then inc(i);
     1344          iStart := i+1
     1345        end;
     1346        inc(i);
     1347      end;
     1348    end;
     1349
     1350    if style.Alignment = taLeftJustify then
     1351      availableWidth := ARect.Right-X
    12211352    else
    1222       TextOut(ADest,X,Y,sUTF8,c,style.Alignment);
    1223   end;
    1224 
    1225   FontOrientation:= oldOrientation;
     1353      availableWidth := ARect.Right-ARect.Left;
     1354    if availableWidth < 0 then availableWidth:= 0;
     1355
     1356    if lines = nil then //only one line
     1357    begin
     1358      if style.Layout = tlCenter then Y -= InternalTextSize(sUTF8,style.ShowPrefix).cy div 2;
     1359      if style.Layout = tlBottom then Y -= InternalTextSize(sUTF8,style.ShowPrefix).cy;
     1360      if style.EndEllipsis then
     1361        InternalTextOutEllipse(ADest,X,Y,availableWidth,sUTF8,c,ATexture,style.Alignment,
     1362                        style.ShowPrefix,style.RightToLeft)
     1363      else
     1364        InternalTextOut(ADest,X,Y,sUTF8,c,ATexture,style.Alignment,
     1365                        style.ShowPrefix,style.RightToLeft);
     1366    end else
     1367    begin    //multiple lines
     1368      lines.add(copy(sUTF8, iStart, length(sUTF8)-iStart+1));
     1369      h := InternalTextSize('Hg',False).cy;
     1370      if style.Layout = tlCenter then Y -= h*lines.Count div 2;
     1371      if style.Layout = tlBottom then Y -= h*lines.Count;
     1372      for i := 0 to lines.Count-1 do
     1373      begin
     1374        if style.EndEllipsis then
     1375          InternalTextOutEllipse(ADest,X,Y,availableWidth,lines[i],c,ATexture,style.Alignment,
     1376                          style.ShowPrefix,style.RightToLeft)
     1377        else
     1378          InternalTextOut(ADest,X,Y,lines[i],c,ATexture,style.Alignment,
     1379                          style.ShowPrefix,style.RightToLeft);
     1380        inc(Y,h);
     1381      end;
     1382      lines.Free;
     1383    end;
     1384
     1385  end;
     1386
    12261387  if style.Clipping then
    12271388    ADest.ClipRect := previousClip;
     1389end;
     1390
     1391procedure TCustomLCLFontRenderer.InternalTextOut(ADest: TBGRACustomBitmap; x,
     1392  y: single; sUTF8: string; c: TBGRAPixel; texture: IBGRAScanner;
     1393  align: TAlignment; AShowPrefix: boolean = false; ARightToLeft: boolean = false);
     1394var mode : TBGRATextOutImproveReadabilityMode;
     1395begin
     1396  {$IFDEF LINUX}
     1397  //help LCL detect the correct direction
     1398  case GetFirstStrongBidiClassUTF8(sUTF8) of
     1399    ubcRightToLeft, ubcArabicLetter: if not ARightToLeft then sUTF8 := UnicodeCharToUTF8($200E) + sUTF8;
     1400    else
     1401      begin //suppose left-to-right
     1402        if ARightToLeft then sUTF8 := UnicodeCharToUTF8($200F) + sUTF8;
     1403      end;
     1404  end;
     1405  {$ENDIF}
     1406  if Assigned(BGRATextOutImproveReadabilityProc) and (FontQuality in[fqFineAntialiasing,fqFineClearTypeBGR,fqFineClearTypeRGB]) and (FFont.Orientation mod 3600 = 0) then
     1407  begin
     1408    case FontQuality of
     1409      fqFineClearTypeBGR: mode := irClearTypeBGR;
     1410      fqFineClearTypeRGB: mode := irClearTypeRGB;
     1411    else
     1412      mode := irNormal;
     1413    end;
     1414    if AShowPrefix then sUTF8 := RemovePrefix(sUTF8); //prefix not handled
     1415    BGRATextOutImproveReadabilityProc(ADest,FFont,x,y,sUTF8,c,texture,align,mode);
     1416  end else
     1417    BGRAText.BGRATextOut(ADest,FFont,FontQuality,x,y,sUTF8,c,texture,align,
     1418        0,AShowPrefix,ARightToLeft);
     1419end;
     1420
     1421procedure TCustomLCLFontRenderer.InternalTextOutEllipse(
     1422  ADest: TBGRACustomBitmap; x, y, availableWidth: single; sUTF8: string;
     1423  c: TBGRAPixel; texture: IBGRAScanner; align: TAlignment;
     1424  AShowPrefix: boolean; ARightToLeft: boolean);
     1425var remain: string;
     1426begin
     1427  if InternalTextSize(sUTF8,AShowPrefix).cx > availableWidth then
     1428  begin
     1429    InternalSplitText(sUTF8, round(availableWidth - InternalTextSize('...',AShowPrefix).cx), remain, nil);
     1430    sUTF8 += '...';
     1431  end;
     1432  InternalTextOut(ADest,x,y,sUTF8,c,texture,align,AShowPrefix,ARightToLeft);
     1433end;
     1434
     1435procedure TCustomLCLFontRenderer.InternalSplitText(var ATextUTF8: string;
     1436  AMaxWidth: integer; out ARemainsUTF8: string; out ALineEndingBreak: boolean; AWordBreak: TWordBreakHandler);
     1437var p,skipCount, charLen: integer;
     1438  zeroWidth: boolean;
     1439  u: Cardinal;
     1440begin
     1441  ALineEndingBreak:= false;
     1442  if ATextUTF8= '' then
     1443  begin
     1444    ARemainsUTF8 := '';
     1445    exit;
     1446  end;
     1447  if RemoveLineEnding(ATextUTF8,1) then
     1448  begin
     1449    ARemainsUTF8:= ATextUTF8;
     1450    ATextUTF8 := '';
     1451    ALineEndingBreak:= true;
     1452    exit;
     1453  end;
     1454
     1455  if AMaxWidth <= 0 then
     1456    skipCount := 0
     1457  else
     1458    skipCount := BGRATextFitInfo(FFont, FontQuality, ATextUTF8, FontAntialiasingLevel, AMaxWidth);
     1459
     1460  if skipCount <= 0 then skipCount := 1;
     1461
     1462  p := 1;
     1463  zeroWidth := true;
     1464  repeat
     1465    charLen := UTF8CharacterLength(@ATextUTF8[p]);
     1466    u := UTF8CodepointToUnicode(@ATextUTF8[p], charLen);
     1467    if not IsZeroWidthUnicode(u) then
     1468      zeroWidth:= false;
     1469    inc(p, charLen); //UTF8 chars may be more than 1 byte long
     1470    dec(skipCount);
     1471
     1472    if RemoveLineEnding(ATextUTF8,p) then
     1473    begin
     1474      ARemainsUTF8:= copy(ATextUTF8,p,length(ATextUTF8)-p+1);
     1475      ATextUTF8 := copy(ATextUTF8,1,p-1);
     1476      ALineEndingBreak:= true;
     1477      exit;
     1478    end;
     1479  until ((skipCount <= 0) and not zeroWidth) or (p >= length(ATextUTF8)+1);
     1480
     1481  ARemainsUTF8:= copy(ATextUTF8,p,length(ATextUTF8)-p+1);
     1482  ATextUTF8 := copy(ATextUTF8,1,p-1); //this includes the whole last UTF8 char
     1483  if Assigned(AWordBreak) then AWordBreak(ATextUTF8,ARemainsUTF8);
     1484end;
     1485
     1486procedure TCustomLCLFontRenderer.InternalSplitText(var ATextUTF8: string;
     1487  AMaxWidth: integer; out ARemainsUTF8: string; AWordBreak: TWordBreakHandler);
     1488var lineEndingBreak: boolean;
     1489begin
     1490  InternalSplitText(ATextUTF8,AMaxWidth,ARemainsUTF8,lineEndingBreak,AWordBreak);
     1491end;
     1492
     1493procedure TCustomLCLFontRenderer.DefaultWorkBreakHandler(var ABeforeUTF8,
     1494  AAfterUTF8: string);
     1495begin
     1496  BGRADefaultWordBreakHandler(ABeforeUTF8,AAfterUTF8);
    12281497end;
    12291498
     
    12341503  FontOrientation:= 0;
    12351504  UpdateFont;
    1236   result := TextSizeNoUpdateFont(sUTF8);
     1505  result := InternalTextSize(sUTF8,False);
    12371506  FontOrientation:= oldOrientation;
     1507end;
     1508
     1509function TCustomLCLFontRenderer.TextSizeAngle(sUTF8: string;
     1510  orientationTenthDegCCW: integer): TSize;
     1511var oldOrientation: integer;
     1512begin
     1513  oldOrientation:= FontOrientation;
     1514  FontOrientation:= orientationTenthDegCCW;
     1515  UpdateFont;
     1516  result := InternalTextSize(sUTF8,False);
     1517  FontOrientation:= oldOrientation;
     1518end;
     1519
     1520function TCustomLCLFontRenderer.TextSize(sUTF8: string;
     1521  AMaxWidth: integer; ARightToLeft: boolean): TSize;
     1522var
     1523  remains: string;
     1524  h, i, w: integer;
     1525  WordBreakHandler: TWordBreakHandler;
     1526  layout: TBidiTextLayout;
     1527begin
     1528  UpdateFont;
     1529
     1530  if Assigned(FWordBreakHandler) then
     1531    WordBreakHandler := FWordBreakHandler
     1532  else
     1533    WordBreakHandler := @DefaultWorkBreakHandler;
     1534
     1535  if ContainsBidiIsolateOrFormattingUTF8(sUTF8) then
     1536  begin
     1537    layout := TBidiTextLayout.Create(self, sUTF8, ARightToLeft);
     1538    layout.WordBreakHandler:= WordBreakHandler;
     1539    layout.AvailableWidth := AMaxWidth;
     1540    for i := 0 to layout.ParagraphCount-1 do
     1541      layout.ParagraphAlignment[i] := btaLeftJustify;
     1542    result.cx := 0;
     1543    for i := 0 to layout.PartCount-1 do
     1544    begin
     1545      w := ceil(layout.PartRectF[i].Right);
     1546      if w > result.cx then result.cx := w;
     1547    end;
     1548    result.cy := ceil(layout.TotalTextHeight);
     1549    layout.Free;
     1550  end else
     1551  begin
     1552    result.cx := 0;
     1553    result.cy := 0;
     1554    h := InternalTextSize('Hg',False).cy;
     1555    repeat
     1556      InternalSplitText(sUTF8, AMaxWidth, remains, WordBreakHandler);
     1557      with InternalTextSize(sUTF8, false) do
     1558        if cx > result.cx then result.cx := cx;
     1559      result.cy += h;
     1560      sUTF8 := remains;
     1561    until remains = '';
     1562  end;
     1563end;
     1564
     1565function TCustomLCLFontRenderer.TextFitInfo(sUTF8: string; AMaxWidth: integer
     1566  ): integer;
     1567begin
     1568  UpdateFont;
     1569  result := BGRATextFitInfo(FFont, FontQuality, sUTF8, FontAntialiasingLevel, AMaxWidth);
    12381570end;
    12391571
  • GraphicTest/Packages/bgrabitmap/bgratextfx.pas

    r494 r521  
    6262    OutlineVisible,OuterOutlineOnly: boolean;
    6363    OutlineTexture: IBGRAScanner;
    64     constructor Create;
    65     constructor Create(AShader: TCustomPhongShading; AShaderOwner: boolean);
     64    constructor Create; overload;
     65    constructor Create(AShader: TCustomPhongShading; AShaderOwner: boolean); overload;
    6666    destructor Destroy; override;
    6767    procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientation: integer;
    68       s: string; texture: IBGRAScanner; align: TAlignment); override;
     68      s: string; texture: IBGRAScanner; align: TAlignment); overload; override;
    6969    procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientation: integer;
    70       s: string; c: TBGRAPixel; align: TAlignment); override;
    71     procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; s: string;
    72       texture: IBGRAScanner; align: TAlignment); override;
    73     procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; s: string; c: TBGRAPixel;
    74       align: TAlignment); override;
    75     function TextSize(sUTF8: string): TSize; override;
     70      s: string; c: TBGRAPixel; align: TAlignment); overload; override;
     71    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; s: string; texture: IBGRAScanner; align: TAlignment); overload; override;
     72    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; s: string; c: TBGRAPixel; align: TAlignment); overload; override;
     73    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment; {%H-}ARightToLeft: boolean); overload; override;
     74    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment; {%H-}ARightToLeft: boolean); overload; override;
     75    function TextSize(sUTF8: string): TSize; overload; override;
     76    function TextSize(sUTF8: string; AMaxWidth: integer; {%H-}ARightToLeft: boolean): TSize; overload; override;
     77    function TextFitInfo(sUTF8: string; AMaxWidth: integer): integer; override;
    7678    property Shader: TCustomPhongShading read FShader;
    7779    property ShaderLightPosition: TPoint read GetShaderLightPosition write SetShaderLightPosition;
     
    8789    procedure InitWithFontName(AText: string; AFontName: string; AFullHeight: integer; AStyle: TFontStyles; Antialiasing: boolean; SubOffsetX,SubOffsetY: single);
    8890  public
    89     constructor Create(AText: string; Font: TFont; Antialiasing: boolean);
    90     constructor Create(AText: string; Font: TFont; Antialiasing: boolean; SubOffsetX,SubOffsetY: single);
    91     constructor Create(AText: string; Font: TFont; Antialiasing: boolean; SubOffsetX,SubOffsetY: single; GrainX, GrainY: Integer);
    92     constructor Create(AText: string; AFontName: string; AFullHeight: integer; Antialiasing: boolean);
    93     constructor Create(AText: string; AFontName: string; AFullHeight: integer; Antialiasing: boolean; SubOffsetX,SubOffsetY: single);
    94     constructor Create(AText: string; AFontName: string; AFullHeight: integer; AStyle: TFontStyles; Antialiasing: boolean);
    95     constructor Create(AText: string; AFontName: string; AFullHeight: integer; AStyle: TFontStyles; Antialiasing: boolean; SubOffsetX,SubOffsetY: single);
     91    constructor Create(AText: string; Font: TFont; Antialiasing: boolean); overload;
     92    constructor Create(AText: string; Font: TFont; Antialiasing: boolean; SubOffsetX,SubOffsetY: single); overload;
     93    constructor Create(AText: string; Font: TFont; Antialiasing: boolean; SubOffsetX,SubOffsetY: single; GrainX, GrainY: Integer); overload;
     94    constructor Create(AText: string; AFontName: string; AFullHeight: integer; Antialiasing: boolean); overload;
     95    constructor Create(AText: string; AFontName: string; AFullHeight: integer; Antialiasing: boolean; SubOffsetX,SubOffsetY: single); overload;
     96    constructor Create(AText: string; AFontName: string; AFullHeight: integer; AStyle: TFontStyles; Antialiasing: boolean); overload;
     97    constructor Create(AText: string; AFontName: string; AFullHeight: integer; AStyle: TFontStyles; Antialiasing: boolean; SubOffsetX,SubOffsetY: single); overload;
    9698  end;
    9799
     
    509511end;
    510512
     513procedure TBGRATextEffectFontRenderer.TextOut(ADest: TBGRACustomBitmap; x,
     514  y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment;
     515  ARightToLeft: boolean);
     516begin
     517  if VectorizedFontNeeded then
     518    VectorizedFontRenderer.TextOut(ADest,x,y,sUTF8,texture,align,ARightToLeft)
     519  else
     520    InternalTextOut(ADest,x,y,sUTF8,BGRAPixelTransparent,texture,align);
     521end;
     522
     523procedure TBGRATextEffectFontRenderer.TextOut(ADest: TBGRACustomBitmap; x,
     524  y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment;
     525  ARightToLeft: boolean);
     526begin
     527  if VectorizedFontNeeded then
     528    VectorizedFontRenderer.TextOut(ADest,x,y,sUTF8,c,align,ARightToLeft)
     529  else
     530    InternalTextOut(ADest,x,y,sUTF8,c,nil,align);
     531end;
     532
    511533function TBGRATextEffectFontRenderer.TextSize(sUTF8: string): TSize;
    512534begin
     
    514536    result := VectorizedFontRenderer.TextSize(sUTF8)
    515537  else
    516   begin
    517538    result := inherited TextSize(sUTF8);
    518   end;
     539end;
     540
     541function TBGRATextEffectFontRenderer.TextSize(sUTF8: string;
     542  AMaxWidth: integer; ARightToLeft: boolean): TSize;
     543begin
     544  if VectorizedFontNeeded then
     545    result := VectorizedFontRenderer.TextSize(sUTF8, AMaxWidth, ARightToLeft)
     546  else
     547    result := inherited TextSize(sUTF8, AMaxWidth, ARightToLeft);
     548end;
     549
     550function TBGRATextEffectFontRenderer.TextFitInfo(sUTF8: string;
     551  AMaxWidth: integer): integer;
     552begin
     553  if VectorizedFontNeeded then
     554    result := VectorizedFontRenderer.TextFitInfo(sUTF8, AMaxWidth)
     555  else
     556    result := inherited TextFitInfo(sUTF8, AMaxWidth)
    519557end;
    520558
     
    526564  overhang: integer;
    527565begin
     566  FShadowQuality:= rbFast;
    528567  if SubOffsetX < 0 then SubOffsetX := 0;
    529568  if SubOffsetY < 0 then SubOffsetY := 0;
  • GraphicTest/Packages/bgrabitmap/bgrathumbnail.pas

    r494 r521  
    99  Classes, SysUtils, BGRABitmap, BGRABitmapTypes, FPimage;
    1010
    11 function GetBitmapThumbnail(ABitmap: TBGRABitmap; AWidth,AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil; AVerticalShrink : single = 1): TBGRABitmap;
     11function GetBitmapThumbnail(ABitmap: TBGRACustomBitmap; AWidth,AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil; AVerticalShrink: single = 1; AHorizShrink: single = 1): TBGRABitmap; overload;
     12function GetBitmapThumbnail(ABitmap: TBGRACustomBitmap; AFormat: TBGRAImageFormat; AWidth,AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil; AVerticalShrink: single = 1; AHorizShrink: single = 1): TBGRABitmap; overload;
    1213function GetFileThumbnail(AFilenameUTF8: string; AWidth,AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil): TBGRABitmap;
    1314function GetStreamThumbnail(AStream: TStream; AWidth,AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ASuggestedExtensionUTF8: string = ''; ADest: TBGRABitmap= nil): TBGRABitmap; overload;
     
    2223function GetPaintDotNetThumbnail(AStream: TStream; AWidth, AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil): TBGRABitmap;
    2324function GetBmpThumbnail(AStream: TStream; AWidth, AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil): TBGRABitmap;
    24 {$IFDEF BGRABITMAP_USE_LCL}
    2525function GetIcoThumbnail(AStream: TStream; AWidth, AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil): TBGRABitmap;
    26 {$ENDIF}
     26function GetCurThumbnail(AStream: TStream; AWidth, AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil): TBGRABitmap;
    2727
    2828function GetPcxThumbnail(AStream: TStream; AWidth, AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil): TBGRABitmap;
     
    3434function GetBmpMioMapThumbnail(AStream: TStream; AWidth, AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil): TBGRABitmap;
    3535
    36 procedure DrawThumbnailCheckers(bmp: TBGRABitmap; ARect: TRect);
     36procedure DrawThumbnailCheckers(bmp: TBGRABitmap; ARect: TRect; AIconCheckers: boolean = false);
     37
     38var
     39  ImageCheckersColor1,ImageCheckersColor2  : TBGRAPixel;
     40  IconCheckersColor1,IconCheckersColor2  : TBGRAPixel;
    3741
    3842implementation
    3943
    40 uses Types, base64, BGRAUTF8, {$IFDEF BGRABITMAP_USE_LCL}Graphics, GraphType,{$ENDIF}
     44uses Types, base64, BGRAUTF8,
    4145     DOM, XMLRead, BGRAReadJPEG, BGRAReadPng, BGRAReadGif, BGRAReadBMP,
    4246     BGRAReadPSD, BGRAReadIco, UnzipperExt, BGRAReadLzp;
    4347
    44 procedure DrawThumbnailCheckers(bmp: TBGRABitmap; ARect: TRect);
    45 begin
    46   bmp.DrawCheckers(ARect, BGRA(255,255,255), BGRA(220,220,220));
    47 end;
    48 
    49 function GetBitmapThumbnail(ABitmap: TBGRABitmap; AWidth, AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap; AVerticalShrink: single
    50   ): TBGRABitmap;
     48procedure DrawThumbnailCheckers(bmp: TBGRABitmap; ARect: TRect; AIconCheckers: boolean);
     49begin
     50  if AIconCheckers then
     51    bmp.DrawCheckers(ARect, IconCheckersColor1, IconCheckersColor2)
     52  else
     53    bmp.DrawCheckers(ARect, ImageCheckersColor1, ImageCheckersColor2);
     54end;
     55
     56function InternalGetBitmapThumbnail(ABitmap: TBGRACustomBitmap; AWidth, AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean;
     57  ADest: TBGRABitmap; AVerticalShrink: single = 1; AHorizShrink: single = 1; AShowHotSpot: boolean = false; ADarkCheckers: boolean = false): TBGRABitmap;
    5158var
    5259  factorX, factorY, factor: single;
    5360  xIcon,yIcon,wIcon,hIcon: Integer;
     61  hotspot: TPoint;
    5462begin
    5563  result := nil;
     
    6472      end else
    6573        result := TBGRABitmap.Create(AWidth,AHeight,ABackColor);
    66       factorX := result.Width/ABitmap.Width;
     74      factorX := result.Width/(ABitmap.Width*AHorizShrink);
    6775      factorY := result.Height/(ABitmap.Height*AVerticalShrink);
    6876      if factorX < factorY then factor := factorX else factor := factorY;
    69       wIcon := round(ABitmap.Width*factor);
     77      wIcon := round(ABitmap.Width*AHorizShrink*factor);
     78      if wIcon = 0 then wIcon := 1;
    7079      hIcon := round(ABitmap.Height*AVerticalShrink*factor);
     80      if hIcon = 0 then hIcon := 1;
    7181      xIcon:= (result.Width-wIcon) div 2;
    7282      yIcon:= (result.Height-hIcon) div 2;
    73       if ACheckers then DrawThumbnailCheckers(result,Rect(xIcon,yIcon,xIcon+wIcon,yIcon+hIcon));
     83      if ACheckers then DrawThumbnailCheckers(result,Rect(xIcon,yIcon,xIcon+wIcon,yIcon+hIcon),ADarkCheckers);
     84      if AShowHotSpot and (wIcon > 0) and (hIcon > 0) then
     85      begin
     86        hotspot := Point(xIcon+ABitmap.HotSpot.X*wIcon div ABitmap.Width,yIcon+ABitmap.HotSpot.Y*hIcon div ABitmap.Height);
     87        result.HorizLine(xIcon,hotspot.y-1,xIcon+wIcon-1,CSSLime,dmDrawWithTransparency);
     88        result.HorizLine(xIcon,hotspot.y,xIcon+wIcon-1,CSSLime,dmDrawWithTransparency);
     89        result.HorizLine(xIcon,hotspot.y+1,xIcon+wIcon-1,CSSLime,dmDrawWithTransparency);
     90        result.VertLine(hotspot.x-1,yIcon,yIcon+hIcon-1,CSSLime,dmDrawWithTransparency);
     91        result.VertLine(hotspot.x,yIcon,yIcon+hIcon-1,CSSLime,dmDrawWithTransparency);
     92        result.VertLine(hotspot.x+1,yIcon,yIcon+hIcon-1,CSSLime,dmDrawWithTransparency);
     93      end;
    7494      if (ABackColor.alpha <> 0) or ACheckers then
    7595        result.StretchPutImage(Rect(xIcon,yIcon,xIcon+wIcon,yIcon+hIcon),ABitmap,dmDrawWithTransparency) else
    7696        result.StretchPutImage(Rect(xIcon,yIcon,xIcon+wIcon,yIcon+hIcon),ABitmap,dmSet);
     97      if AShowHotSpot and (wIcon > 0) and (hIcon > 0) then
     98      begin
     99        result.HorizLine(xIcon,yIcon+ABitmap.HotSpot.Y*hIcon div ABitmap.Height,xIcon+wIcon-1,BGRA(255,0,255,96),dmDrawWithTransparency);
     100        result.VertLine(xIcon+ABitmap.HotSpot.X*wIcon div ABitmap.Width,yIcon,yIcon+hIcon-1,BGRA(255,0,255,96),dmDrawWithTransparency);
     101      end;
    77102    end;
    78103  except
    79104  end;
     105end;
     106
     107function GetBitmapThumbnail(ABitmap: TBGRACustomBitmap; AWidth, AHeight: integer;
     108  ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap = nil;
     109  AVerticalShrink: single = 1; AHorizShrink: single = 1): TBGRABitmap;
     110begin
     111  result := InternalGetBitmapThumbnail(ABitmap,AWidth,AHeight,ABackColor,ACheckers,ADest,AVerticalShrink,AHorizShrink,
     112                                       false,false);
     113end;
     114
     115function GetBitmapThumbnail(ABitmap: TBGRACustomBitmap; AFormat: TBGRAImageFormat; AWidth, AHeight: integer;
     116  ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap = nil; AVerticalShrink: single = 1; AHorizShrink: single = 1): TBGRABitmap;
     117begin
     118  result := InternalGetBitmapThumbnail(ABitmap,AWidth,AHeight,ABackColor,ACheckers,ADest,AVerticalShrink,AHorizShrink,
     119                                       AFormat = ifCur, AFormat in[ifCur,ifIco]);
     120
    80121end;
    81122
     
    83124var stream: TFileStreamUTF8;
    84125begin
     126  result := nil;
    85127  try
    86128    stream := TFileStreamUTF8.Create(AFilenameUTF8,fmOpenRead or fmShareDenyWrite);
    87129  except
    88     result := nil;
    89130    exit;
    90131  end;
     
    99140  ABackColor: TBGRAPixel; ACheckers: boolean; ASuggestedExtensionUTF8: string;
    100141  ADest: TBGRABitmap): TBGRABitmap;
    101 begin
    102   case DetectFileFormat(AStream,ASuggestedExtensionUTF8) of
     142var
     143  ff: TBGRAImageFormat;
     144  reader: TFPCustomImageReader;
     145begin
     146  ff := DetectFileFormat(AStream,ASuggestedExtensionUTF8);
     147  case ff of
    103148    ifJpeg: result := GetJpegThumbnail(AStream, AWidth,AHeight, ABackColor, ACheckers, ADest);
    104     ifPng: result := GetPngThumbnail(AStream, AWidth,AHeight, ABackColor, ACheckers, ADest);
    105     ifGif: result := GetGifThumbnail(AStream, AWidth,AHeight, ABackColor, ACheckers, ADest);
    106     ifBmp: result := GetBmpThumbnail(AStream, AWidth,AHeight, ABackColor, ACheckers, ADest);
    107     {$IFDEF BGRABITMAP_USE_LCL}
    108149    ifIco: result := GetIcoThumbnail(AStream, AWidth,AHeight, ABackColor, ACheckers, ADest);
    109     {$ENDIF}
    110     ifPcx: result := GetPcxThumbnail(AStream, AWidth,AHeight, ABackColor, ACheckers, ADest);
     150    ifCur: result := GetCurThumbnail(AStream, AWidth,AHeight, ABackColor, ACheckers, ADest);
    111151    ifPaintDotNet: result := GetPaintDotNetThumbnail(AStream, AWidth,AHeight, ABackColor, ACheckers, ADest);
    112152    ifLazPaint: result := GetLazPaintThumbnail(AStream, AWidth,AHeight, ABackColor, ACheckers, ADest);
     
    114154    ifPhoxo: result := GetPhoxoThumbnail(AStream, AWidth,AHeight, ABackColor, ACheckers, ADest);
    115155    ifPsd: result := GetPsdThumbnail(AStream, AWidth,AHeight, ABackColor, ACheckers, ADest);
    116     ifTarga: result := GetTargaThumbnail(AStream, AWidth,AHeight, ABackColor, ACheckers, ADest);
    117     ifTiff: result := GetTiffThumbnail(AStream, AWidth,AHeight, ABackColor, ACheckers, ADest);
    118     ifXwd: result := GetXwdThumbnail(AStream, AWidth,AHeight, ABackColor, ACheckers, ADest);
    119     ifXPixMap: result := GetXPixMapThumbnail(AStream, AWidth,AHeight, ABackColor, ACheckers, ADest);
    120     ifBmpMioMap: result := GetBmpMioMapThumbnail(AStream, AWidth,AHeight, ABackColor, ACheckers, ADest);
    121156    else
    122       result := nil;
     157    begin
     158      if (ff = ifUnknown) or (DefaultBGRAImageReader[ff] = nil) then
     159        result := nil
     160      else
     161      begin
     162        result := nil;
     163        reader := nil;
     164        try
     165          reader := CreateBGRAImageReader(ff);
     166          result := GetStreamThumbnail(AStream, reader, AWidth, AHeight, ABackColor, ACheckers, ADest);
     167        finally
     168          reader.Free;
     169        end;
     170      end;
     171    end;
    123172  end;
    124173end;
     
    127176  AWidth, AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean;
    128177  ADest: TBGRABitmap): TBGRABitmap;
    129 var bmp: TBGRABitmap;
    130 begin
     178var
     179  bmp: TBGRACustomBitmap;
     180  AOriginalWidth, AOriginalHeight: integer;
     181begin
     182  if AReader is TBGRAImageReader then
     183  begin
     184    bmp := nil;
     185    try
     186      bmp := TBGRAImageReader(AReader).GetBitmapDraft(AStream, AWidth,AHeight, AOriginalWidth,AOriginalHeight);
     187      if Assigned(bmp) and (bmp.Height <> 0) and (bmp.Width <> 0) then
     188        result := GetBitmapThumbnail(bmp, AWidth, AHeight, ABackColor, ACheckers, ADest,
     189                    AOriginalHeight/bmp.Height, AOriginalWidth/bmp.Width);
     190    except
     191      result := nil;
     192    end;
     193    bmp.free;
     194    exit;
     195  end;
     196
    131197  bmp := TBGRABitmap.Create;
    132198  try
     
    143209  end;
    144210end;
    145 
    146 
    147211
    148212function GetOpenRasterThumbnail(AStream: TStream; AWidth, AHeight: integer;
     
    234298end;
    235299
    236 function GetPngThumbnail(AStream: TStream; AWidth, AHeight: integer
    237   ; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil): TBGRABitmap;
    238 var
    239   png: TBGRAReaderPNG;
    240   bmp: TBGRABitmap;
    241 begin
    242   png:= TBGRAReaderPNG.Create;
    243   bmp := TBGRABitmap.Create;
    244   try
    245     png.MinifyHeight := AHeight;
    246     bmp.LoadFromStream(AStream, png);
    247   except
    248     FreeAndNil(bmp);
    249   end;
    250   if bmp = nil then
    251     result := nil
    252   else
    253   begin
    254     result := GetBitmapThumbnail(bmp, AWidth, AHeight, ABackColor, ACheckers, ADest, png.OriginalHeight/bmp.Height);
    255     bmp.Free;
    256   end;
    257   png.Free;
     300function GetPngThumbnail(AStream: TStream; AWidth, AHeight: integer;
     301    ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil): TBGRABitmap;
     302var
     303  pngFormat: TBGRAReaderPNG;
     304begin
     305  pngFormat:= TBGRAReaderPNG.Create;
     306  result:= GetStreamThumbnail(AStream, pngFormat, AWidth,AHeight, ABackColor, ACheckers, ADest);
     307  pngFormat.Free;
    258308end;
    259309
     
    303353        if Assigned(pngNode) then
    304354        begin
    305           png64 := TStringStream.Create(pngNode.NodeValue);
     355          png64 := TStringStream.Create(string(pngNode.NodeValue));
    306356          try
    307357            png64.Position := 0;
     
    327377var
    328378  bmpFormat: TBGRAReaderBMP;
    329   bmp: TBGRABitmap;
    330379begin
    331380  bmpFormat:= TBGRAReaderBMP.Create;
    332   bmpFormat.MinifyHeight := AHeight*2;
    333   bmp := TBGRABitmap.Create;
    334   try
    335     bmp.LoadFromStream(AStream, bmpFormat);
    336   except
    337     FreeAndNil(bmp);
    338   end;
    339   if bmp = nil then
    340     result := nil
    341   else
    342   begin
    343     if bmp.Height <= 0 then
    344       result := nil
    345     else
    346       result := GetBitmapThumbnail(bmp, AWidth, AHeight, ABackColor, ACheckers, ADest, bmpFormat.OriginalHeight/bmp.Height);
    347     bmp.Free;
    348   end;
     381  result:= GetStreamThumbnail(AStream, bmpFormat, AWidth,AHeight, ABackColor, ACheckers, ADest);
    349382  bmpFormat.Free;
    350383end;
    351384
    352 {$IFDEF BGRABITMAP_USE_LCL}
    353385function GetIcoThumbnail(AStream: TStream; AWidth, AHeight: integer;
    354386  ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap): TBGRABitmap;
    355 var ico: TIcon; i,bestIdx: integer;
    356     height,width: word; format:TPixelFormat;
    357     bestHeight,bestWidth: integer; maxFormat: TPixelFormat;
    358     icoBmp: TBGRABitmap;
     387var
     388  reader: TBGRAReaderIco;
     389  icoBmp: TBGRABitmap;
    359390begin
    360391  result := nil;
    361   ico := TIcon.Create;
    362   try
    363     ico.LoadFromStream(AStream);
    364   except
    365     ico.free;
    366     exit;
    367   end;
    368   bestIdx := -1;
    369   bestHeight := 0;
    370   bestWidth := 0;
    371   maxFormat := pfDevice;
    372   try
    373     for i := 0 to ico.Count-1 do
    374     begin
    375       ico.GetDescription(i,format,height,width);
    376       if (bestIdx = -1) or (abs(height-AHeight)+abs(width-AWidth) < abs(bestHeight-AHeight)+abs(bestWidth-AWidth)) or
    377       ((height = bestHeight) or (width = bestWidth) and (format > maxFormat)) then
    378       begin
    379         bestIdx := i;
    380         bestHeight := height;
    381         bestWidth := width;
    382         maxFormat := format;
    383       end;
    384     end;
    385     if (bestIdx = -1) or (bestWidth = 0) or (bestHeight = 0) then result := nil else
    386     begin
    387       ico.Current := bestIdx;
    388       icoBmp := TBGRABitmap.Create(bestWidth,bestHeight);
    389       icoBmp.Assign(ico);
    390       result := GetBitmapThumbnail(icoBmp, AWidth, AHeight, ABackColor, ACheckers, ADest);
    391       icoBmp.Free;
    392     end;
    393   except
    394   end;
    395   ico.Free;
    396 end;
    397 {$ENDIF}
     392  reader := TBGRAReaderIco.Create;
     393  reader.WantedWidth:= AWidth;
     394  reader.WantedHeight:= AHeight;
     395  icoBmp := TBGRABitmap.Create;
     396  try
     397    icoBmp.LoadFromStream(AStream, reader);
     398    result := GetBitmapThumbnail(icoBmp, ifIco, AWidth, AHeight, ABackColor, ACheckers, ADest);
     399  except
     400  end;
     401  icoBmp.Free;
     402  reader.Free;
     403end;
     404
     405function GetCurThumbnail(AStream: TStream; AWidth, AHeight: integer;
     406  ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap): TBGRABitmap;
     407var
     408  reader: TBGRAReaderCur;
     409  icoBmp: TBGRABitmap;
     410begin
     411  result := nil;
     412  reader := TBGRAReaderCur.Create;
     413  reader.WantedWidth:= AWidth;
     414  reader.WantedHeight:= AHeight;
     415  icoBmp := TBGRABitmap.Create;
     416  try
     417    icoBmp.LoadFromStream(AStream, reader);
     418    result := GetBitmapThumbnail(icoBmp, ifCur, AWidth, AHeight, ABackColor, ACheckers, ADest);
     419  except
     420  end;
     421  icoBmp.Free;
     422  reader.Free;
     423end;
    398424
    399425function GetPcxThumbnail(AStream: TStream; AWidth, AHeight: integer;
     
    467493end;
    468494
     495initialization
     496
     497  IconCheckersColor1 := BGRA(140,180,180);
     498  IconCheckersColor2 := BGRA(80,140,140);
     499
     500  ImageCheckersColor1 := BGRA(255,255,255);
     501  ImageCheckersColor2 := BGRA(220,220,220);
     502
    469503end.
  • GraphicTest/Packages/bgrabitmap/bgratransform.pas

    r494 r521  
    1313  { Contains an affine matrix, i.e. a matrix to transform linearly and translate TPointF coordinates }
    1414  TAffineMatrix = BGRABitmapTypes.TAffineMatrix;
    15 
    16   { TAffineBox }
    17 
    18   TAffineBox = object
    19   private
    20     function GetAsPolygon: ArrayOfTPointF;
    21     function GetBottomRight: TPointF;
    22     function GetIsEmpty: boolean;
    23   public
    24     TopLeft, TopRight,
    25     BottomLeft: TPointF;
    26     class function EmptyBox: TAffineBox;
    27     class function AffineBox(ATopLeft, ATopRight, ABottomLeft: TPointF): TAffineBox;
    28     property BottomRight: TPointF read GetBottomRight;
    29     property IsEmpty: boolean read GetIsEmpty;
    30     property AsPolygon: ArrayOfTPointF read GetAsPolygon;
    31   end;
     15  { Contains an affine base and information on the resulting box }
     16  TAffineBox = BGRABitmapTypes.TAffineBox;
    3217
    3318  { TBGRAAffineScannerTransform allow to transform any scanner. To use it,
     
    8772    procedure Init(ABitmap: TBGRACustomBitmap; ARepeatImageX: Boolean= false; ARepeatImageY: Boolean= false; AResampleFilter: TResampleFilter = rfLinear; AIncludeEdges: boolean = false);
    8873  public
    89     constructor Create(ABitmap: TBGRACustomBitmap; ARepeatImage: Boolean= false; AResampleFilter: TResampleFilter = rfLinear; AIncludeEdges: boolean = false);
    90     constructor Create(ABitmap: TBGRACustomBitmap; ARepeatImageX: Boolean; ARepeatImageY: Boolean; AResampleFilter: TResampleFilter = rfLinear; AIncludeEdges: boolean = false);
     74    constructor Create(ABitmap: TBGRACustomBitmap; ARepeatImage: Boolean= false; AResampleFilter: TResampleFilter = rfLinear; AIncludeEdges: boolean = false); overload;
     75    constructor Create(ABitmap: TBGRACustomBitmap; ARepeatImageX: Boolean; ARepeatImageY: Boolean; AResampleFilter: TResampleFilter = rfLinear; AIncludeEdges: boolean = false); overload;
    9176    destructor Destroy; override;
    9277    function InternalScanCurrentPixel: TBGRAPixel; override;
     
    137122    constructor Create(ASource: IBGRAScanner;
    138123      ASourceMatrix: TAffineMatrix; const APoints: array of TPointF;
    139       ATextureInterpolation: boolean = true);
     124      ATextureInterpolation: boolean = true); overload;
    140125    constructor Create(ASource: IBGRAScanner;
    141126      const ATexCoords: array of TPointF; const APoints: array of TPointF;
    142       ATextureInterpolation: boolean = true);
     127      ATextureInterpolation: boolean = true); overload;
    143128    destructor Destroy; override;
    144129    property Culling: TFaceCulling read GetCulling write SetCulling;
     
    191176{---------------------- Affine matrix functions -------------------}
    192177//fill a matrix
    193 function AffineMatrix(m11,m12,m13,m21,m22,m23: single): TAffineMatrix;
     178function AffineMatrix(m11,m12,m13,m21,m22,m23: single): TAffineMatrix; overload;
     179function AffineMatrix(AU,AV: TPointF; ATranslation: TPointF): TAffineMatrix; overload;
    194180
    195181//matrix multiplication
     
    200186operator *(M: TAffineMatrix; V: TPointF): TPointF;
    201187operator *(M: TAffineMatrix; A: array of TPointF): ArrayOfTPointF;
     188operator *(M: TAffineMatrix; ab: TAffineBox): TAffineBox;
    202189
    203190//check if matrix is inversible
     
    221208//define a scaling matrix
    222209function AffineMatrixScale(sx,sy: single): TAffineMatrix;
     210function AffineMatrixScaledRotation(ASourceVector, ATargetVector: TPointF): TAffineMatrix;
     211function AffineMatrixScaledRotation(ASourcePoint, ATargetPoint, AOrigin: TPointF): TAffineMatrix;
    223212
    224213function AffineMatrixSkewXDeg(AngleCW: single): TAffineMatrix;
     
    228217
    229218//define a linear matrix
    230 function AffineMatrixLinear(v1,v2: TPointF): TAffineMatrix;
     219function AffineMatrixLinear(v1,v2: TPointF): TAffineMatrix; overload;
     220function AffineMatrixLinear(const AMatrix: TAffineMatrix): TAffineMatrix; overload;
    231221
    232222//define a rotation matrix (positive radians are counter-clockwise)
     
    242232
    243233function IsAffineMatrixOrthogonal(M: TAffineMatrix): boolean;
     234function IsAffineMatrixScaledRotation(M: TAffineMatrix): boolean;
    244235
    245236type
     
    278269    procedure SetIncludeOppositePlane(AValue: boolean);
    279270  public
    280     constructor Create(texture: IBGRAScanner; texCoord1,texCoord2: TPointF; const quad: array of TPointF);
    281     constructor Create(texture: IBGRAScanner; const texCoordsQuad: array of TPointF; const quad: array of TPointF);
     271    constructor Create(texture: IBGRAScanner; texCoord1,texCoord2: TPointF; const quad: array of TPointF); overload;
     272    constructor Create(texture: IBGRAScanner; const texCoordsQuad: array of TPointF; const quad: array of TPointF); overload;
    282273    destructor Destroy; override;
    283274    procedure ScanMoveTo(X, Y: Integer); override;
     
    298289  public
    299290    constructor Create; overload;
    300     constructor Create(x1,y1,x2,y2: single; const quad: array of TPointF);
    301     constructor Create(const quad: array of TPointF; x1,y1,x2,y2: single);
    302     constructor Create(const srcQuad,destQuad: array of TPointF);
     291    constructor Create(x1,y1,x2,y2: single; const quad: array of TPointF); overload;
     292    constructor Create(const quad: array of TPointF; x1,y1,x2,y2: single); overload;
     293    constructor Create(const srcQuad,destQuad: array of TPointF); overload;
    303294    function MapQuadToQuad(const srcQuad,destQuad: array of TPointF): boolean;
    304295    function MapRectToQuad(x1,y1,x2,y2: single; const quad: array of TPointF): boolean;
     
    386377end;
    387378
     379function AffineMatrix(AU, AV: TPointF; ATranslation: TPointF): TAffineMatrix;
     380begin
     381  result:= AffineMatrix(AU.x, AV.x, ATranslation.x,
     382                        AU.y, AV.y, ATranslation.y);
     383end;
     384
    388385operator *(M, N: TAffineMatrix): TAffineMatrix;
    389386begin
     
    427424    for i := 0 to high(A) do
    428425      result[i] := M*A[i];
     426end;
     427
     428operator*(M: TAffineMatrix; ab: TAffineBox): TAffineBox;
     429begin
     430  result.TopLeft := M*ab.TopLeft;
     431  result.TopRight := M*ab.TopRight;
     432  result.BottomLeft := M*ab.BottomLeft;
    429433end;
    430434
     
    475479end;
    476480
     481function AffineMatrixScaledRotation(ASourceVector, ATargetVector: TPointF): TAffineMatrix;
     482var
     483  prevScale, newScale, scale: Single;
     484  u1,v1,u2,v2,w: TPointF;
     485begin
     486  prevScale := VectLen(ASourceVector);
     487  newScale := VectLen(ATargetVector);
     488  if (prevScale = 0) or (newScale = 0) then
     489    result := AffineMatrixIdentity
     490  else
     491  begin
     492    scale := newScale/prevScale;
     493    u1 := ASourceVector*(1/prevScale);
     494    v1 := PointF(-u1.y,u1.x);
     495    w := ATargetVector*(1/newScale);
     496    u2 := PointF(w*u1, w*v1);
     497    v2 := PointF(-u2.y,u2.x);
     498    result := AffineMatrix(scale*u2,scale*v2,PointF(0,0));
     499  end;
     500end;
     501
     502function AffineMatrixScaledRotation(ASourcePoint, ATargetPoint, AOrigin: TPointF): TAffineMatrix;
     503begin
     504  result := AffineMatrixTranslation(AOrigin.x,AOrigin.y)*
     505         AffineMatrixScaledRotation(ASourcePoint-AOrigin, ATargetPoint-AOrigin)*
     506         AffineMatrixTranslation(-AOrigin.x,-AOrigin.y);
     507end;
     508
    477509function AffineMatrixSkewXDeg(AngleCW: single): TAffineMatrix;
    478510begin
     
    506538end;
    507539
     540function AffineMatrixLinear(const AMatrix: TAffineMatrix): TAffineMatrix;
     541begin
     542  result := AffineMatrix(AMatrix[1,1],AMatrix[1,2],0,
     543                         AMatrix[2,1],AMatrix[2,2],0);
     544end;
     545
    508546function AffineMatrixRotationRad(AngleCCW: Single): TAffineMatrix;
    509547begin
     
    527565begin
    528566  result := PointF(M[1,1],M[2,1])*PointF(M[1,2],M[2,2]) = 0;
     567end;
     568
     569function IsAffineMatrixScaledRotation(M: TAffineMatrix): boolean;
     570begin
     571  result := IsAffineMatrixOrthogonal(M) and
     572           (VectLen(PointF(M[1,1],M[2,1]))=VectLen(PointF(M[1,2],M[2,2])));
    529573end;
    530574
     
    608652  if y > FBounds.Bottom-1 then y := FBounds.Bottom-1;
    609653  result := FSource.ScanAt(X,Y);
    610 end;
    611 
    612 { TAffineBox }
    613 
    614 function TAffineBox.GetAsPolygon: ArrayOfTPointF;
    615 begin
    616   result := PointsF([TopLeft,TopRight,BottomRight,BottomLeft]);
    617 end;
    618 
    619 function TAffineBox.GetBottomRight: TPointF;
    620 begin
    621   if IsEmpty then
    622     result := EmptyPointF
    623   else
    624     result := TopRight + (BottomLeft-TopLeft);
    625 end;
    626 
    627 function TAffineBox.GetIsEmpty: boolean;
    628 begin
    629   result := isEmptyPointF(TopRight) or isEmptyPointF(BottomLeft) or isEmptyPointF(TopLeft);
    630 end;
    631 
    632 class function TAffineBox.EmptyBox: TAffineBox;
    633 begin
    634   result.TopLeft := EmptyPointF;
    635   result.TopRight := EmptyPointF;
    636   result.BottomLeft := EmptyPointF;
    637 end;
    638 
    639 class function TAffineBox.AffineBox(ATopLeft, ATopRight, ABottomLeft: TPointF): TAffineBox;
    640 begin
    641   result.TopLeft := ATopLeft;
    642   result.TopRight := ATopRight;
    643   result.BottomLeft := ABottomLeft;
    644654end;
    645655
  • GraphicTest/Packages/bgrabitmap/bgratypewriter.pas

    r494 r521  
    3535  end;
    3636
    37   TGlyphPointCurveMode= (cmAuto, cmCurve, cmAngle);
    38 
     37  TGlyphPointCurveMode= TEasyBezierCurveMode;
     38
     39const
     40  cmAuto = TEasyBezierCurveMode.cmAuto;
     41  cmCurve = TEasyBezierCurveMode.cmCurve;
     42  cmAngle = TEasyBezierCurveMode.cmAngle;
     43
     44type
    3945  { TBGRAPolygonalGlyph }
    4046
    4147  TBGRAPolygonalGlyph = class(TBGRAGlyph)
    4248  private
     49    function GetClosed: boolean;
     50    function GetMinimumDotProduct: single;
     51    function GetPoint(AIndex: integer): TPointF;
     52    function GetPointCount: integer;
     53    procedure SetClosed(AValue: boolean);
     54    procedure SetMinimumDotProduct(AValue: single);
     55    procedure SetPoint(AIndex: integer; AValue: TPointF);
    4356    procedure SetQuadraticCurves(AValue: boolean);
    4457  protected
    4558    FQuadraticCurves: boolean;
    46     Points: array of TPointF;
    47     CurveMode: array of TGlyphPointCurveMode;
    48     Curves: array of record
    49       isCurvedToNext,isCurvedToPrevious: boolean;
    50       Center,ControlPoint,NextCenter: TPointF;
    51     end;
    52     function MaybeCurve(start1,end1,start2,end2: integer): boolean;
    53     procedure ComputeQuadraticCurves;
     59    FEasyBezier: TEasyBezierCurve;
    5460    function ContentSize: integer; override;
    5561    function HeaderName: string; override;
    5662    procedure WriteContent(AStream: TStream); override;
    5763    procedure ReadContent(AStream: TStream); override;
     64    function PointTransformMatrix(APoint: PPointF; AData: pointer): TPointF;
    5865    procedure Init;
    5966  public
    6067    Offset: TPointF;
    61     Closed: boolean;
    62     MinimumDotProduct: single;
    6368    constructor Create(AIdentifier: string); override;
    6469    constructor Create(AStream: TStream); override;
     70    constructor Create(AStream: TStream; AQuadratic: boolean);
    6571    procedure SetPoints(const APoints: array of TPointF); overload;
    6672    procedure SetPoints(const APoints: array of TPointF; const ACurveMode: array of TGlyphPointCurveMode); overload;
    6773    procedure Path(ADest: IBGRAPath; AMatrix: TAffineMatrix); override;
    6874    property QuadraticCurves: boolean read FQuadraticCurves write SetQuadraticCurves;
     75    property Closed: boolean read GetClosed write SetClosed;
     76    property MinimumDotProduct: single read GetMinimumDotProduct write SetMinimumDotProduct;
     77    property Point[AIndex: integer]: TPointF read GetPoint write SetPoint;
     78    property PointCount: integer read GetPointCount;
    6979  end;
    7080
     
    193203{ TBGRAPolygonalGlyph }
    194204
     205function TBGRAPolygonalGlyph.GetClosed: boolean;
     206begin
     207  result := FEasyBezier.Closed;
     208end;
     209
     210function TBGRAPolygonalGlyph.GetMinimumDotProduct: single;
     211begin
     212  result := FEasyBezier.MinimumDotProduct;
     213end;
     214
     215function TBGRAPolygonalGlyph.GetPoint(AIndex: integer): TPointF;
     216begin
     217  result := FEasyBezier.Point[AIndex];
     218end;
     219
     220function TBGRAPolygonalGlyph.GetPointCount: integer;
     221begin
     222  result := FEasyBezier.PointCount;
     223end;
     224
     225procedure TBGRAPolygonalGlyph.SetClosed(AValue: boolean);
     226begin
     227  FEasyBezier.Closed := AValue;
     228end;
     229
     230procedure TBGRAPolygonalGlyph.SetMinimumDotProduct(AValue: single);
     231begin
     232  FEasyBezier.MinimumDotProduct := AValue;
     233end;
     234
     235procedure TBGRAPolygonalGlyph.SetPoint(AIndex: integer; AValue: TPointF);
     236begin
     237  FEasyBezier.Point[AIndex] := AValue;
     238end;
     239
    195240procedure TBGRAPolygonalGlyph.SetQuadraticCurves(AValue: boolean);
    196241begin
    197242  if FQuadraticCurves=AValue then Exit;
    198243  FQuadraticCurves:=AValue;
    199   Curves := nil;
    200 end;
    201 
    202 function TBGRAPolygonalGlyph.MaybeCurve(start1,end1,start2,end2: integer): boolean;
    203 var
    204   u,v: TPointF;
    205   lu,lv: single;
    206 begin
    207   if (start1=-1) or (end1=-1) or (start2=-1) or (end2=-1) then
    208   begin
    209     result := false;
    210     exit;
    211   end;
    212   u := pointF(points[end1].x - points[start1].x, points[end1].y - points[start1].y);
    213   lu := sqrt(u*u);
    214   if lu <> 0 then u *= 1/lu;
    215   v := pointF(points[end2].x - points[start2].x, points[end2].y - points[start2].y);
    216   lv := sqrt(v*v);
    217   if lv <> 0 then v *= 1/lv;
    218 
    219   result := u*v > MinimumDotProduct;
    220 end;
    221 
    222 procedure TBGRAPolygonalGlyph.ComputeQuadraticCurves;
    223 var
    224   i,FirstPointIndex,NextPt,NextPt2: integer;
    225 begin
    226   setlength(Curves, length(points));
    227   FirstPointIndex := 0;
    228   for i := 0 to high(points) do
    229     Curves[i].isCurvedToPrevious := false;
    230   for i := 0 to high(points) do
    231   begin
    232     Curves[i].isCurvedToNext := false;
    233     Curves[i].Center := EmptyPointF;
    234     Curves[i].ControlPoint := EmptyPointF;
    235     Curves[i].NextCenter := EmptyPointF;
    236 
    237     if IsEmptyPointF(Points[i]) then
    238     begin
    239       FirstPointIndex := i+1;
    240     end else
    241     begin
    242       NextPt := i+1;
    243       if (NextPt = length(points)) or isEmptyPointF(points[NextPt]) then NextPt := FirstPointIndex;
    244       NextPt2 := NextPt+1;
    245       if (NextPt2 = length(points)) or isEmptyPointF(points[NextPt2]) then NextPt2 := FirstPointIndex;
    246 
    247       Curves[i].Center := (points[i]+points[NextPt])*0.5;
    248       Curves[i].NextCenter := (points[NextPt]+points[NextPt2])*0.5;
    249       Curves[i].ControlPoint := points[NextPt];
    250 
    251       if (i < high(points)-1) or Closed then
    252       begin
    253         case CurveMode[nextPt] of
    254           cmAuto: Curves[i].isCurvedToNext:= MaybeCurve(i,NextPt,NextPt,NextPt2);
    255           cmCurve: Curves[i].isCurvedToNext:= true;
    256           else Curves[i].isCurvedToNext:= false;
    257         end;
    258         Curves[NextPt].isCurvedToPrevious := Curves[i].isCurvedToNext;
    259       end;
    260     end;
    261   end;
    262244end;
    263245
    264246function TBGRAPolygonalGlyph.ContentSize: integer;
    265247begin
    266   Result:= (inherited ContentSize) + sizeof(single)*2 + 4 + sizeof(single)*2*length(Points);
     248  Result:= (inherited ContentSize) + sizeof(single)*2 + 4 + sizeof(single)*2*PointCount;
    267249end;
    268250
    269251function TBGRAPolygonalGlyph.HeaderName: string;
    270252begin
    271   Result:='TBGRAPolygonalGlyph';
     253  if FQuadraticCurves then
     254    Result:='TBGRAEasyBezierGlyph'
     255  else
     256    Result:='TBGRAPolygonalGlyph'
    272257end;
    273258
     
    277262  inherited WriteContent(AStream);
    278263  LEWritePointF(AStream, Offset);
    279   LEWriteLongint(AStream,length(Points));
    280   for i := 0 to high(Points) do
    281     LEWritePointF(AStream, Points[i]);
     264  LEWriteLongint(AStream,PointCount);
     265  for i := 0 to PointCount-1 do
     266    LEWritePointF(AStream, FEasyBezier.Point[i]);
     267  if FQuadraticCurves then
     268    for i := 0 to PointCount-1 do
     269      LEWriteLongint(AStream, ord(FEasyBezier.CurveMode[i]));
    282270end;
    283271
     
    285273var i: integer;
    286274  tempPts: array of TPointF;
     275  flags: LongInt;
    287276begin
    288277  inherited ReadContent(AStream);
     
    292281    tempPts[i] := LEReadPointF(AStream);
    293282  SetPoints(tempPts);
     283  if FQuadraticCurves then
     284  begin
     285    for i := 0 to high(tempPts) do
     286    begin
     287      flags := LEReadLongint(AStream);
     288      FEasyBezier.CurveMode[i] := TEasyBezierCurveMode(flags and 255);
     289    end;
     290  end;
     291end;
     292
     293function TBGRAPolygonalGlyph.PointTransformMatrix(APoint: PPointF;
     294  AData: pointer): TPointF;
     295begin
     296  result := TAffineMatrix(AData^) * APoint^;
    294297end;
    295298
    296299procedure TBGRAPolygonalGlyph.Init;
    297300begin
     301  FEasyBezier.Init;
    298302  Closed := True;
    299   MinimumDotProduct := 0.707;
     303  Offset := PointF(0,0);
     304  FQuadraticCurves:= False;
    300305end;
    301306
    302307constructor TBGRAPolygonalGlyph.Create(AIdentifier: string);
    303308begin
     309  Init;
    304310  inherited Create(AIdentifier);
    305   Offset := PointF(0,0);
     311end;
     312
     313constructor TBGRAPolygonalGlyph.Create(AStream: TStream);
     314begin
    306315  Init;
    307 end;
    308 
    309 constructor TBGRAPolygonalGlyph.Create(AStream: TStream);
    310 begin
    311316  inherited Create(AStream);
     317end;
     318
     319constructor TBGRAPolygonalGlyph.Create(AStream: TStream; AQuadratic: boolean);
     320begin
    312321  Init;
     322  FQuadraticCurves:= AQuadratic;
     323  inherited Create(AStream);
    313324end;
    314325
    315326procedure TBGRAPolygonalGlyph.SetPoints(const APoints: array of TPointF);
    316 var i: integer;
    317 begin
    318   SetLength(Points,length(APoints));
    319   for i := 0 to high(points) do
    320     points[i] := APoints[i];
    321   setlength(CurveMode, length(APoints));
    322   for i := 0 to high(CurveMode) do
    323     CurveMode[i] := cmAuto;
    324   Curves := nil;
     327begin
     328  FEasyBezier.SetPoints(APoints, cmAuto);
    325329end;
    326330
    327331procedure TBGRAPolygonalGlyph.SetPoints(const APoints: array of TPointF;
    328332  const ACurveMode: array of TGlyphPointCurveMode);
    329 var i: integer;
    330333begin
    331334  if length(APoints) <> length(ACurveMode) then
    332335    raise exception.Create('Dimension mismatch');
    333   SetLength(Points,length(APoints));
    334   for i := 0 to high(points) do
    335     points[i] := APoints[i];
    336   setlength(CurveMode, length(ACurveMode));
    337   for i := 0 to high(CurveMode) do
    338     CurveMode[i] := ACurveMode[i];
    339   Curves := nil;
     336  FEasyBezier.SetPoints(APoints, ACurveMode);
    340337end;
    341338
     
    343340var i: integer;
    344341  nextMove: boolean;
    345   startCoord: TPointF;
    346 
    347 begin
    348   if Points = nil then exit;
    349 
    350   if (Curves = nil) and FQuadraticCurves then ComputeQuadraticCurves;
    351   nextMove := true;
     342begin
    352343  AMatrix := AMatrix*AffineMatrixTranslation(Offset.X,Offset.Y);
    353 
    354   for i := 0 to high(Points) do
    355     if isEmptyPointF(Points[i]) then
    356     begin
    357       if not nextMove then ADest.closePath;
    358       nextMove := true;
    359     end else
    360     if FQuadraticCurves then
    361     begin
    362       with Curves[i] do
     344  if not FQuadraticCurves then
     345  begin
     346    nextMove := true;
     347    for i := 0 to PointCount-1 do
     348      if isEmptyPointF(Point[i]) then
     349      begin
     350        if not nextMove and Closed then ADest.closePath;
     351        nextMove := true;
     352      end else
    363353      begin
    364354        if nextMove then
    365355        begin
    366           if not isCurvedToPrevious then
    367             startCoord := Points[i]
    368           else
    369             startCoord := Center;
    370           ADest.moveTo(AMatrix*startCoord);
     356          ADest.moveTo(AMatrix*Point[i]);
    371357          nextMove := false;
    372358        end else
    373           if not isCurvedToPrevious then
    374             ADest.lineTo(AMatrix*Points[i]);
    375 
    376         if isCurvedToNext then
    377         begin
    378           if not isCurvedToPrevious then ADest.lineTo(AMatrix*Center);
    379           ADest.quadraticCurveTo(AMatrix*ControlPoint,AMatrix*NextCenter);
    380         end;
     359          ADest.lineTo(AMatrix*Point[i]);
    381360      end;
    382     end else
    383     begin
    384       if nextMove then
    385       begin
    386         ADest.moveTo(AMatrix*Points[i]);
    387         nextMove := false;
    388       end else
    389       begin
    390         ADest.lineTo(AMatrix*Points[i]);
    391       end;
    392     end;
    393   if not nextmove then
    394     ADest.closePath;
     361    if not nextmove and Closed then ADest.closePath;
     362  end else
     363    FEasyBezier.CopyToPath(ADest, @PointTransformMatrix, @AMatrix);
    395364end;
    396365
     
    473442  if lName = 'TBGRAPolygonalGlyph' then
    474443    result := TBGRAPolygonalGlyph.Create(AStream)
     444  else if lName = 'TBGRAEasyBezierGlyph' then
     445    result := TBGRAPolygonalGlyph.Create(AStream, true)
    475446  else if lName = 'TBGRAGlyph' then
    476447    result := TBGRAGlyph.Create(AStream)
  • GraphicTest/Packages/bgrabitmap/bgraunits.pas

    r494 r521  
    4747    property DefaultUnitHeight: TFloatWithCSSUnit read GetDefaultUnitHeight;
    4848  public
    49     function Convert(xy: single; sourceUnit, destUnit: TCSSUnit; dpi: single): single;
    50     function ConvertWidth(x: single; sourceUnit, destUnit: TCSSUnit): single;
    51     function ConvertHeight(y: single; sourceUnit, destUnit: TCSSUnit): single;
    52     function ConvertWidth(AValue: TFloatWithCSSUnit; destUnit: TCSSUnit): TFloatWithCSSUnit;
    53     function ConvertHeight(AValue: TFloatWithCSSUnit; destUnit: TCSSUnit): TFloatWithCSSUnit;
    54     function ConvertCoord(pt: TPointF; sourceUnit, destUnit: TCSSUnit): TPointF; virtual;
    55     class function parseValue(AValue: string; ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit;
    56     class function formatValue(AValue: TFloatWithCSSUnit; APrecision: integer = 7): string;
    57     class function formatValue(AValue: single; APrecision: integer = 7): string;
     49    function Convert(xy: single; sourceUnit, destUnit: TCSSUnit; dpi: single; containerSize: single = 0): single;
     50    function ConvertWidth(x: single; sourceUnit, destUnit: TCSSUnit; containerWidth: single = 0): single; overload;
     51    function ConvertHeight(y: single; sourceUnit, destUnit: TCSSUnit; containerHeight: single = 0): single; overload;
     52    function ConvertWidth(AValue: TFloatWithCSSUnit; destUnit: TCSSUnit; containerWidth: single = 0): TFloatWithCSSUnit; overload;
     53    function ConvertHeight(AValue: TFloatWithCSSUnit; destUnit: TCSSUnit; containerHeight: single = 0): TFloatWithCSSUnit; overload;
     54    function ConvertCoord(pt: TPointF; sourceUnit, destUnit: TCSSUnit; containerWidth: single = 0; containerHeight: single = 0): TPointF; virtual;
     55    class function parseValue(AValue: string; ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit; overload;
     56    class function parseValue(AValue: string; ADefault: single): single; overload;
     57    class function formatValue(AValue: TFloatWithCSSUnit; APrecision: integer = 7): string; overload;
     58    class function formatValue(AValue: single; APrecision: integer = 7): string; overload;
    5859    property DpiX: single read GetDpiX;
    5960    property DpiY: single read GetDpiY;
     
    135136
    136137function TCSSUnitConverter.Convert(xy: single; sourceUnit, destUnit: TCSSUnit;
    137   dpi: single): single;
     138  dpi: single; containerSize: single): single;
    138139var sourceFactor, destFactor: integer;
    139140begin
     
    144145    result := xy
    145146  else
     147  if sourceUnit = cuPercent then
     148  begin
     149    result := xy/100*containerSize;
     150  end else
    146151  if sourceUnit = cuFontEmHeight then
    147152  begin
     
    185190
    186191function TCSSUnitConverter.ConvertWidth(x: single; sourceUnit,
    187   destUnit: TCSSUnit): single;
     192  destUnit: TCSSUnit; containerWidth: single): single;
    188193begin
    189194  if sourceUnit = destUnit then
     
    192197  with DefaultUnitWidth do
    193198  begin
    194     result := x*ConvertWidth(value,CSSUnit, destUnit)
     199    result := x*ConvertWidth(value,CSSUnit, destUnit, containerWidth)
    195200  end
    196201  else if destUnit = cuCustom then
     
    202207      result := x/value;
    203208  end else
    204     result := Convert(x, sourceUnit, destUnit, DpiX);
     209    result := Convert(x, sourceUnit, destUnit, DpiX, containerWidth);
    205210end;
    206211
    207212function TCSSUnitConverter.ConvertHeight(y: single; sourceUnit,
    208   destUnit: TCSSUnit): single;
     213  destUnit: TCSSUnit; containerHeight: single): single;
    209214begin
    210215  if sourceUnit = cuCustom then
    211216  with DefaultUnitHeight do
    212217  begin
    213     result := y*ConvertHeight(value,CSSUnit, destUnit)
     218    result := y*ConvertHeight(value,CSSUnit, destUnit, containerHeight)
    214219  end
    215220  else if destUnit = cuCustom then
     
    221226      result := y/value;
    222227  end else
    223     result := Convert(y, sourceUnit, destUnit, DpiY);
     228    result := Convert(y, sourceUnit, destUnit, DpiY, containerHeight);
    224229end;
    225230
    226231function TCSSUnitConverter.ConvertWidth(AValue: TFloatWithCSSUnit;
    227   destUnit: TCSSUnit): TFloatWithCSSUnit;
     232  destUnit: TCSSUnit; containerWidth: single): TFloatWithCSSUnit;
    228233begin
    229234  result.CSSUnit := destUnit;
    230   result.value:= ConvertWidth(AValue.value,AValue.CSSUnit,destUnit);
     235  result.value:= ConvertWidth(AValue.value,AValue.CSSUnit,destUnit,containerWidth);
    231236end;
    232237
    233238function TCSSUnitConverter.ConvertHeight(AValue: TFloatWithCSSUnit;
    234   destUnit: TCSSUnit): TFloatWithCSSUnit;
     239  destUnit: TCSSUnit; containerHeight: single): TFloatWithCSSUnit;
    235240begin
    236241  result.CSSUnit := destUnit;
    237   result.value:= ConvertHeight(AValue.value,AValue.CSSUnit,destUnit);
     242  result.value:= ConvertHeight(AValue.value,AValue.CSSUnit,destUnit,containerHeight);
    238243end;
    239244
    240245function TCSSUnitConverter.ConvertCoord(pt: TPointF; sourceUnit,
    241   destUnit: TCSSUnit): TPointF;
    242 begin
    243   result.x := ConvertWidth(pt.x, sourceUnit, destUnit);
    244   result.y := ConvertHeight(pt.y, sourceUnit, destUnit);
     246  destUnit: TCSSUnit; containerWidth: single; containerHeight: single): TPointF;
     247begin
     248  result.x := ConvertWidth(pt.x, sourceUnit, destUnit, containerWidth);
     249  result.y := ConvertHeight(pt.y, sourceUnit, destUnit, containerHeight);
    245250end;
    246251
     
    266271end;
    267272
     273class function TCSSUnitConverter.parseValue(AValue: string; ADefault: single): single;
     274var
     275  errPos: integer;
     276begin
     277  AValue := trim(AValue);
     278  val(AValue,result,errPos);
     279  if errPos <> 0 then
     280    result := ADefault;
     281end;
     282
    268283class function TCSSUnitConverter.formatValue(AValue: TFloatWithCSSUnit; APrecision: integer = 7): string;
    269284begin
  • GraphicTest/Packages/bgrabitmap/bgrautf8.pas

    r494 r521  
    77
    88uses
    9   Classes, SysUtils{$IFDEF BGRABITMAP_USE_LCL}, lazutf8classes{$ENDIF};
     9  Classes, SysUtils, BGRAUnicode{$IFDEF BGRABITMAP_USE_LCL}, lazutf8classes{$ENDIF};
    1010
    1111{$IFDEF BGRABITMAP_USE_LCL}
     
    1919    FFileName: utf8string;
    2020  public
    21     constructor Create(const AFileName: utf8string; Mode: Word);
    22     constructor Create(const AFileName: utf8string; Mode: Word; Rights: Cardinal);
     21    constructor Create(const AFileName: utf8string; Mode: Word); overload;
     22    constructor Create(const AFileName: utf8string; Mode: Word; Rights: Cardinal); overload;
    2323    destructor Destroy; override;
    2424    property FileName: utf8string Read FFilename;
     
    6060
    6161function UTF8CharacterLength(p: PChar): integer;
    62 function UTF8Length(const s: string): PtrInt;
    63 function UTF8Length(p: PChar; ByteCount: PtrInt): PtrInt;
     62function UTF8Length(const s: string): PtrInt; overload;
     63function UTF8Length(p: PChar; ByteCount: PtrInt): PtrInt; overload;
    6464function UnicodeCharToUTF8(u: cardinal): string4;
     65function UTF8ReverseString(const s: string): string;
     66function UTF8CodepointToUnicode(p: PChar; ACodePointLen: integer): cardinal;
     67
     68type
     69  TBidiUTF8Info = packed record
     70    Offset: Integer;
     71    BidiInfo: TUnicodeBidiInfo;
     72  end;
     73  TBidiUTF8Array = packed array of TBidiUTF8Info;
     74  TUnicodeDisplayOrder = BGRAUnicode.TUnicodeDisplayOrder;
     75
     76function GetBidiClassUTF8(P: PChar): TUnicodeBidiClass;
     77function GetFirstStrongBidiClassUTF8(const sUTF8: string): TUnicodeBidiClass;
     78function GetLastStrongBidiClassUTF8(const sUTF8: string): TUnicodeBidiClass;
     79function IsRightToLeftUTF8(const sUTF8: string): boolean;
     80function IsZeroWidthUTF8(const sUTF8: string): boolean;
     81function AddParagraphBidiUTF8(s: string; ARightToLeft: boolean): string;
     82function AnalyzeBidiUTF8(const sUTF8: string; ARightToLeft: boolean): TBidiUTF8Array; overload;
     83function AnalyzeBidiUTF8(const sUTF8: string): TBidiUTF8Array; overload;
     84function GetUTF8DisplayOrder(const ABidi: TBidiUTF8Array): TUnicodeDisplayOrder;
     85function ContainsBidiIsolateOrFormattingUTF8(const sUTF8: string): boolean;
     86
     87function UTF8OverrideDirection(const sUTF8: string; ARightToLeft: boolean): string;
     88function UTF8EmbedDirection(const sUTF8: string; ARightToLeft: boolean): string;
    6589
    6690//little endian stream functions
     91function LEReadInt64(Stream: TStream): int64;
     92procedure LEWriteInt64(Stream: TStream; AValue: int64);
    6793function LEReadLongint(Stream: TStream): longint;
    6894procedure LEWriteLongint(Stream: TStream; AValue: LongInt);
     
    172198  result := LazUtf8.UnicodeToUTF8(u);
    173199end;
     200
    174201{$ELSE}
    175202
     
    457484{$ENDIF}
    458485
    459 function LEReadLongint(Stream: TStream): longint;
    460 begin
    461   Result := 0;
    462   stream.Read(Result, sizeof(Result));
    463   Result := LEtoN(Result);
    464 end;
    465 
    466 procedure LEWriteLongint(Stream: TStream; AValue: LongInt);
    467 begin
    468   AValue := NtoLE(AValue);
    469   stream.Write(AValue, sizeof(AValue));
    470 end;
    471 
    472 function LEReadByte(Stream: TStream): byte;
    473 begin
    474   Result := 0;
    475   stream.Read(Result, sizeof(Result));
    476 end;
    477 
    478 procedure LEWriteByte(Stream: TStream; AValue: Byte);
    479 begin
    480   stream.Write(AValue, sizeof(AValue));
    481 end;
    482 
    483 function LEReadSingle(Stream: TStream): single;
    484 var
    485   ResultAsDWord : longword absolute result;
    486 begin
    487   ResultAsDWord := 0;
    488   stream.Read(ResultAsDWord, sizeof(Result));
    489   ResultAsDWord := LEtoN(ResultAsDWord);
    490 end;
    491 
    492 procedure LEWriteSingle(Stream: TStream; AValue: single);
    493 var
    494   ValueAsDWord : longword absolute AValue;
    495 begin
    496   ValueAsDWord := NtoLE(ValueAsDWord);
    497   stream.Write(ValueAsDWord, sizeof(AValue));
     486function UTF8ReverseString(const s: string): string;
     487var
     488  pSrc,pDest,pEnd: PChar;
     489  charLen: Integer;
     490begin
     491  if s = '' then
     492  begin
     493    result := '';
     494    exit;
     495  end;
     496  setlength(result, length(s));
     497  pDest := @result[1] + length(result);
     498  pSrc := @s[1];
     499  pEnd := pSrc+length(s);
     500  while pSrc < pEnd do
     501  begin
     502    charLen := UTF8CharacterLength(pSrc);
     503    if (charLen = 0) or (pSrc+charLen > pEnd) then break;
     504    dec(pDest, charLen);
     505    move(pSrc^, pDest^, charLen);
     506    inc(pSrc, charLen);
     507  end;
     508end;
     509
     510function UTF8CodepointToUnicode(p: PChar; ACodePointLen: integer): cardinal;
     511begin
     512  case ACodePointLen of
     513    0: result := 0;
     514    1: result := ord(p^);
     515    2: result := ((ord(p^) and %00011111) shl 6) or (ord(p[1]) and %00111111);
     516    3: result := ((ord(p^) and %00011111) shl 12) or ((ord(p[1]) and %00111111) shl 6)
     517                or (ord(p[2]) and %00111111);
     518    4: result := ((ord(p^) and %00001111) shl 18) or ((ord(p[1]) and %00111111) shl 12)
     519                or ((ord(p[2]) and %00111111) shl 6) or (ord(p[3]) and %00111111);
     520    else
     521      raise exception.Create('Invalid code point length');
     522  end;
    498523end;
    499524
     
    515540end;
    516541
     542function GetBidiClassUTF8(P: PChar): TUnicodeBidiClass;
     543begin
     544  result := GetUnicodeBidiClass(UTF8CodepointToUnicode(P, UTF8CharacterLength(p)));
     545end;
     546
     547function GetFirstStrongBidiClassUTF8(const sUTF8: string): TUnicodeBidiClass;
     548var
     549  p,pEnd: PChar;
     550  charLen: Integer;
     551  u: Cardinal;
     552  curBidi: TUnicodeBidiClass;
     553  isolateNesting: integer;
     554begin
     555  if sUTF8 = '' then exit(ubcUnknown);
     556  p := @sUTF8[1];
     557  pEnd := p + length(sUTF8);
     558  isolateNesting:= 0;
     559  while p < pEnd do
     560  begin
     561    charLen := UTF8CharacterLength(p);
     562    if (charLen = 0) or (p+charLen > pEnd) then break;
     563    u := UTF8CodepointToUnicode(p, charLen);
     564    case u of
     565      UNICODE_POP_DIRECTIONAL_ISOLATE: if isolateNesting > 0 then dec(isolateNesting);
     566    end;
     567    curBidi := GetUnicodeBidiClass(u);
     568    if isolateNesting = 0 then
     569    begin
     570      if curBidi in[ubcLeftToRight,ubcRightToLeft,ubcArabicLetter] then
     571        exit(curBidi);
     572    end;
     573    case u of
     574      UNICODE_FIRST_STRONG_ISOLATE, UNICODE_LEFT_TO_RIGHT_ISOLATE, UNICODE_RIGHT_TO_LEFT_ISOLATE: inc(isolateNesting);
     575    end;
     576    if curBidi = ubcParagraphSeparator then isolateNesting:= 0;
     577    inc(p,charLen);
     578  end;
     579  exit(ubcUnknown);
     580end;
     581
     582function GetLastStrongBidiClassUTF8(const sUTF8: string): TUnicodeBidiClass;
     583var
     584  p,pEnd: PChar;
     585  charLen: Integer;
     586  u: Cardinal;
     587  curBidi: TUnicodeBidiClass;
     588  isolateNesting: integer;
     589begin
     590  if sUTF8 = '' then exit(ubcUnknown);
     591  p := @sUTF8[1];
     592  pEnd := p + length(sUTF8);
     593  isolateNesting:= 0;
     594  result := ubcUnknown;
     595  while p < pEnd do
     596  begin
     597    charLen := UTF8CharacterLength(p);
     598    if (charLen = 0) or (p+charLen > pEnd) then break;
     599    u := UTF8CodepointToUnicode(p, charLen);
     600    case u of
     601      UNICODE_POP_DIRECTIONAL_ISOLATE: if isolateNesting > 0 then dec(isolateNesting);
     602    end;
     603    curBidi := GetUnicodeBidiClass(u);
     604    if isolateNesting = 0 then
     605    begin
     606      if curBidi in[ubcLeftToRight,ubcRightToLeft,ubcArabicLetter] then
     607        result := curBidi;
     608    end;
     609    case u of
     610      UNICODE_FIRST_STRONG_ISOLATE, UNICODE_LEFT_TO_RIGHT_ISOLATE, UNICODE_RIGHT_TO_LEFT_ISOLATE: inc(isolateNesting);
     611    end;
     612    if curBidi = ubcParagraphSeparator then isolateNesting:= 0;
     613    inc(p,charLen);
     614  end;
     615end;
     616
     617function IsRightToLeftUTF8(const sUTF8: string): boolean;
     618begin
     619  result := GetFirstStrongBidiClassUTF8(sUTF8) in[ubcRightToLeft,ubcArabicLetter];
     620end;
     621
     622function IsZeroWidthUTF8(const sUTF8: string): boolean;
     623var
     624  p,pEnd: PChar;
     625  charLen: Integer;
     626  u: Cardinal;
     627begin
     628  if sUTF8 = '' then exit(true);
     629  p := @sUTF8[1];
     630  pEnd := p + length(sUTF8);
     631  while p < pEnd do
     632  begin
     633    charLen := UTF8CharacterLength(p);
     634    if (charLen = 0) or (p+charLen > pEnd) then break;
     635    u := UTF8CodepointToUnicode(p, charLen);
     636    if not IsZeroWidthUnicode(u) then exit(false);
     637    inc(p,charLen);
     638  end;
     639  exit(true);
     640end;
     641
     642function AddParagraphBidiUTF8(s: string; ARightToLeft: boolean): string;
     643var
     644  i,curParaStart: Integer;
     645
     646  procedure CheckParagraph;
     647  var
     648    para,newPara: string;
     649    paraRTL: boolean;
     650  begin
     651    if i > curParaStart then
     652    begin
     653      para := copy(s,curParaStart,i-curParaStart);
     654      paraRTL := GetFirstStrongBidiClassUTF8(para) in[ubcRightToLeft,ubcArabicLetter];
     655      //detected paragraph does not match overall RTL option
     656      if paraRTL <> ARightToLeft then
     657      begin
     658        if not paraRTL then
     659          newPara := UnicodeCharToUTF8(UNICODE_LEFT_TO_RIGHT_MARK)+para+UnicodeCharToUTF8(UNICODE_LEFT_TO_RIGHT_MARK)
     660        else
     661          newPara := UnicodeCharToUTF8(UNICODE_RIGHT_TO_LEFT_MARK)+para+UnicodeCharToUTF8(UNICODE_RIGHT_TO_LEFT_MARK);
     662        inc(i, length(newPara)-length(para));
     663        delete(s, curParaStart, length(para));
     664        insert(newPara, s, curParaStart);
     665      end;
     666    end;
     667  end;
     668
     669var
     670  charLen: integer;
     671  u: Cardinal;
     672
     673begin
     674  i := 1;
     675  curParaStart := 1;
     676  while i <= length(s) do
     677  begin
     678    charLen := UTF8CharacterLength(@s[i]);
     679    u := UTF8CodepointToUnicode(@s[i], charLen);
     680    if IsUnicodeParagraphSeparator(u) then
     681    begin
     682      CheckParagraph;
     683      //skip end of line
     684      inc(i);
     685      //skip second CRLF
     686      if ((u = 10) or (u = 13)) and (i <= length(s)) and (s[i] in[#13,#10]) and (s[i]<>s[i-1]) then inc(i);
     687      curParaStart := i;
     688    end else
     689      inc(i);
     690  end;
     691  CheckParagraph;
     692  result := s;
     693end;
     694
     695type
     696  TUnicodeArray = packed array of cardinal;
     697  TIntegerArray = array of integer;
     698
     699procedure UTF8ToUnicode(const sUTF8: string; out u: TUnicodeArray; out ofs: TIntegerArray);
     700var
     701  index,len,charLen: integer;
     702  p,pStart,pEnd: PChar;
     703begin
     704  if sUTF8 = '' then
     705  begin
     706    u := nil;
     707    ofs := nil;
     708  end
     709  else
     710  begin
     711    pStart := @sUTF8[1];
     712    pEnd := pStart + length(sUTF8);
     713    p := pStart;
     714    len := 0;
     715    while p < pEnd do
     716    begin
     717      charLen := UTF8CharacterLength(p);
     718      inc(len);
     719      inc(p,charLen);
     720    end;
     721
     722    setlength(u, len);
     723    setlength(ofs, len);
     724    p := pStart;
     725    index := 0;
     726    while p < pEnd do
     727    begin
     728      charLen := UTF8CharacterLength(p);
     729      u[index] := UTF8CodepointToUnicode(p, charLen);
     730      ofs[index] := p - pStart;
     731      inc(index);
     732      inc(p,charLen);
     733    end;
     734  end;
     735end;
     736
     737function AnalyzeBidiUTF8(const sUTF8: string; ABaseDirection: cardinal): TBidiUTF8Array;
     738var
     739  u: TUnicodeArray;
     740  ofs: TIntegerArray;
     741  a: TUnicodeBidiArray;
     742  i: Integer;
     743begin
     744  if sUTF8 = '' then
     745    result := nil
     746  else
     747  begin
     748    UTF8ToUnicode(sUTF8, u, ofs);
     749    a := AnalyzeBidiUnicode(@u[0], length(u), ABaseDirection);
     750    setlength(result, length(u));
     751    for i := 0 to high(result) do
     752    begin
     753      result[i].Offset:= ofs[i];
     754      result[i].BidiInfo := a[i];
     755    end;
     756  end;
     757end;
     758
     759function AnalyzeBidiUTF8(const sUTF8: string; ARightToLeft: boolean): TBidiUTF8Array;
     760begin
     761  if ARightToLeft then
     762    result := AnalyzeBidiUTF8(sUTF8, UNICODE_RIGHT_TO_LEFT_ISOLATE)
     763  else
     764    result := AnalyzeBidiUTF8(sUTF8, UNICODE_LEFT_TO_RIGHT_ISOLATE);
     765end;
     766
     767function AnalyzeBidiUTF8(const sUTF8: string): TBidiUTF8Array;
     768begin
     769  result := AnalyzeBidiUTF8(sUTF8, UNICODE_FIRST_STRONG_ISOLATE)
     770end;
     771
     772function GetUTF8DisplayOrder(const ABidi: TBidiUTF8Array): TUnicodeDisplayOrder;
     773begin
     774  if length(ABidi) = 0 then
     775    result := nil
     776  else
     777    result := GetUnicodeDisplayOrder(@ABidi[0].BidiInfo, sizeof(TBidiUTF8Info), length(ABidi));
     778end;
     779
     780function ContainsBidiIsolateOrFormattingUTF8(const sUTF8: string): boolean;
     781var
     782  p,pEnd: PChar;
     783  charLen: Integer;
     784  u: Cardinal;
     785begin
     786  if sUTF8 = '' then exit(false);
     787  p := @sUTF8[1];
     788  pEnd := p + length(sUTF8);
     789  while p < pEnd do
     790  begin
     791    charLen := UTF8CharacterLength(p);
     792    if (charLen = 0) or (p+charLen > pEnd) then break;
     793    u := UTF8CodepointToUnicode(p, charLen);
     794    case u of
     795      UNICODE_LEFT_TO_RIGHT_ISOLATE, UNICODE_RIGHT_TO_LEFT_ISOLATE, UNICODE_FIRST_STRONG_ISOLATE,
     796      UNICODE_LEFT_TO_RIGHT_EMBEDDING, UNICODE_RIGHT_TO_LEFT_EMBEDDING,
     797      UNICODE_LEFT_TO_RIGHT_OVERRIDE, UNICODE_RIGHT_TO_LEFT_OVERRIDE: exit(true);
     798    end;
     799    inc(p,charLen);
     800  end;
     801  exit(false);
     802end;
     803
     804function UTF8OverrideDirection(const sUTF8: string; ARightToLeft: boolean): string;
     805begin
     806  if ARightToLeft then
     807    result := UnicodeCharToUTF8(UNICODE_RIGHT_TO_LEFT_OVERRIDE) + sUTF8 + UnicodeCharToUTF8(UNICODE_POP_DIRECTIONAL_FORMATTING)
     808  else
     809    result := UnicodeCharToUTF8(UNICODE_LEFT_TO_RIGHT_OVERRIDE) + sUTF8 + UnicodeCharToUTF8(UNICODE_POP_DIRECTIONAL_FORMATTING);
     810end;
     811
     812function UTF8EmbedDirection(const sUTF8: string; ARightToLeft: boolean): string;
     813begin
     814  if ARightToLeft then
     815    result := UnicodeCharToUTF8(UNICODE_RIGHT_TO_LEFT_EMBEDDING) + sUTF8 + UnicodeCharToUTF8(UNICODE_POP_DIRECTIONAL_FORMATTING)
     816  else
     817    result := UnicodeCharToUTF8(UNICODE_LEFT_TO_RIGHT_EMBEDDING) + sUTF8 + UnicodeCharToUTF8(UNICODE_POP_DIRECTIONAL_FORMATTING);
     818end;
     819
     820//little endian stream functions
     821function LEReadInt64(Stream: TStream): int64;
     822begin
     823  Result := 0;
     824  stream.Read(Result, sizeof(Result));
     825  Result := LEtoN(Result);
     826end;
     827
     828procedure LEWriteInt64(Stream: TStream; AValue: int64);
     829begin
     830  AValue := NtoLE(AValue);
     831  stream.Write(AValue, sizeof(AValue));
     832end;
     833
     834function LEReadLongint(Stream: TStream): longint;
     835begin
     836  Result := 0;
     837  stream.Read(Result, sizeof(Result));
     838  Result := LEtoN(Result);
     839end;
     840
     841procedure LEWriteLongint(Stream: TStream; AValue: LongInt);
     842begin
     843  AValue := NtoLE(AValue);
     844  stream.Write(AValue, sizeof(AValue));
     845end;
     846
     847function LEReadByte(Stream: TStream): byte;
     848begin
     849  Result := 0;
     850  stream.Read(Result, sizeof(Result));
     851end;
     852
     853procedure LEWriteByte(Stream: TStream; AValue: Byte);
     854begin
     855  stream.Write(AValue, sizeof(AValue));
     856end;
     857
     858function LEReadSingle(Stream: TStream): single;
     859var
     860  ResultAsDWord : longword absolute result;
     861begin
     862  ResultAsDWord := 0;
     863  stream.Read(ResultAsDWord, sizeof(Result));
     864  ResultAsDWord := LEtoN(ResultAsDWord);
     865end;
     866
     867procedure LEWriteSingle(Stream: TStream; AValue: single);
     868var
     869  ValueAsDWord : longword absolute AValue;
     870begin
     871  ValueAsDWord := NtoLE(ValueAsDWord);
     872  stream.Write(ValueAsDWord, sizeof(AValue));
     873end;
     874
    517875end.
    518876
  • GraphicTest/Packages/bgrabitmap/bgravectorize.pas

    r494 r521  
    6363    ShadowOffset: TPoint;
    6464
    65     constructor Create;
    66     constructor Create(ADirectoryUTF8: string);
     65    constructor Create; overload;
     66    constructor Create(ADirectoryUTF8: string); overload;
    6767    function GetFontPixelMetric: TFontPixelMetric; override;
    68     procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientation: integer; s: string; c: TBGRAPixel; align: TAlignment); override;
    69     procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientation: integer; s: string; texture: IBGRAScanner; align: TAlignment); override;
    70     procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; s: string; texture: IBGRAScanner; align: TAlignment); override;
    71     procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; s: string; c: TBGRAPixel; align: TAlignment); override;
    72     procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; s: string; style: TTextStyle; c: TBGRAPixel); override;
    73     procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; s: string; style: TTextStyle; texture: IBGRAScanner); override;
     68    procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientation: integer; s: string; c: TBGRAPixel; align: TAlignment); overload; override;
     69    procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientation: integer; s: string; texture: IBGRAScanner; align: TAlignment); overload; override;
     70    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; s: string; texture: IBGRAScanner; align: TAlignment); overload; override;
     71    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; s: string; c: TBGRAPixel; align: TAlignment); overload; override;
     72    procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; s: string; style: TTextStyle; c: TBGRAPixel); overload; override;
     73    procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; s: string; style: TTextStyle; texture: IBGRAScanner); overload; override;
    7474    procedure CopyTextPathTo(ADest: IBGRAPath; x, y: single; s: string; align: TAlignment); override;
     75    function HandlesTextPath: boolean; override;
    7576    function TextSize(s: string): TSize; override;
     77    function TextSize(sUTF8: string; AMaxWidth: integer; {%H-}ARightToLeft: boolean): TSize; override;
     78    function TextFitInfo(sUTF8: string; AMaxWidth: integer): integer; override;
    7679    destructor Destroy; override;
    7780  end;
     
    151154  public
    152155    UnderlineDecoration,StrikeOutDecoration: boolean;
    153     constructor Create;
    154     constructor Create(AVectorizeLCL: boolean);
     156    constructor Create; overload;
     157    constructor Create(AVectorizeLCL: boolean); overload;
    155158    destructor Destroy; override;
    156159    function GetGlyphSize(AIdentifier:string): TPointF;
     
    162165      AAlign: TBGRATypeWriterAlignment=twaTopLeft); override;
    163166    procedure DrawTextWordBreak(ADest: TBGRACanvas2D; ATextUTF8: string; X, Y, MaxWidth: Single; AAlign: TBGRATypeWriterAlignment=twaTopLeft);
    164     procedure DrawTextRect(ADest: TBGRACanvas2D; ATextUTF8: string; X1,Y1,X2,Y2: Single; AAlign: TBGRATypeWriterAlignment=twaTopLeft);
    165     procedure DrawTextRect(ADest: TBGRACanvas2D; ATextUTF8: string; ATopLeft,ABottomRight: TPointF; AAlign: TBGRATypeWriterAlignment=twaTopLeft);
     167    procedure DrawTextRect(ADest: TBGRACanvas2D; ATextUTF8: string; X1,Y1,X2,Y2: Single; AAlign: TBGRATypeWriterAlignment=twaTopLeft); overload;
     168    procedure DrawTextRect(ADest: TBGRACanvas2D; ATextUTF8: string; ATopLeft,ABottomRight: TPointF; AAlign: TBGRATypeWriterAlignment=twaTopLeft); overload;
    166169    function GetTextWordBreakGlyphBoxes(ATextUTF8: string; X,Y, MaxWidth: Single; AAlign: TBGRATypeWriterAlignment = twaTopLeft): TGlyphBoxes;
    167     function GetTextRectGlyphBoxes(ATextUTF8: string; X1,Y1,X2,Y2: Single; AAlign: TBGRATypeWriterAlignment=twaTopLeft): TGlyphBoxes;
    168     function GetTextRectGlyphBoxes(ATextUTF8: string; ATopLeft,ABottomRight: TPointF; AAlign: TBGRATypeWriterAlignment=twaTopLeft): TGlyphBoxes;
     170    function GetTextRectGlyphBoxes(ATextUTF8: string; X1,Y1,X2,Y2: Single; AAlign: TBGRATypeWriterAlignment=twaTopLeft): TGlyphBoxes; overload;
     171    function GetTextRectGlyphBoxes(ATextUTF8: string; ATopLeft,ABottomRight: TPointF; AAlign: TBGRATypeWriterAlignment=twaTopLeft): TGlyphBoxes; overload;
    169172    procedure UpdateDirectory;
    170173    function LoadGlyphsInfo(AFilenameUTF8: string): TBGRAGlyphsInfo;
     
    190193implementation
    191194
    192 uses BGRAUTF8;
     195uses BGRAUTF8, math;
    193196
    194197function VectorizeMonochrome(ASource: TBGRACustomBitmap; zoom: single; PixelCenteredCoordinates: boolean): ArrayOfTPointF;
     
    234237    inc(nbpoints);
    235238  end;
    236   procedure AddLine(x1,y1,x2,y2: integer);
     239  procedure AddLine(x1,y1,x2,y2: integer); overload;
    237240  var i,j,k: integer;
    238241  begin
     
    267270    points[k].next := addpoint(x2,y2,k,-1);
    268271  end;
    269   procedure AddLine(x1,y1,x2,y2,x3,y3: integer);
     272  procedure AddLine(x1,y1,x2,y2,x3,y3: integer); overload;
    270273  begin
    271274    AddLine(x1,y1,x2,y2);
    272275    AddLine(x2,y2,x3,y3);
    273276  end;
    274   procedure AddLine(x1,y1,x2,y2,x3,y3,x4,y4: integer);
     277  procedure AddLine(x1,y1,x2,y2,x3,y3,x4,y4: integer); overload;
    275278  begin
    276279    AddLine(x1,y1,x2,y2);
     
    278281    AddLine(x3,y3,x4,y4);
    279282  end;
    280   procedure AddLine(x1,y1,x2,y2,x3,y3,x4,y4,x5,y5: integer);
     283  procedure AddLine(x1,y1,x2,y2,x3,y3,x4,y4,x5,y5: integer); overload;
    281284  begin
    282285    AddLine(x1,y1,x2,y2);
     
    12251228end;
    12261229
     1230function TBGRAVectorizedFontRenderer.HandlesTextPath: boolean;
     1231begin
     1232  Result:= true;
     1233end;
     1234
    12271235function TBGRAVectorizedFontRenderer.TextSize(s: string): TSize;
    12281236var sizeF: TPointF;
     
    12321240  result.cx := round(sizeF.x);
    12331241  result.cy := round(sizeF.y);
     1242end;
     1243
     1244function TBGRAVectorizedFontRenderer.TextSize(sUTF8: string;
     1245  AMaxWidth: integer; ARightToLeft: boolean): TSize;
     1246var
     1247  remains: string;
     1248  w,h,totalH: single;
     1249begin
     1250  UpdateFont;
     1251
     1252  result.cx := 0;
     1253  totalH := 0;
     1254  h := FVectorizedFont.FullHeight;
     1255  repeat
     1256    FVectorizedFont.SplitText(sUTF8, AMaxWidth, remains);
     1257    w := FVectorizedFont.GetTextSize(sUTF8).x;
     1258    if round(w)>result.cx then result.cx := round(w);
     1259    totalH += h;
     1260    sUTF8 := remains;
     1261  until remains = '';
     1262  result.cy := ceil(totalH);
     1263end;
     1264
     1265function TBGRAVectorizedFontRenderer.TextFitInfo(sUTF8: string;
     1266  AMaxWidth: integer): integer;
     1267var
     1268  remains: string;
     1269begin
     1270  UpdateFont;
     1271  FVectorizedFont.SplitText(sUTF8, AMaxWidth, remains);
     1272  result := length(sUTF8);
    12341273end;
    12351274
     
    13511390      FFont.Height := FontEmHeightSign * 100;
    13521391      lEmHeight := BGRATextSize(FFont, fqSystem, 'Hg', 1).cy;
    1353       FFont.Height := FontFullHeightSign * 100;
     1392      FFont.Height := FixLCLFontFullHeight(FFont.Name, FontFullHeightSign * 100);
    13541393      lFullHeight := BGRATextSize(FFont, fqSystem, 'Hg', 1).cy;
    13551394      if lEmHeight = 0 then
     
    13921431    FFont.Name := FName;
    13931432    FFont.Style := FStyle;
    1394     FFont.Height := FontFullHeightSign * FResolution;
     1433    FFont.Height := FixLCLFontFullHeight(FFont.Name, FontFullHeightSign * FResolution);
     1434    FFont.Quality := fqNonAntialiased;
    13951435    FFontEmHeightRatio := 1;
    13961436    FFontEmHeightRatioComputed := false;
     
    19602000    FBuffer.Fill(BGRAWhite);
    19612001    FBuffer.Canvas.Font := FFont;
    1962     FBuffer.Canvas.Font.Quality := fqNonAntialiased;
    19632002    FBuffer.Canvas.Font.Color := clBlack;
    19642003    FBuffer.Canvas.TextOut(size.cy div 2,0,AIdentifier);
  • GraphicTest/Packages/bgrabitmap/bgrawinbitmap.pas

    r494 r521  
    5353  public
    5454    procedure LoadFromBitmapIfNeeded; override;
    55     procedure Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean=True); override;
    56     procedure Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean = True); override;
    57     procedure DataDrawOpaque(ACanvas: TCanvas; Rect: TRect; AData: Pointer;
     55    procedure Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean=True); overload; override;
     56    procedure Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean = True); overload; override;
     57    procedure DataDrawOpaque(ACanvas: TCanvas; ARect: TRect; AData: Pointer;
    5858      ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); override;
    5959    procedure GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer); override;
     
    183183end;
    184184
    185 procedure TBGRAWinBitmap.DataDrawOpaque(ACanvas: TCanvas; Rect: TRect;
     185procedure TBGRAWinBitmap.DataDrawOpaque(ACanvas: TCanvas; ARect: TRect;
    186186  AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
    187187var
     
    206206
    207207  info := DIBitmapInfo(AWidth, AHeight);
    208   StretchDIBits(ACanvas.Handle, Rect.Left, Rect.Top, Rect.Right -
    209     Rect.Left, Rect.Bottom - Rect.Top,
     208  StretchDIBits(ACanvas.Handle, ARect.Left, ARect.Top, ARect.Right -
     209    ARect.Left, ARect.Bottom - ARect.Top,
    210210    0, 0, AWidth, AHeight, AData, info, DIB_RGB_COLORS, SRCCOPY);
    211211
  • GraphicTest/Packages/bgrabitmap/bgrawinresource.pas

    r494 r521  
    66
    77uses
    8   Classes, SysUtils, BGRAMultiFileType, BGRABitmapTypes;
     8  Classes, SysUtils, BGRAMultiFileType, BGRABitmapTypes, BGRAReadBMP;
    99
    1010const
     
    3131  RT_HTML = 23;
    3232  RT_MANIFEST = 24;
     33
     34  ICON_OR_CURSOR_FILE_ICON_TYPE = 1;
     35  ICON_OR_CURSOR_FILE_CURSOR_TYPE = 2;
    3336
    3437type
     
    9598    constructor Create(AContainer: TMultiFileContainer; ATypeNameOrId: TNameOrId; AEntryNameOrId: TNameOrId; const AResourceInfo: TResourceInfo; ADataStream: TStream);
    9699    destructor Destroy; override;
    97     function CopyTo(ADestination: TStream): integer; override;
     100    function CopyTo(ADestination: TStream): int64; override;
    98101  end;
    99102
     
    106109  public
    107110    constructor Create(AContainer: TMultiFileContainer; AEntryNameOrId: TNameOrId; const AResourceInfo: TResourceInfo; ADataStream: TStream);
    108     function CopyTo(ADestination: TStream): integer; override;
     111    function CopyTo(ADestination: TStream): int64; override;
    109112    procedure CopyFrom(ASource: TStream);
    110113  end;
     
    151154    constructor Create(AContainer: TMultiFileContainer; ATypeNameOrId: TNameOrId; AEntryNameOrId: TNameOrId; const AResourceInfo: TResourceInfo);
    152155    procedure Clear;
    153     function CopyTo(ADestination: TStream): integer; override;
     156    function CopyTo(ADestination: TStream): int64; override;
    154157    procedure CopyFrom(ASource: TStream);
    155158    property NbIcons: integer read GetNbIcons;
     
    206209implementation
    207210
    208 uses Math, BMPcomn, BGRAUTF8;
     211uses Math, BGRAUTF8;
    209212
    210213operator =(const ANameOrId1, ANameOrId2: TNameOrId): boolean;
     
    216219end;
    217220
    218 function NameOrId(AName: string): TNameOrId;
     221function NameOrId(AName: string): TNameOrId; overload;
    219222begin
    220223  result.Id := -1;
     
    222225end;
    223226
    224 function NameOrId(AId: integer): TNameOrId;
     227function NameOrId(AId: integer): TNameOrId; overload;
    225228begin
    226229  result.Id := AId;
     
    237240function TGroupCursorEntry.ExpectedResourceType: word;
    238241begin
    239   result := 2;
     242  result := ICON_OR_CURSOR_FILE_CURSOR_TYPE;
    240243end;
    241244
     
    262265function TGroupIconEntry.ExpectedResourceType: word;
    263266begin
    264   result := 1;
     267  result := ICON_OR_CURSOR_FILE_ICON_TYPE;
    265268end;
    266269
     
    371374end;
    372375
    373 function TGroupIconOrCursorEntry.CopyTo(ADestination: TStream): integer;
     376function TGroupIconOrCursorEntry.CopyTo(ADestination: TStream): int64;
    374377var
    375378  fileDir: packed array of TIconFileDirEntry;
     
    515518end;
    516519
    517 function TBitmapResourceEntry.CopyTo(ADestination: TStream): integer;
    518 var header: PBitMapInfoHeader;
    519   fileHeader: TBitMapFileHeader;
    520   headerSize: integer;
    521   extraSize: integer;
    522 
     520function TBitmapResourceEntry.CopyTo(ADestination: TStream): int64;
     521var fileHeader: TBitMapFileHeader;
    523522begin
    524523  result := 0;
    525524  FDataStream.Position := 0;
    526   headerSize := LEtoN(FDataStream.ReadDWord);
    527   if (headerSize < 16) or (headerSize > FDataStream.Size) then
    528     raise exception.Create('Invalid header size');
    529   getmem(header, headerSize);
    530   try
    531     fillchar(header^, headerSize,0);
    532     header^.Size := NtoLE(headerSize);
    533     FDataStream.ReadBuffer((PByte(header)+4)^, headerSize-4);
    534     if LEtoN(header^.Compression) = BI_BITFIELDS then
    535       extraSize := 4*3
    536     else if LEtoN(header^.BitCount) in [1,4,8] then
    537     begin
    538       if header^.ClrUsed > 0 then
    539         extraSize := 4*header^.ClrUsed
    540       else
    541         extraSize := 4*(1 shl header^.BitCount);
    542     end else
    543       extraSize := 0;
    544     fileHeader.bfType:= Word('BM');
    545     fileHeader.bfSize := NtoLE(Integer(sizeof(TBitMapFileHeader) + FDataStream.Size));
    546     fileHeader.bfReserved:= 0;
    547     fileHeader.bfOffset := NtoLE(Integer(sizeof(TBitMapFileHeader) + headerSize + extraSize));
    548     ADestination.WriteBuffer(fileHeader, sizeof(fileHeader));
    549     result += sizeof(fileHeader);
    550     ADestination.WriteBuffer(header^, headerSize);
    551     result += headerSize;
    552     if FDataStream.Size - headerSize > 0 then
    553       result += ADestination.CopyFrom(FDataStream, FDataStream.Size - headerSize);
    554   finally
    555     freemem(header);
    556   end;
     525  fileHeader := MakeBitmapFileHeader(FDataStream);
     526  ADestination.WriteBuffer(fileHeader, sizeof(fileHeader));
     527  result += sizeof(fileHeader);
     528  FDataStream.Position := 0;
     529  result += ADestination.CopyFrom(FDataStream, FDataStream.Size);
    557530end;
    558531
     
    633606end;
    634607
    635 function TUnformattedResourceEntry.CopyTo(ADestination: TStream): integer;
     608function TUnformattedResourceEntry.CopyTo(ADestination: TStream): int64;
    636609begin
    637610  if FDataStream.Size > 0 then
     
    10391012  'ico': begin
    10401013           result := TGroupIconEntry.Create(self, entryName, resourceInfo);
     1014           AContent.Position:= 0;
    10411015           TGroupIconEntry(result).CopyFrom(AContent);
     1016           AContent.Free;
    10421017         end;
    10431018  'cur': begin
    10441019           result := TGroupCursorEntry.Create(self, entryName, resourceInfo);
     1020           AContent.Position:= 0;
    10451021           TGroupCursorEntry(result).CopyFrom(AContent);
     1022           AContent.Free;
    10461023         end;
    10471024  'bmp': begin
    10481025           result := TBitmapResourceEntry.Create(self, entryName, resourceInfo, AContent);
     1026           AContent.Position:= 0;
    10491027           TBitmapResourceEntry(result).CopyFrom(AContent);
     1028           AContent.Free;
    10501029         end;
    10511030  'dat': result := TUnformattedResourceEntry.Create(self, NameOrId(RT_RCDATA), entryName, resourceInfo, AContent);
  • GraphicTest/Packages/bgrabitmap/bgrawritelzp.pas

    r494 r521  
    148148    begin
    149149      IncludeThumbnail := false;
    150       header.compressionMode:= CompressionMode;
     150      header.compressionMode:= CompressionMode; //update field for thumbnail
    151151    end;
    152152
    153153  header.previewOffset:= Str.Position - startPos;
    154154  if Compression = lzpRLE then
    155     WriteRLEImage(Str, Img)
     155    WriteRLEImage(Str, Img, Caption)
    156156  else
    157157  begin
    158158    compBmp := TBGRACompressableBitmap.Create(Img as TBGRABitmap);
     159    compBmp.Caption := Caption;
    159160    compBmp.WriteToStream(Str);
    160161    compBmp.Free;
  • GraphicTest/Packages/bgrabitmap/bgrawritepng.pas

    r494 r521  
    8080      function  DoFilter (LineFilter:byte;index:longword; b:byte) : byte; virtual;
    8181      procedure SetChunkLength (aValue : longword);
    82       procedure SetChunkType (ct : TChunkTypes);
    83       procedure SetChunkType (ct : TChunkCode);
     82      procedure SetChunkType (ct : TChunkTypes); overload;
     83      procedure SetChunkType (ct : TChunkCode); overload;
    8484      function DecideGetPixel : TGetPixelFunc; virtual;
    8585      procedure DetermineHeader (var AHeader : THeaderChunk); virtual;
  • GraphicTest/Packages/bgrabitmap/csscolorconst.inc

    r494 r521  
    9999    constructor Create;
    100100    {** Add a color to the list }
    101     procedure Add(Name: string; const Color: TBGRAPixel);
     101    procedure Add(Name: string; const Color: TBGRAPixel); overload;
    102102    {** Ends the color list and prevents further modifications }
    103103    procedure Finished;
     
    137137{* Converts a fully defined string into a ''TBGRAPixel'' value. Color names from ''VGAColors'' and ''CSSColors''
    138138   are used if there is an exact match }
    139 function StrToBGRA(str: string): TBGRAPixel;
     139function StrToBGRA(str: string): TBGRAPixel; overload;
    140140{* Converts a string into a ''TBGRAPixel'' value. If the value is not fully defined or that
    141141   there is an error, ''DefaultColor'' is returned.
    142142   Color names from ''VGAColors'' and ''CSSColors'' are used if there is an exact match. }
    143 function StrToBGRA(str: string; const DefaultColor: TBGRAPixel): TBGRAPixel;
     143function StrToBGRA(str: string; const DefaultColor: TBGRAPixel): TBGRAPixel; overload;
    144144{* Converts a string into a ''TBGRAPixel'' value. If the value is not fully defined, missing channels (expressed with '?')
    145145   are filled with fallbackValues. You can check if there was an error with the provided boolean.
     
    311311function ParseColorValue(str: string; var flagError: boolean): byte;
    312312var pourcent,unclipped,{%H-}errPos: integer;
     313  pourcentF: single;
     314  pourcentStr: string;
    313315begin
    314316  if str = '' then result := 0 else
     
    316318    if str[length(str)]='%' then
    317319    begin
    318       val(copy(str,1,length(str)-1),pourcent,errPos);
    319       if errPos <> 0 then flagError := true;
    320       if pourcent < 0 then result := 0 else
    321       if pourcent > 100 then result := 255 else
    322         result := pourcent*255 div 100;
     320      pourcentStr := copy(str,1,length(str)-1);
     321      val(pourcentStr,pourcent,errPos);
     322      if errPos <> 0 then
     323      begin
     324        val(pourcentStr,pourcentF,errPos);
     325        if errPos <> 0 then
     326        begin
     327          flagError := true;
     328          result := 0;
     329        end
     330        else
     331        begin
     332          if pourcentF < 0 then result := 0 else
     333          if pourcentF > 100 then result := 255 else
     334           result := round(pourcentF*255 / 100);
     335        end;
     336      end else
     337      begin
     338         if pourcent < 0 then result := 0 else
     339         if pourcent > 100 then result := 255 else
     340           result := pourcent*255 div 100;
     341      end;
    323342    end else
    324343    begin
  • GraphicTest/Packages/bgrabitmap/geometrytypes.inc

    r494 r521  
    1919  {$endif}
    2020
     21  {* Contains an array of points with single-precision floating point coordinates }
     22  ArrayOfTPointF = array of TPointF;
     23
     24  {* An affine matrix contains three 2D vectors: the image of x, the image of y and the translation }
    2125  TAffineMatrix = array[1..2,1..3] of single;
    2226
     
    2428  TRectF = Types.TRectF;
    2529  {$else}
     30  {$define BGRA_DEFINE_TRECTF}
     31  { TRectF }
     32
    2633  TRectF =
    2734  {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
     
    2936  {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
    3037  record
     38  private
     39    function GetHeight: single;
     40    function GetWidth: Single;
     41  public
     42    property Width: Single read GetWidth;
     43    property Height: single read GetHeight;
     44    procedure Offset (const dx,dy : Single);
    3145    case Integer of
    3246     0: (Left, Top, Right, Bottom: Single);
    3347     1: (TopLeft, BottomRight: TPointF);
    3448  end;
     49
     50  { TRectHelper }
     51
     52  TRectHelper = record helper for TRect
     53  private
     54    function GetHeight: integer;
     55    function GetIsEmpty: boolean;
     56    function GetWidth: integer;
     57    procedure SetHeight(AValue: integer);
     58    procedure SetWidth(AValue: integer);
     59  public
     60    constructor Create(Origin: TPoint; AWidth, AHeight: Longint); overload;
     61    constructor Create(ALeft, ATop, ARight, ABottom: Longint); overload;
     62    procedure Intersect(const ARect: TRect);
     63    procedure Offset(DX, DY: Longint);
     64    procedure Inflate(DX, DY: Longint);
     65    function Contains(const APoint: TPoint): boolean; overload;
     66    function Contains(const ARect: TRect): boolean; overload;
     67    property Width: integer read GetWidth write SetWidth;
     68    property Height: integer read GetHeight write SetHeight;
     69    property IsEmpty: boolean read GetIsEmpty;
     70  end;
     71
     72operator=(const ARect1,ARect2: TRect): boolean;
     73
     74type
     75  { TSizeHelper }
     76
     77  TSizeHelper = record helper for TSize
     78  private
     79    function GetHeight: integer;
     80    function GetWidth: integer;
     81  public
     82    property Width: integer read GetWidth;
     83    property Height: integer read GetHeight;
     84  end;
     85
    3586  {$endif}
     87
     88const
     89  EmptyPoint : TPoint = (X: -2147483648; Y: -2147483648);
     90
     91function IsEmptyPoint(const APoint: TPoint): boolean;
     92
     93type
     94  TPointFHelper = record helper for TPointF
     95    function Ceiling: TPoint;
     96    function Truncate: TPoint;
     97    function Floor: TPoint;
     98    function Round: TPoint;
     99    function Length: Single;
     100  end;
     101
     102type
     103  PRectF = ^TRectF;
     104
     105  { TRectFHelper }
     106
     107  TRectFHelper = record helper for TRectF
     108    class function Intersect(const R1: TRectF; const R2: TRectF): TRectF; overload; static;
     109    class function Union(const R1: TRectF; const R2: TRectF): TRectF; overload; static;
     110    class function Union(const R1: TRectF; const R2: TRectF; ADiscardEmpty: boolean): TRectF; overload; static;
     111    function Union(const r: TRectF):TRectF;
     112    function Union(const r: TRectF; ADiscardEmpty: boolean):TRectF;
     113    function IntersectsWith(const r: TRectF): boolean;
     114    function IsEmpty: boolean;
     115  end;
     116
     117const
     118  {* A value for an empty rectangle }
     119  EmptyRectF : TRectF = (left:0; top:0; right:0; bottom: 0);
     120
    36121  function RectF(Left, Top, Right, Bottom: Single): TRectF;
     122  function RectF(const ATopLeft,ABottomRight: TPointF): TRectF;
     123  function RectWithSizeF(left,top,width,height: Single): TRectF;
     124  function IsEmptyRectF(const ARect:TRectF): boolean;
     125
     126type
     127  { TAffineBox }
     128
     129  TAffineBox = object
     130  private
     131    function GetAsPolygon: ArrayOfTPointF;
     132    function GetBottomRight: TPointF;
     133    function GetHeight: single;
     134    function GetIsEmpty: boolean;
     135    function GetRectBounds: TRect;
     136    function GetRectBoundsF: TRectF;
     137    function GetSurface: single;
     138    function GetWidth: single;
     139  public
     140    TopLeft, TopRight,
     141    BottomLeft: TPointF;
     142    class function EmptyBox: TAffineBox; static;
     143    class function AffineBox(ATopLeft, ATopRight, ABottomLeft: TPointF): TAffineBox; static; overload;
     144    class function AffineBox(ARectF: TRectF): TAffineBox; static; overload;
     145    function Contains(APoint: TPointF): boolean;
     146    property RectBounds: TRect read GetRectBounds;
     147    property RectBoundsF: TRectF read GetRectBoundsF;
     148    property BottomRight: TPointF read GetBottomRight;
     149    property IsEmpty: boolean read GetIsEmpty;
     150    property AsPolygon: ArrayOfTPointF read GetAsPolygon;
     151    property Width: single read GetWidth;
     152    property Height: single read GetHeight;
     153    property Surface: single read GetSurface;
     154  end;
    37155
    38156  const
     
    43161  {----------------- Operators for TPointF --------------------}
    44162  {** Creates a new structure with values ''x'' and ''y'' }
    45   function PointF(x, y: single): TPointF;
     163  function PointF(x, y: single): TPointF; overload;
     164  function PointF(pt: TPoint): TPointF; overload;
    46165  {** Checks if the structure is empty (equal to ''EmptyPointF'') }
    47166  function isEmptyPointF(const pt: TPointF): boolean;
     
    68187type
    69188  TFaceCulling = (fcNone, fcKeepCW, fcKeepCCW);
    70   {* Contains an array of points with single-precision floating point coordinates }
    71   ArrayOfTPointF = array of TPointF;
    72189
    73190  {** Creates an array of ''TPointF'' }
     
    109226    ssRoundOutside,
    110227    {** The curve is outside the polygonal envelope and there is a tangeant at vertices (starting and ending points are reached) }
    111     ssVertexToSide);
    112 
    113   { TCubicBezierCurve }
    114   {* Definition of a Bézier curve of order 3. It has two control points ''c1'' and ''c2''. Those are not reached by the curve }
    115   TCubicBezierCurve = object
    116   private
    117     function SimpleComputePoints(AAcceptedDeviation: single = 0.1; AIncludeFirstPoint: boolean = true): ArrayOfTPointF;
    118   public
    119     {** Starting point (reached) }
    120     p1: TPointF;
    121     {** First control point (not reached by the curve) }
    122     c1: TPointF;
    123     {** Second control point (not reached by the curve) }
    124     c2: TPointF;
    125     {** Ending point (reached) }
    126     p2: TPointF;
    127     {** Computes the point at time ''t'', varying from 0 to 1 }
    128     function ComputePointAt(t: single): TPointF;
    129     {** Split the curve in two such that ''ALeft.p2'' = ''ARight.p1'' }
    130     procedure Split(out ALeft, ARight: TCubicBezierCurve);
    131     {** Compute an approximation of the length of the curve. ''AAcceptedDeviation'' indicates the
    132        maximum orthogonal distance that is ignored and approximated by a straight line. }
    133     function ComputeLength(AAcceptedDeviation: single = 0.1): single;
    134     {** Computes a polygonal approximation of the curve. ''AAcceptedDeviation'' indicates the
    135        maximum orthogonal distance that is ignored and approximated by a straight line.
    136        ''AIncludeFirstPoint'' indicates if the first point must be included in the array }
    137     function ToPoints(AAcceptedDeviation: single = 0.1; AIncludeFirstPoint: boolean = true): ArrayOfTPointF;
    138     function GetBounds: TRectF;
    139   end;
    140 
    141   {** Creates a structure for a cubic Bézier curve }
    142   function BezierCurve(origin, control1, control2, destination: TPointF) : TCubicBezierCurve; overload;
    143 
    144 type
    145   { TQuadraticBezierCurve }
    146   {* Definition of a Bézier curve of order 2. It has one control point }
    147   TQuadraticBezierCurve = object
    148   private
    149     function SimpleComputePoints(AAcceptedDeviation: single = 0.1; AIncludeFirstPoint: boolean = true): ArrayOfTPointF;
    150     function ComputeExtremumPositionOutsideSegment: single;
    151   public
    152     {** Starting point (reached) }
    153     p1: TPointF;
    154     {** Control point (not reached by the curve) }
    155     c: TPointF;
    156     {** Ending point (reached) }
    157     p2: TPointF;
    158     {** Computes the point at time ''t'', varying from 0 to 1 }
    159     function ComputePointAt(t: single): TPointF;
    160     {** Split the curve in two such that ''ALeft.p2'' = ''ARight.p1'' }
    161     procedure Split(out ALeft, ARight: TQuadraticBezierCurve);
    162     {** Compute the '''exact''' length of the curve }
    163     function ComputeLength: single;
    164     {** Computes a polygonal approximation of the curve. ''AAcceptedDeviation'' indicates the
    165        maximum orthogonal distance that is ignored and approximated by a straight line.
    166        ''AIncludeFirstPoint'' indicates if the first point must be included in the array }
    167     function ToPoints(AAcceptedDeviation: single = 0.1; AIncludeFirstPoint: boolean = true): ArrayOfTPointF;
    168     function GetBounds: TRectF;
    169   end;
    170 
    171   {** Creates a structure for a quadratic Bézier curve }
    172   function BezierCurve(origin, control, destination: TPointF) : TQuadraticBezierCurve; overload;
    173   {** Creates a structure for a quadratic Bézier curve without curvature }
    174   function BezierCurve(origin, destination: TPointF) : TQuadraticBezierCurve; overload;
     228    ssVertexToSide,
     229    {** The curve is rounded using Bezier curves when the angle is less than or equal to 45° }
     230    ssEasyBezier);
    175231
    176232type
     
    271327      procedure SetStrokeMatrix(const AValue: TAffineMatrix); virtual; abstract;
    272328  public
    273       function ComputePolyline(const APoints: array of TPointF; AWidth: single; AClosedCap: boolean = true): ArrayOfTPointF; virtual; abstract;
    274       function ComputePolyline(const APoints: array of TPointF; AWidth: single; APenColor: TBGRAPixel; AClosedCap: boolean = true): ArrayOfTPointF; virtual; abstract;
     329      function ComputePolyline(const APoints: array of TPointF; AWidth: single; AClosedCap: boolean = true): ArrayOfTPointF; overload; virtual; abstract;
     330      function ComputePolyline(const APoints: array of TPointF; AWidth: single; APenColor: TBGRAPixel; AClosedCap: boolean = true): ArrayOfTPointF; overload; virtual; abstract;
    275331      function ComputePolylineAutoCycle(const APoints: array of TPointF; AWidth: single): ArrayOfTPointF; virtual; abstract;
    276332      function ComputePolygon(const APoints: array of TPointF; AWidth: single): ArrayOfTPointF; virtual; abstract;
     
    325381  {** Computes the intersection of two lines. If they are parallel, returns
    326382      the middle of the segment between the two origins }
    327   function IntersectLine(line1, line2: TLineDef): TPointF;
     383  function IntersectLine(line1, line2: TLineDef): TPointF; overload;
    328384  {** Computes the intersection of two lines. If they are parallel, returns
    329385      the middle of the segment between the two origins. The value ''parallel''
    330386      is set to indicate if the lines were parallel }
    331   function IntersectLine(line1, line2: TLineDef; out parallel: boolean): TPointF;
     387  function IntersectLine(line1, line2: TLineDef; out parallel: boolean): TPointF; overload;
    332388  {** Checks if the polygon formed by the given points is convex. ''IgnoreAlign''
    333389      specifies that if the points are aligned, it should still be considered as convex }
     
    348404    procedure closePath;
    349405    {** Moves to a location, disconnected from previous points }
    350     procedure moveTo(const pt: TPointF);
     406    procedure moveTo(constref pt: TPointF);
    351407    {** Adds a line from the current point }
    352     procedure lineTo(const pt: TPointF);
     408    procedure lineTo(constref pt: TPointF);
    353409    {** Adds a polyline from the current point }
    354410    procedure polylineTo(const pts: array of TPointF);
    355411    {** Adds a quadratic Bézier curve from the current point }
    356     procedure quadraticCurveTo(const cp,pt: TPointF);
     412    procedure quadraticCurveTo(constref cp,pt: TPointF);
    357413    {** Adds a cubic Bézier curve from the current point }
    358     procedure bezierCurveTo(const cp1,cp2,pt: TPointF);
     414    procedure bezierCurveTo(constref cp1,cp2,pt: TPointF);
    359415    {** Adds an arc. If there is a current point, it is connected to the beginning of the arc }
    360     procedure arc(const arcDef: TArcDef);
     416    procedure arc(constref arcDef: TArcDef);
    361417    {** Adds an opened spline. If there is a current point, it is connected to the beginning of the spline }
    362418    procedure openedSpline(const pts: array of TPointF; style: TSplineStyle);
     
    366422    procedure copyTo(dest: IBGRAPath);
    367423    {** Returns the content of the path as an array of points }
    368     function getPoints: ArrayOfTPointF;
     424    function getPoints: ArrayOfTPointF; overload;
    369425    {** Returns the content of the path as an array of points with the transformation specified by ''AMatrix'' }
    370     function getPoints(AMatrix: TAffineMatrix): ArrayOfTPointF;
     426    function getPoints(AMatrix: TAffineMatrix): ArrayOfTPointF; overload;
    371427    {** Returns a cursor to go through the path. The cursor must be freed by calling ''Free''. }
    372428    function getCursor: TBGRACustomPathCursor;
    373429  end;
     430
     431  { TBGRACustomPath }
     432
     433  TBGRACustomPath = class(IBGRAPath)
     434    constructor Create; virtual; abstract;
     435    procedure beginPath; virtual; abstract;
     436    procedure closePath; virtual; abstract;
     437    procedure moveTo(constref pt: TPointF); virtual; abstract;
     438    procedure lineTo(constref pt: TPointF); virtual; abstract;
     439    procedure polylineTo(const pts: array of TPointF); virtual; abstract;
     440    procedure quadraticCurveTo(constref cp,pt: TPointF); virtual; abstract;
     441    procedure bezierCurveTo(constref cp1,cp2,pt: TPointF); virtual; abstract;
     442    procedure arc(constref arcDef: TArcDef); virtual; abstract;
     443    procedure openedSpline(const pts: array of TPointF; style: TSplineStyle); virtual; abstract;
     444    procedure closedSpline(const pts: array of TPointF; style: TSplineStyle); virtual; abstract;
     445    procedure copyTo(dest: IBGRAPath); virtual; abstract;
     446  protected
     447    function getPoints: ArrayOfTPointF; virtual; abstract;
     448    function getPoints(AMatrix: TAffineMatrix): ArrayOfTPointF; virtual; abstract;
     449    function getLength: single; virtual; abstract;
     450    function getCursor: TBGRACustomPathCursor; virtual; abstract;
     451  protected
     452    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};
     453    function _AddRef: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
     454    function _Release: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
     455  end;
     456
     457  TBGRAPathAny = class of TBGRACustomPath;
    374458
    375459  { TBGRACustomPathCursor }
     
    420504  end;
    421505
     506var
     507  BGRAPathFactory: TBGRAPathAny;
     508
    422509const
    423510  {* A value for an empty rectangle }
     
    428515{* Creates a rectangle with the specified ''width'' and ''height'' }
    429516function RectWithSize(left,top,width,height: integer): TRect;
     517
     518{$DEFINE INCLUDE_INTERFACE}
     519{$I bezier.inc}
    430520
    431521type
     
    501591    gtDiamond,
    502592    {** The color changes in a radial way from a given center }
    503     gtRadial);
     593    gtRadial,
     594    {** The color changes according to the angle relative to a given center }
     595    gtAngular);
    504596const
    505597  {** List of string to represent gradient types }
    506598  GradientTypeStr : array[TGradientType] of string
    507   = ('Linear','Reflected','Diamond','Radial');
     599  = ('Linear','Reflected','Diamond','Radial','Angular');
    508600  {** Returns the gradient type represented by the given string }
    509601  function StrToGradientType(str: string): TGradientType;
     
    539631{$UNDEF INCLUDE_IMPLEMENTATION}
    540632
     633{$IFDEF BGRA_DEFINE_TRECTF}
     634{ TRectF }
     635
     636function TRectF.GetHeight: single;
     637begin
     638  result := Bottom-Top;
     639end;
     640
     641function TRectF.GetWidth: Single;
     642begin
     643  result := Right-Left;
     644end;
     645
     646procedure TRectF.Offset(const dx, dy: Single);
     647begin
     648  left:=left+dx; right:=right+dx;
     649  bottom:=bottom+dy; top:=top+dy;
     650end;
     651
     652{ TRectHelper }
     653
     654function TRectHelper.GetHeight: integer;
     655begin
     656  result := Bottom-Top;
     657end;
     658
     659function TRectHelper.GetIsEmpty: boolean;
     660begin
     661  result := (Width = 0) and (Height = 0)
     662end;
     663
     664function TRectHelper.GetWidth: integer;
     665begin
     666  result := Right-Left;
     667end;
     668
     669procedure TRectHelper.SetHeight(AValue: integer);
     670begin
     671  Bottom := Top+AValue;
     672end;
     673
     674procedure TRectHelper.SetWidth(AValue: integer);
     675begin
     676  Right := Left+AValue;
     677end;
     678
     679constructor TRectHelper.Create(Origin: TPoint; AWidth, AHeight: Longint);
     680begin
     681  self.Left := Origin.X;
     682  self.Top := Origin.Y;
     683  self.Right := Origin.X+AWidth;
     684  self.Bottom := Origin.Y+AHeight;
     685end;
     686
     687constructor TRectHelper.Create(ALeft, ATop, ARight, ABottom: Longint);
     688begin
     689  self.Left := ALeft;
     690  self.Top := ATop;
     691  self.Right := ARight;
     692  self.Bottom := ABottom;
     693end;
     694
     695procedure TRectHelper.Intersect(const ARect: TRect);
     696begin
     697  IntersectRect(self, self, ARect);
     698end;
     699
     700procedure TRectHelper.Offset(DX, DY: Longint);
     701begin
     702  OffsetRect(self, DX,DY);
     703end;
     704
     705procedure TRectHelper.Inflate(DX, DY: Longint);
     706begin
     707  InflateRect(self, DX,DY);
     708end;
     709
     710function TRectHelper.Contains(const APoint: TPoint): boolean;
     711begin
     712  result := (APoint.X >= Left) and (APoint.X <= Right) and
     713    (APoint.Y >= Top) and (APoint.Y <= Bottom);
     714end;
     715
     716function TRectHelper.Contains(const ARect: TRect): boolean;
     717begin
     718  Result := (Left <= ARect.Left) and (ARect.Right <= Right) and (Top <= ARect.Top) and (ARect.Bottom <= Bottom);
     719end;
     720
     721operator =(const ARect1, ARect2: TRect): boolean;
     722begin
     723  result:= (ARect1.Left = ARect2.Left) and (ARect1.Top = ARect2.Top) and
     724           (ARect1.Right = ARect2.Right) and (ARect1.Bottom = ARect2.Bottom);
     725end;
     726
     727{ TSizeHelper }
     728
     729function TSizeHelper.GetHeight: integer;
     730begin
     731  result := cy;
     732end;
     733
     734function TSizeHelper.GetWidth: integer;
     735begin
     736  result := cx;
     737end;
     738
     739{$ENDIF}
     740
     741function IsEmptyPoint(const APoint: TPoint): boolean;
     742begin
     743  result := (APoint.x = -2147483648) or (APoint.y = -2147483648);
     744end;
     745
     746function TPointFHelper.Ceiling: TPoint;
     747begin
     748  if isEmptyPointF(self) then
     749    result := EmptyPoint
     750  else
     751  begin
     752    result.x:=ceil(x);
     753    result.y:=ceil(y);
     754  end;
     755end;
     756
     757function TPointFHelper.Truncate: TPoint;
     758begin
     759  if isEmptyPointF(self) then
     760    result := EmptyPoint
     761  else
     762  begin
     763    result.x:=trunc(x);
     764    result.y:=trunc(y);
     765  end;
     766end;
     767
     768function TPointFHelper.Floor: TPoint;
     769begin
     770  if isEmptyPointF(self) then
     771    result := EmptyPoint
     772  else
     773  begin
     774    result.x:=Math.floor(x);
     775    result.y:=Math.floor(y);
     776  end;
     777end;
     778
     779function TPointFHelper.Round: TPoint;
     780begin
     781  if isEmptyPointF(self) then
     782    result := EmptyPoint
     783  else
     784  begin
     785    result.x:=System.round(x);
     786    result.y:=System.round(y);
     787  end;
     788end;
     789
     790function TPointFHelper.Length: Single;
     791begin
     792  result:= VectLen(self);
     793end;
     794
     795class function TRectFHelper.Intersect(const R1: TRectF; const R2: TRectF): TRectF;
     796begin
     797  result.left:=max(R1.left,R2.left);
     798  result.top:=max(R1.top,R2.top);
     799  result.right:=min(R1.right,R2.right);
     800  result.bottom:=min(R1.bottom,R2.bottom);
     801  if (result.left >= result.right) or (result.top >= result.bottom) then
     802    result := EmptyRectF;
     803end;
     804
     805class function TRectFHelper.Union(const R1: TRectF; const R2: TRectF): TRectF;
     806begin
     807  result.left:=min(R1.left,R2.left);
     808  result.top:=min(R1.top,R2.top);
     809  result.right:=max(R1.right,R2.right);
     810  result.bottom:=max(R1.bottom,R2.bottom);
     811end;
     812
     813class function TRectFHelper.Union(const R1: TRectF; const R2: TRectF; ADiscardEmpty: boolean): TRectF;
     814begin
     815  if ADiscardEmpty and IsEmptyRectF(R1) then result:= R2 else
     816  if ADiscardEmpty and IsEmptyRectF(R2) then result:= R1 else
     817    result := Union(R1,R2);
     818end;
     819
     820function TRectFHelper.Union(const r: TRectF): TRectF;
     821begin
     822  result := TRectF.Union(self, r);
     823end;
     824
     825function TRectFHelper.Union(const r: TRectF; ADiscardEmpty: boolean): TRectF;
     826begin
     827  result := TRectF.Union(self, r, ADiscardEmpty);
     828end;
     829
     830function TRectFHelper.IntersectsWith(const r: TRectF): boolean;
     831begin
     832  result:= not TRectF.Intersect(self, r).IsEmpty;
     833end;
     834
     835function TRectFHelper.IsEmpty: boolean;
     836begin
     837  result:= IsEmptyRectF(self);
     838end;
     839
     840{ TAffineBox }
     841
     842function TAffineBox.GetAsPolygon: ArrayOfTPointF;
     843begin
     844  result := PointsF([TopLeft,TopRight,BottomRight,BottomLeft]);
     845end;
     846
     847function TAffineBox.GetBottomRight: TPointF;
     848begin
     849  if IsEmpty then
     850    result := EmptyPointF
     851  else
     852    result := TopRight + (BottomLeft-TopLeft);
     853end;
     854
     855function TAffineBox.GetHeight: single;
     856begin
     857  if isEmptyPointF(TopLeft) or isEmptyPointF(BottomLeft) then
     858    result := 0
     859  else
     860    result := VectLen(BottomLeft-TopLeft);
     861end;
     862
     863function TAffineBox.GetIsEmpty: boolean;
     864begin
     865  result := isEmptyPointF(TopRight) or isEmptyPointF(BottomLeft) or isEmptyPointF(TopLeft);
     866end;
     867
     868function TAffineBox.GetRectBounds: TRect;
     869begin
     870  with GetRectBoundsF do
     871    result := Rect(floor(Left),floor(Top),ceil(Right),ceil(Bottom));
     872end;
     873
     874function TAffineBox.GetRectBoundsF: TRectF;
     875var
     876  x1,y1,x2,y2: single;
     877begin
     878  x1 := TopLeft.x; x2 := x1;
     879  y1 := TopLeft.y; y2 := y1;
     880  if TopRight.x > x2 then x2 := TopRight.x;
     881  if TopRight.x < x1 then x1 := TopRight.x;
     882  if TopRight.y > y2 then y2 := TopRight.y;
     883  if TopRight.y < y1 then y1 := TopRight.y;
     884  if BottomLeft.x > x2 then x2 := BottomLeft.x;
     885  if BottomLeft.x < x1 then x1 := BottomLeft.x;
     886  if BottomLeft.y > y2 then y2 := BottomLeft.y;
     887  if BottomLeft.y < y1 then y1 := BottomLeft.y;
     888  if BottomRight.x > x2 then x2 := BottomRight.x;
     889  if BottomRight.x < x1 then x1 := BottomRight.x;
     890  if BottomRight.y > y2 then y2 := BottomRight.y;
     891  if BottomRight.y < y1 then y1 := BottomRight.y;
     892  result := RectF(x1,y1,x2,y2);
     893end;
     894
     895function TAffineBox.GetSurface: single;
     896var
     897  u, v: TPointF;
     898  lenU, lenH: Single;
     899begin
     900  u := TopRight-TopLeft;
     901  lenU := VectLen(u);
     902  if lenU = 0 then exit(0);
     903  u *= 1/lenU;
     904  v := BottomLeft-TopLeft;
     905  lenH := PointF(-u.y,u.x)*v;
     906  result := abs(lenU*lenH);
     907end;
     908
     909function TAffineBox.GetWidth: single;
     910begin
     911  if isEmptyPointF(TopLeft) or isEmptyPointF(TopRight) then
     912    result := 0
     913  else
     914    result := VectLen(TopRight-TopLeft);
     915end;
     916
     917class function TAffineBox.EmptyBox: TAffineBox;
     918begin
     919  result.TopLeft := EmptyPointF;
     920  result.TopRight := EmptyPointF;
     921  result.BottomLeft := EmptyPointF;
     922end;
     923
     924class function TAffineBox.AffineBox(ATopLeft, ATopRight, ABottomLeft: TPointF): TAffineBox;
     925begin
     926  result.TopLeft := ATopLeft;
     927  result.TopRight := ATopRight;
     928  result.BottomLeft := ABottomLeft;
     929end;
     930
     931class function TAffineBox.AffineBox(ARectF: TRectF): TAffineBox;
     932begin
     933  result.TopLeft := ARectF.TopLeft;
     934  result.TopRight := PointF(ARectF.Right, ARectF.Top);
     935  result.BottomLeft := PointF(ARectF.Left, ARectF.Bottom);
     936end;
     937
     938function TAffineBox.Contains(APoint: TPointF): boolean;
     939var
     940  u,v,perpU,perpV: TPointF;
     941  posV1, posV2, posU1, posU2: single;
     942begin
     943  if IsEmpty then exit(false);
     944
     945  u := TopRight-TopLeft;
     946  perpU := PointF(-u.y,u.x);
     947  v := BottomLeft-TopLeft;
     948  perpV := PointF(v.y,-v.x);
     949
     950  //reverse normal if not in the same direction as other side
     951  if perpU*v < 0 then
     952  begin
     953    perpU := -perpU;
     954    perpV := -perpV;
     955  end;
     956
     957  //determine position along normals
     958  posU1 := (APoint-TopLeft)*perpU;
     959  posU2 := (APoint-BottomLeft)*perpU;
     960  posV1 := (APoint-TopLeft)*perpV;
     961  posV2 := (APoint-TopRight)*perpV;
     962
     963  result := (posU1 >= 0) and (posU2 < 0) and (posV1 >= 0) and (posV2 < 0);
     964end;
     965
    541966function StrToGradientType(str: string): TGradientType;
    542967var gt: TGradientType;
     
    6671092end;
    6681093
    669 //-------------- Bézier curves definitions ----------------
    670 // See : http://en.wikipedia.org/wiki/B%C3%A9zier_curve
    671 
    672 // Define a Bézier curve with two control points.
    673 function BezierCurve(origin, control1, control2, destination: TPointF): TCubicBezierCurve;
    674 begin
    675   result.p1 := origin;
    676   result.c1 := control1;
    677   result.c2 := control2;
    678   result.p2 := destination;
    679 end;
    680 
    681 // Define a Bézier curve with one control point.
    682 function BezierCurve(origin, control, destination: TPointF
    683   ): TQuadraticBezierCurve;
    684 begin
    685   result.p1 := origin;
    686   result.c := control;
    687   result.p2 := destination;
    688 end;
    689 
    690 //straight line
    691 function BezierCurve(origin, destination: TPointF): TQuadraticBezierCurve;
    692 begin
    693   result.p1 := origin;
    694   result.c := (origin+destination)*0.5;
    695   result.p2 := destination;
     1094{ TBGRACustomPath }
     1095
     1096function TBGRACustomPath.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};
     1097begin
     1098  if GetInterface(iid, obj) then
     1099    Result := S_OK
     1100  else
     1101    Result := longint(E_NOINTERFACE);
     1102end;
     1103
     1104{ There is no automatic reference counting, but it is compulsory to define these functions }
     1105function TBGRACustomPath._AddRef: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
     1106begin
     1107  result := 0;
     1108end;
     1109
     1110function TBGRACustomPath._Release: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
     1111begin
     1112  result := 0;
    6961113end;
    6971114
     
    8321249end;
    8331250
     1251function RectF(const ATopLeft, ABottomRight: TPointF): TRectF;
     1252begin
     1253  result.TopLeft:= ATopLeft;
     1254  result.BottomRight:= ABottomRight;
     1255end;
     1256
     1257function RectWithSizeF(left, top, width, height: Single): TRectF;
     1258begin
     1259  result.Left:= Left;
     1260  result.Top:= Top;
     1261  result.Right:= left+width;
     1262  result.Bottom:= top+height;
     1263end;
     1264
     1265function IsEmptyRectF(const ARect: TRectF): boolean;
     1266begin
     1267  result:= (ARect.Width = 0) and (ARect.Height = 0);
     1268end;
     1269
    8341270function PointF(x, y: single): TPointF;
    8351271begin
    8361272  Result.x := x;
    8371273  Result.y := y;
     1274end;
     1275
     1276function PointF(pt: TPoint): TPointF;
     1277begin
     1278  if IsEmptyPoint(pt) then
     1279    result:= EmptyPointF
     1280  else
     1281  begin
     1282    Result.x := pt.x;
     1283    Result.y := pt.y;
     1284  end;
    8381285end;
    8391286
     
    8671314function VectLen(v: TPointF): single;
    8681315begin
    869   result := sqrt(v*v);
     1316  if isEmptyPointF(v) then
     1317    result := EmptySingle
     1318  else
     1319    result := sqrt(v*v);
    8701320end;
    8711321
     
    10691519end;
    10701520
    1071 {------------------ Bezier curves ------------------------}
    1072 
    1073 function ComputeBezierCurvePrecision(pt1, pt2, pt3, pt4: TPointF; AAcceptedDeviation: single = 0.1): integer;
    1074 var
    1075   len: single;
    1076 begin
    1077   len    := sqr(pt1.x - pt2.x) + sqr(pt1.y - pt2.y);
    1078   len    := max(len, sqr(pt3.x - pt2.x) + sqr(pt3.y - pt2.y));
    1079   len    := max(len, sqr(pt3.x - pt4.x) + sqr(pt3.y - pt4.y));
    1080   Result := round(sqrt(sqrt(len)/ AAcceptedDeviation) * 1);
    1081   if Result<=0 then Result:=1;
    1082 end;
    1083 
    1084 { TCubicBezierCurve }
    1085 
    1086 function TCubicBezierCurve.SimpleComputePoints(AAcceptedDeviation: single;
    1087   AIncludeFirstPoint: boolean = true): ArrayOfTPointF;
    1088 var
    1089   t,step: single;
    1090   i,nb: Integer;
    1091 begin
    1092   nb := ComputeBezierCurvePrecision(p1,c1,c2,p2, AAcceptedDeviation/2);
    1093   if nb <= 1 then nb := 2;
    1094   if AIncludeFirstPoint then
    1095   begin
    1096     setlength(result,nb);
    1097     result[0] := p1;
    1098     result[nb-1] := p2;
    1099     step := 1/(nb-1);
    1100     t := 0;
    1101     for i := 1 to nb-2 do
    1102     begin
    1103       t += step;
    1104       result[i] := ComputePointAt(t);
    1105     end;
    1106   end else
    1107   begin
    1108     setlength(result,nb-1);
    1109     result[nb-2] := p2;
    1110     step := 1/(nb-1);
    1111     t := 0;
    1112     for i := 0 to nb-3 do
    1113     begin
    1114       t += step;
    1115       result[i] := ComputePointAt(t);
    1116     end;
    1117   end;
    1118 end;
    1119 
    1120 function TCubicBezierCurve.ComputePointAt(t: single): TPointF;
    1121 var
    1122   f1,f2,f3,f4: single;
    1123 begin
    1124   f1 := (1-t);
    1125   f2 := f1*f1;
    1126   f1 *= f2;
    1127   f2 *= t*3;
    1128   f4 := t*t;
    1129   f3 := f4*(1-t)*3;
    1130   f4 *= t;
    1131 
    1132   result.x := f1*p1.x + f2*c1.x +
    1133               f3*c2.x + f4*p2.x;
    1134   result.y := f1*p1.y + f2*c1.y +
    1135               f3*c2.y + f4*p2.y;
    1136 end;
    1137 
    1138 procedure TCubicBezierCurve.Split(out ALeft, ARight: TCubicBezierCurve);
    1139 var midc: TPointF;
    1140 begin
    1141   ALeft.p1 := p1;
    1142   ALeft.c1 := 0.5*(p1+c1);
    1143   ARight.p2 := p2;
    1144   ARight.c2 := 0.5*(p2+c2);
    1145   midc := 0.5*(c1+c2);
    1146   ALeft.c2 := 0.5*(ALeft.c1+midc);
    1147   ARight.c1 := 0.5*(ARight.c2+midc);
    1148   ALeft.p2 := 0.5*(ALeft.c2+ARight.c1);
    1149   ARight.p1 := ALeft.p2;
    1150 end;
    1151 
    1152 function TCubicBezierCurve.ComputeLength(AAcceptedDeviation: single): single;
    1153 var
    1154   t,step: single;
    1155   i,nb: Integer;
    1156   curCoord,nextCoord: TPointF;
    1157 begin
    1158   nb := ComputeBezierCurvePrecision(p1,c1,c2,p2, AAcceptedDeviation);
    1159   if nb <= 1 then nb := 2;
    1160   result := 0;
    1161   curCoord := p1;
    1162   step := 1/(nb-1);
    1163   t := 0;
    1164   for i := 1 to nb-2 do
    1165   begin
    1166     t += step;
    1167     nextCoord := ComputePointAt(t);
    1168     result += VectLen(nextCoord-curCoord);
    1169     curCoord := nextCoord;
    1170   end;
    1171   result += VectLen(p2-curCoord);
    1172 end;
    1173 
    1174 function TCubicBezierCurve.ToPoints(AAcceptedDeviation: single;
    1175   AIncludeFirstPoint: boolean = true): ArrayOfTPointF;
    1176 begin
    1177   result := SimpleComputePoints(AAcceptedDeviation, AIncludeFirstPoint);
    1178 end;
    1179 
    1180 {//The following function computes by splitting the curve. It is slower than the simple function.
    1181 function TCubicBezierCurve.ToPoints(AAcceptedDeviation: single;
    1182   ARelativeDeviation: boolean): ArrayOfTPointF;
    1183   function ToPointsRec(const ACurve: TCubicBezierCurve): ArrayOfTPointF;
    1184   var simpleLen2: single;
    1185     v: TPointF;
    1186     left,right: TCubicBezierCurve;
    1187     subLeft,subRight: ArrayOfTPointF;
    1188     maxDev,dev1,dev2: single;
    1189     subLeftLen: integer;
    1190 
    1191     procedure ComputeExtremum;
    1192     begin
    1193       raise Exception.Create('Not implemented');
    1194       result := nil;
    1195     end;
    1196 
    1197   begin
    1198     v := ACurve.p2-ACurve.p1;
    1199     simpleLen2 := v*v;
    1200     if simpleLen2 = 0 then
    1201     begin
    1202       if (ACurve.c1.x = ACurve.p1.x) and (ACurve.c1.y = ACurve.p1.y) and
    1203          (ACurve.c2.x = ACurve.p2.x) and (ACurve.c2.y = ACurve.p2.y) then
    1204       begin
    1205         result := nil;
    1206         exit;
    1207       end;
    1208       ACurve.Split(left,right);
    1209     end else
    1210     begin
    1211       ACurve.Split(left,right);
    1212       if not ARelativeDeviation then simpleLen2:= sqrt(simpleLen2);
    1213       maxDev := AAcceptedDeviation*simpleLen2;
    1214       if abs(PointF(v.y,-v.x) * (left.p2-ACurve.p1)) <= maxDev then
    1215       begin
    1216         dev1 := PointF(v.y,-v.x) * (ACurve.c1-ACurve.p1);
    1217         dev2 := PointF(v.y,-v.x) * (ACurve.c2-ACurve.p2);
    1218         if not ((Sign(dev1)<>Sign(dev2)) and ((abs(dev1) > maxDev) or (abs(dev2) > maxDev))) then
    1219         begin
    1220           result := nil;
    1221           if ((ACurve.c1-ACurve.p1)*v < -maxDev) or
    1222              ((ACurve.c1-ACurve.p2)*v > maxDev) or
    1223              ((ACurve.c2-ACurve.p1)*v < -maxDev) or
    1224              ((ACurve.c2-ACurve.p2)*v > maxDev) then
    1225             ComputeExtremum;
    1226           exit;
    1227         end;
    1228       end;
    1229     end;
    1230     subRight := ToPointsRec(right);
    1231     subLeft := ToPointsRec(left);
    1232     subLeftLen := length(subLeft);
    1233 
    1234     //avoid leaving a gap in memory
    1235     result := subLeft;
    1236     subLeft := nil;
    1237     setlength(result, subLeftLen+1+length(subRight));
    1238     result[subLeftLen] := left.p2;
    1239     move(subRight[0], result[subLeftLen+1], length(subRight)*sizeof(TPointF));
    1240   end;
    1241 
    1242 var
    1243   subLen: integer;
    1244 
    1245 begin
    1246   if (c1.x = p1.x) and (c1.y = p1.y) and
    1247      (c1.x = c2.x) and (c1.y = c2.y) and
    1248      (c1.x = p2.x) and (c1.y = p2.y) then
    1249   begin
    1250     setlength(result,1);
    1251     result[0] := c1;
    1252     exit;
    1253   end else
    1254   begin
    1255     result := ToPointsRec(self);
    1256     subLen := length(result);
    1257     setlength(result, length(result)+2);
    1258     move(result[0], result[1], subLen*sizeof(TPointF));
    1259     result[0] := p1;
    1260     result[high(result)] := p2;
    1261   end;
    1262 end;}
    1263 
    1264 function TCubicBezierCurve.GetBounds: TRectF;
    1265 const precision = 1e-5;
    1266 
    1267   procedure Include(pt: TPointF);
    1268   begin
    1269     if pt.x < result.Left then result.Left := pt.x
    1270     else if pt.x > result.Right then result.Right := pt.x;
    1271     if pt.y < result.Top then result.Top := pt.y
    1272     else if pt.y > result.Bottom then result.Bottom := pt.y;
    1273   end;
    1274 
    1275   procedure IncludeT(t: single);
    1276   begin
    1277     if (t > 0) and (t < 1) then
    1278       Include(ComputePointAt(t));
    1279   end;
    1280 
    1281   procedure IncludeABC(a,b,c: single);
    1282   var b2ac, sqrtb2ac: single;
    1283   begin
    1284     if abs(a) < precision then
    1285     begin
    1286       if abs(b) < precision then exit;
    1287       IncludeT(-c/b);
    1288     end else
    1289     begin
    1290       b2ac := sqr(b) - 4 * a * c;
    1291       if b2ac >= 0 then
    1292       begin
    1293         sqrtb2ac := sqrt(b2ac);
    1294         IncludeT((-b + sqrtb2ac) / (2 * a));
    1295         IncludeT((-b - sqrtb2ac) / (2 * a));
    1296       end;
    1297     end;
    1298   end;
    1299 
    1300 var
    1301   va, vb, vc: TPointF;
    1302 
    1303 begin
    1304   result.TopLeft := p1;
    1305   result.BottomRight := p1;
    1306   Include(p2);
    1307 
    1308   vb := 6 * p1 - 12 * c1 + 6 * c2;
    1309   va := -3 * p1 + 9 * c1 - 9 * c2 + 3 * p2;
    1310   vc := 3 * c1 - 3 * p1;
    1311 
    1312   IncludeABC(va.x,vb.x,vc.x);
    1313   IncludeABC(va.y,vb.y,vc.y);
    1314 end;
    1315 
    1316 { TQuadraticBezierCurve }
    1317 
    1318 function TQuadraticBezierCurve.SimpleComputePoints(AAcceptedDeviation: single;
    1319   AIncludeFirstPoint: boolean = true): ArrayOfTPointF;
    1320 var
    1321   t,step: single;
    1322   i,nb: Integer;
    1323 begin
    1324   nb := ComputeBezierCurvePrecision(p1,c,c,p2, AAcceptedDeviation);
    1325   if nb <= 1 then nb := 2;
    1326   if AIncludeFirstPoint then
    1327   begin
    1328     setlength(result,nb);
    1329     result[0] := p1;
    1330     result[nb-1] := p2;
    1331     step := 1/(nb-1);
    1332     t := 0;
    1333     for i := 1 to nb-2 do
    1334     begin
    1335       t += step;
    1336       result[i] := ComputePointAt(t);
    1337     end;
    1338   end else
    1339   begin
    1340     setlength(result,nb-1);
    1341     result[nb-2] := p2;
    1342     step := 1/(nb-1);
    1343     t := 0;
    1344     for i := 0 to nb-3 do
    1345     begin
    1346       t += step;
    1347       result[i] := ComputePointAt(t);
    1348     end;
    1349   end;
    1350 end;
    1351 
    1352 function TQuadraticBezierCurve.ComputeExtremumPositionOutsideSegment: single;
    1353 var a,b: single;
    1354   v: TPointF;
    1355 begin
    1356   v := self.p2-self.p1;
    1357   a := (self.p1-2*self.c+self.p2)*v;
    1358   if a = 0 then //no solution
    1359   begin
    1360     result := -1;
    1361     exit;
    1362   end;
    1363   b := (self.c-self.p1)*v;
    1364   result := -b/a;
    1365 end;
    1366 
    1367 function TQuadraticBezierCurve.ComputePointAt(t: single): TPointF;
    1368 var
    1369   rev_t,f2,t2: single;
    1370 begin
    1371   rev_t := (1-t);
    1372   f2 := rev_t*t*2;
    1373   rev_t *= rev_t;
    1374   t2 := t*t;
    1375   result.x := rev_t*p1.x + f2*c.x + t2*p2.x;
    1376   result.y := rev_t*p1.y + f2*c.y + t2*p2.y;
    1377 end;
    1378 
    1379 procedure TQuadraticBezierCurve.Split(out ALeft, ARight: TQuadraticBezierCurve);
    1380 begin
    1381   ALeft.p1 := p1;
    1382   ALeft.c := 0.5*(p1+c);
    1383   ARight.p2 := p2;
    1384   ARight.c := 0.5*(p2+c);
    1385   ALeft.p2 := 0.5*(ALeft.c+ARight.c);
    1386   ARight.p1 := ALeft.p2;
    1387 end;
    1388 
    1389 function TQuadraticBezierCurve.ComputeLength: single;
    1390 var a,b: TPointF;
    1391   A_,AB_,B_,Sabc,A_2,A_32,B_2,BA,
    1392   divisor: single;
    1393   extremumPos: single;
    1394   extremum: TPointF;
    1395 begin
    1396   a := p1 - 2*c + p2;
    1397   b := 2*(c - p1);
    1398   A_ := 4*(a*a);
    1399   B_ := b*b;
    1400   if (A_ = 0) or (B_ = 0) then
    1401   begin
    1402     result := VectLen(p2-p1);
    1403     exit;
    1404   end;
    1405   AB_ := 4*(a*b);
    1406 
    1407   A_2 := sqrt(A_);
    1408   B_2 := 2*sqrt(B_);
    1409   BA := AB_/A_2;
    1410   divisor := BA+B_2;
    1411   if divisor <= 0 then
    1412   begin
    1413     extremumPos:= ComputeExtremumPositionOutsideSegment;
    1414     if (extremumPos <= 0) or (extremumPos >= 1) then
    1415       result := VectLen(p2-p1)
    1416     else
    1417     begin
    1418       extremum := ComputePointAt(extremumPos);
    1419       result := VectLen(extremum-p1)+VectLen(p2-extremum);
    1420     end;
    1421     exit;
    1422   end;
    1423 
    1424   Sabc := 2*sqrt(A_+AB_+B_);
    1425   A_32 := 2*A_*A_2;
    1426   result := ( A_32*Sabc +
    1427               A_2*AB_*(Sabc-B_2) +
    1428               (4*B_*A_-AB_*AB_)*ln( (2*A_2+BA+Sabc)/divisor )
    1429             )/(4*A_32);
    1430 end;
    1431 
    1432 function TQuadraticBezierCurve.ToPoints(AAcceptedDeviation: single;
    1433   AIncludeFirstPoint: boolean = true): ArrayOfTPointF;
    1434 begin
    1435   result := SimpleComputePoints(AAcceptedDeviation, AIncludeFirstPoint);
    1436 end;
    1437 
    1438 function TQuadraticBezierCurve.GetBounds: TRectF;
    1439 const precision = 1e-5;
    1440 
    1441   procedure Include(pt: TPointF);
    1442   begin
    1443     if pt.x < result.Left then result.Left := pt.x
    1444     else if pt.x > result.Right then result.Right := pt.x;
    1445     if pt.y < result.Top then result.Top := pt.y
    1446     else if pt.y > result.Bottom then result.Bottom := pt.y;
    1447   end;
    1448 
    1449   procedure IncludeT(t: single);
    1450   begin
    1451     if (t > 0) and (t < 1) then
    1452       Include(ComputePointAt(t));
    1453   end;
    1454 
    1455   procedure IncludeABC(a,b,c: single);
    1456   var denom: single;
    1457   begin
    1458     denom := a-2*b+c;
    1459     if abs(denom) < precision then exit;
    1460     IncludeT((a-b)/denom);
    1461   end;
    1462 
    1463 begin
    1464   result.TopLeft := p1;
    1465   result.BottomRight := p1;
    1466   Include(p2);
    1467 
    1468   IncludeABC(p1.x,c.x,p2.x);
    1469   IncludeABC(p1.y,c.y,p2.y);
    1470 end;
    1471 
    1472 {//The following function computes by splitting the curve. It is slower than the simple function
    1473 function TQuadraticBezierCurve.ToPoints(AAcceptedDeviation: single; ARelativeDeviation: boolean): ArrayOfTPointF;
    1474 
    1475   function ToPointsRec(const ACurve: TQuadraticBezierCurve): ArrayOfTPointF;
    1476   var simpleLen2: single;
    1477     v: TPointF;
    1478     left,right: TQuadraticBezierCurve;
    1479     subLeft,subRight: ArrayOfTPointF;
    1480     subLeftLen: Integer;
    1481 
    1482     procedure ComputeExtremum;
    1483     var
    1484       t: single;
    1485     begin
    1486       t := ACurve.ComputeExtremumPositionOutsideSegment;
    1487       if (t <= 0) or (t >= 1) then
    1488         result := nil
    1489       else
    1490       begin
    1491         setlength(result,1);
    1492         result[0] := ACurve.ComputePointAt(t);
    1493       end;
    1494     end;
    1495 
    1496   begin
    1497     v := ACurve.p2-ACurve.p1;
    1498     simpleLen2 := v*v;
    1499     if simpleLen2 = 0 then
    1500     begin
    1501       if (ACurve.c.x = ACurve.p1.x) and (ACurve.c.y = ACurve.p1.y) then
    1502       begin
    1503         result := nil;
    1504         exit;
    1505       end;
    1506       ACurve.Split(left,right);
    1507     end else
    1508     begin
    1509       ACurve.Split(left,right);
    1510       if not ARelativeDeviation then simpleLen2:= sqrt(simpleLen2);
    1511       if abs(PointF(v.y,-v.x) * (left.p2-ACurve.p1))
    1512           <= AAcceptedDeviation*simpleLen2 then
    1513       begin
    1514         result := nil;
    1515         if ((ACurve.c-ACurve.p1)*v < -AAcceptedDeviation*simpleLen2) or
    1516            ((ACurve.c-ACurve.p2)*v > AAcceptedDeviation*simpleLen2) then
    1517           ComputeExtremum;
    1518         exit;
    1519       end;
    1520     end;
    1521     subRight := ToPointsRec(right);
    1522     subLeft := ToPointsRec(left);
    1523     subLeftLen := length(subLeft);
    1524 
    1525     //avoid leaving a gap in memory
    1526     result := subLeft;
    1527     subLeft := nil;
    1528     setlength(result, subLeftLen+1+length(subRight));
    1529     result[subLeftLen] := left.p2;
    1530     move(subRight[0], result[subLeftLen+1], length(subRight)*sizeof(TPointF));
    1531   end;
    1532 
    1533 var
    1534   subLen: integer;
    1535 
    1536 begin
    1537   if (c.x = p1.x) and (c.y = p1.y) and
    1538      (c.x = p2.x) and (c.y = p2.y) then
    1539   begin
    1540     setlength(result,1);
    1541     result[0] := c;
    1542     exit;
    1543   end else
    1544   begin
    1545     result := ToPointsRec(self);
    1546     subLen := length(result);
    1547     setlength(result, length(result)+2);
    1548     move(result[0], result[1], subLen*sizeof(TPointF));
    1549     result[0] := p1;
    1550     result[high(result)] := p2;
    1551   end;
    1552 end;}
     1521{$DEFINE INCLUDE_IMPLEMENTATION}
     1522{$I bezier.inc}
     1523
    15531524{$ENDIF}
  • GraphicTest/Packages/bgrabitmap/lineartexscan.inc

    r494 r521  
    2121    procedure NextLight; inline;
    2222    begin
    23       inc(light,lightStep);
     23      light := (light+lightStep) and 65535;
    2424      inc(lightAcc,lightDiff);
    2525      if lightAcc >= lightMod then
    2626      begin
    2727        dec(lightAcc,lightMod);
    28         inc(light);
     28        light := (light + 1) and 65535;
    2929      end;
    3030    end;
     
    5353      light := info1.lightness;
    5454      lightLen := info2.lightness-info1.lightness;
    55       lightStep := lightLen div (ix2-ix1);
    56       lightMod := ix2-ix1;
    57       lightDiff := lightLen - lightStep*(ix2-ix1);
     55      if lightLen >= 0 then
     56      begin
     57        lightStep := lightLen div (ix2-ix1);
     58        lightMod := ix2-ix1;
     59        lightDiff := lightLen - lightStep*(ix2-ix1);
     60      end else
     61      begin
     62        lightStep := (-lightLen+(ix2-ix1-1)) div (ix2-ix1);
     63        lightMod := ix2-ix1;
     64        lightDiff := lightLen + lightStep*(ix2-ix1);
     65        lightStep := 65536 - lightStep;
     66      end;
    5867    end;
    5968    lightAcc := lightDiff div 2;
  • GraphicTest/Packages/bgrabitmap/multishapeline.inc

    r494 r521  
    22        for k := 0 to NbShapeRows-1 do
    33        with shapeRow[shapeRowsList[k]],shapes[shapeRowsList[k]] do
     4        if densMinx <= densMaxx then
    45        begin
     6          if densMinx < minx then densMinx := minx;
     7          if densMaxx > maxx then densMaxx := maxx;
     8
    59          if texture <> nil then
    610          begin
     
    1115            with sums[xb-minx] do
    1216            begin
    13               j := pdens^; inc(pdens);
    14               if j <> 0 then
     17              if pdens^ <> 0 then
    1518              begin
    1619                ec := GammaExpansion(ScanNextFunc());
    1720                {$ifdef PARAM_ANTIALIASINGFACTOR}
    18                   w := DivByAntialiasPrecision65536(j*ec.alpha);
     21                  w := DivByAntialiasPrecision65536(pdens^ * ec.alpha);
    1922                {$else}
    20                   w := (j*ec.alpha) shr 16;
     23                  w := (pdens^ * ec.alpha) shr 16;
    2124                {$endif}
    2225                if w <> 0 then
     
    2932              end else
    3033                ScanNextFunc();
     34              inc(pdens);
    3135            end;
    3236          end else
     
    3741             with sums[xb-minx] do
    3842             begin
    39                j := pdens^; inc(pdens);
    40                if j <> 0 then
     43               if pdens^ <> 0 then
    4144               begin
    4245                 {$ifdef PARAM_ANTIALIASINGFACTOR}
    43                    w := DivByAntialiasPrecision65536(j*ec.alpha);
     46                   w := DivByAntialiasPrecision65536(pdens^ * ec.alpha);
    4447                 {$else}
    45                    w := (j*ec.alpha) shr 16;
     48                   w := (pdens^ * ec.alpha) shr 16;
    4649                 {$endif}
    4750                 if w <> 0 then
     
    5356                 end;
    5457               end;
     58               inc(pdens);
    5559             end;
    5660          end;
  • GraphicTest/Packages/bgrabitmap/paletteformats.inc

    r494 r521  
    9696    AStream.WriteBuffer(AValue,sizeof(AValue));
    9797  end;
    98   procedure WriteBlock(ABlockType: Int16; AContentLength: Int32);
     98  procedure WriteBlock(ABlockType: Int16; AContentLength: Int32); overload;
    9999  begin
    100100    WriteInt16(ABlockType);
     
    102102  end;
    103103
    104   procedure WriteBlock(ABlockType: Int16; AName: string; AExtraContentLength: Int32);
     104  procedure WriteBlock(ABlockType: Int16; AName: string; AExtraContentLength: Int32); overload;
    105105  var contentLength: Int32;
    106106    wideName: UnicodeString;
  • GraphicTest/Packages/bgrabitmap/part3d.inc

    r494 r521  
    1919    destructor Destroy; override;
    2020    procedure Clear(ARecursive: boolean);
    21     function Add(x,y,z: single): IBGRAVertex3D;
    22     function Add(pt: TPoint3D): IBGRAVertex3D;
    23     function Add(pt: TPoint3D; normal: TPoint3D): IBGRAVertex3D;
    24     function Add(pt: TPoint3D_128): IBGRAVertex3D;
    25     function Add(pt: TPoint3D_128; normal: TPoint3D_128): IBGRAVertex3D;
    26     function Add(const coords: array of single): arrayOfIBGRAVertex3D;
    27     function Add(const pts: array of TPoint3D): arrayOfIBGRAVertex3D;
    28     function Add(const pts: array of TPoint3D_128): arrayOfIBGRAVertex3D;
    29     procedure Add(const pts: array of IBGRAVertex3D);
    30     procedure Add(AVertex: IBGRAVertex3D);
    31     function AddNormal(x,y,z: single): IBGRANormal3D;
    32     function AddNormal(pt: TPoint3D): IBGRANormal3D;
    33     function AddNormal(pt: TPoint3D_128): IBGRANormal3D;
    34     procedure AddNormal(ANormal: IBGRANormal3D);
     21    function Add(x,y,z: single): IBGRAVertex3D; overload;
     22    function Add(pt: TPoint3D): IBGRAVertex3D; overload;
     23    function Add(pt: TPoint3D; normal: TPoint3D): IBGRAVertex3D; overload;
     24    function Add(pt: TPoint3D_128): IBGRAVertex3D; overload;
     25    function Add(pt: TPoint3D_128; normal: TPoint3D_128): IBGRAVertex3D; overload;
     26    function Add(const coords: array of single): arrayOfIBGRAVertex3D; overload;
     27    function Add(const pts: array of TPoint3D): arrayOfIBGRAVertex3D; overload;
     28    function Add(const pts: array of TPoint3D_128): arrayOfIBGRAVertex3D; overload;
     29    procedure Add(const pts: array of IBGRAVertex3D); overload;
     30    procedure Add(AVertex: IBGRAVertex3D); overload;
     31    function AddNormal(x,y,z: single): IBGRANormal3D; overload;
     32    function AddNormal(pt: TPoint3D): IBGRANormal3D; overload;
     33    function AddNormal(pt: TPoint3D_128): IBGRANormal3D; overload;
     34    procedure AddNormal(ANormal: IBGRANormal3D); overload;
    3535    procedure RemoveVertex(Index: integer);
    3636    procedure RemoveNormal(Index: integer);
     
    5050    procedure SetNormal(AIndex: Integer; AValue: IBGRANormal3D);
    5151    procedure ResetTransform;
    52     procedure Translate(x,y,z: single; Before: boolean = true);
    53     procedure Translate(ofs: TPoint3D; Before: boolean = true);
    54     procedure Scale(size: single; Before: boolean = true);
    55     procedure Scale(x,y,z: single; Before: boolean = true);
    56     procedure Scale(size: TPoint3D; Before: boolean = true);
     52    procedure Translate(x,y,z: single; Before: boolean = true); overload;
     53    procedure Translate(ofs: TPoint3D; Before: boolean = true); overload;
     54    procedure Scale(size: single; Before: boolean = true); overload;
     55    procedure Scale(x,y,z: single; Before: boolean = true); overload;
     56    procedure Scale(size: TPoint3D; Before: boolean = true); overload;
    5757    procedure RotateXDeg(angle: single; Before: boolean = true);
    5858    procedure RotateYDeg(angle: single; Before: boolean = true);
  • GraphicTest/Packages/bgrabitmap/perspectivescan.inc

    r494 r521  
    5151    procedure NextLight; inline;
    5252    begin
    53       inc(light,lightStep);
     53      light := (light+lightStep) and 65535;
    5454      inc(lightAcc,lightDiff);
    5555      if lightAcc >= lightMod then
    5656      begin
    5757        dec(lightAcc,lightMod);
    58         inc(light);
     58        light := (light + 1) and 65535;
    5959      end;
    6060    end;
     
    101101      light := info1.lightness;
    102102      lightLen := info2.lightness-info1.lightness;
    103       lightStep := lightLen div (ix2-ix1);
    104       lightMod := ix2-ix1;
    105       lightDiff := lightLen - lightStep*(ix2-ix1);
     103      if lightLen >= 0 then
     104      begin
     105        lightStep := lightLen div (ix2-ix1);
     106        lightMod := ix2-ix1;
     107        lightDiff := lightLen - lightStep*(ix2-ix1);
     108      end else
     109      begin
     110        lightStep := (-lightLen+(ix2-ix1-1)) div (ix2-ix1);
     111        lightMod := ix2-ix1;
     112        lightDiff := lightLen + lightStep*(ix2-ix1);
     113        lightStep := 65536 - lightStep;
     114      end;
    106115    end;
    107116    lightAcc := lightDiff div 2;
  • GraphicTest/Packages/bgrabitmap/vertex3d.inc

    r494 r521  
    1616    FFaceColorsInvalidated,
    1717    FMaterialInvalidated: boolean;
    18     procedure AddFace(AFace: IBGRAFace3D);
     18    procedure AddFace(AFace: IBGRAFace3D); overload;
    1919  public
    2020    constructor Create(AScene: TBGRAScene3D);
     
    2323    procedure InvalidateColor;
    2424    procedure InvalidateMaterial;
    25     function AddFace(const AVertices: array of IBGRAVertex3D): IBGRAFace3D;
    26     function AddFace(const AVertices: array of IBGRAVertex3D; ABiface: boolean): IBGRAFace3D;
    27     function AddFace(const AVertices: array of IBGRAVertex3D; ATexture: IBGRAScanner): IBGRAFace3D;
    28     function AddFace(const AVertices: array of IBGRAVertex3D; AColor: TBGRAPixel): IBGRAFace3D;
    29     function AddFace(const AVertices: array of IBGRAVertex3D; AColors: array of TBGRAPixel): IBGRAFace3D;
     25    function AddFace(const AVertices: array of IBGRAVertex3D): IBGRAFace3D; overload;
     26    function AddFace(const AVertices: array of IBGRAVertex3D; ABiface: boolean): IBGRAFace3D; overload;
     27    function AddFace(const AVertices: array of IBGRAVertex3D; ATexture: IBGRAScanner): IBGRAFace3D; overload;
     28    function AddFace(const AVertices: array of IBGRAVertex3D; AColor: TBGRAPixel): IBGRAFace3D; overload;
     29    function AddFace(const AVertices: array of IBGRAVertex3D; AColors: array of TBGRAPixel): IBGRAFace3D; overload;
    3030    function AddFaceReversed(const AVertices: array of IBGRAVertex3D): IBGRAFace3D;
    3131    procedure ComputeWithMatrix(constref AMatrix: TMatrix3D; constref AProjection: TProjection3D);
  • GraphicTest/UMainForm.pas

    r472 r521  
    66
    77uses
    8   Classes, SysUtils, FileUtil, SynHighlighterPas, SynMemo, Forms, Controls,
     8  Classes, SysUtils, LazFileUtils, SynHighlighterPas, SynMemo, Forms, Controls,
    99  Graphics, Dialogs, ComCtrls, ExtCtrls, StdCtrls, DateUtils, UPlatform,
    1010  LCLType, IntfGraphics, fpImage, Math, GraphType, Contnrs, LclIntf, Spin,
     
    337337    Copy(TDrawMethod(DrawMethods[ListViewMethods.Selected.Index]).ClassName, 2, High(Integer)) + '.pas';
    338338
    339     if FileExistsUTF8(FileName) then
     339    if FileExists(FileName) then
    340340      SynMemo1.Lines.LoadFromFile(FileName)
    341341      else SynMemo1.Lines.Clear;
Note: See TracChangeset for help on using the changeset viewer.