Changeset 521 for GraphicTest
- Timestamp:
- Apr 17, 2019, 12:58:41 AM (6 years ago)
- Location:
- GraphicTest
- Files:
-
- 206 added
- 93 edited
Legend:
- Unmodified
- Added
- Removed
-
GraphicTest
- Property svn:ignore
-
old new 8 8 GraphicTest.lps 9 9 GraphicTest.dbg 10 heaptrclog.trc
-
- Property svn:ignore
-
GraphicTest/GraphicTest.lpi
r494 r521 2 2 <CONFIG> 3 3 <ProjectOptions> 4 <Version Value=" 9"/>4 <Version Value="11"/> 5 5 <General> 6 6 <SessionStorage Value="InProjectDir"/> … … 20 20 <IncludeFiles Value="$(ProjOutDir)"/> 21 21 <OtherUnitFiles Value="Methods"/> 22 <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS) "/>22 <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)-$(BuildMode)"/> 23 23 </SearchPaths> 24 24 <Parsing> … … 48 48 </Options> 49 49 </Linking> 50 <Other> 51 <CompilerMessages> 52 <IgnoredMessages idx5024="True"/> 53 </CompilerMessages> 54 </Other> 50 55 </CompilerOptions> 51 56 </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> 52 61 </BuildModes> 53 62 <PublishOptions> 54 63 <Version Value="2"/> 55 <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>56 <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/>57 64 </PublishOptions> 58 65 <RunParams> 59 <local> 60 <FormatVersion Value="1"/> 61 </local> 66 <FormatVersion Value="2"/> 67 <Modes Count="1"> 68 <Mode0 Name="default"/> 69 </Modes> 62 70 </RunParams> 63 71 <RequiredPackages Count="5"> … … 169 177 <IncludeFiles Value="$(ProjOutDir)"/> 170 178 <OtherUnitFiles Value="Methods"/> 171 <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS) "/>179 <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)-$(BuildMode)"/> 172 180 </SearchPaths> 173 181 <Parsing> … … 191 199 </CodeGeneration> 192 200 <Linking> 201 <Debugging> 202 <UseHeaptrc Value="True"/> 203 </Debugging> 193 204 <Options> 194 205 <Win32> … … 198 209 </Linking> 199 210 <Other> 211 <CompilerMessages> 212 <IgnoredMessages idx5024="True"/> 213 </CompilerMessages> 200 214 <CustomOptions Value="-dopengl"/> 201 215 </Other> -
GraphicTest/GraphicTest.lpr
r494 r521 8 8 {$ENDIF}{$ENDIF} 9 9 Interfaces, // this includes the LCL widgetset 10 Forms, openglcontext, UMainForm, UPlatform, UDrawMethod, UFastBitmap,10 Forms, SysUtils, openglcontext, UMainForm, UPlatform, UDrawMethod, UFastBitmap, 11 11 UDrawForm, bgrabitmappack, 12 12 {$IFDEF GRAPHICS32}GR32_L,{$ENDIF} … … 18 18 {$R *.res} 19 19 20 {$if declared(UseHeapTrace)} 21 const 22 HeapTraceLog = 'heaptrclog.trc'; 23 {$ENDIF} 24 20 25 begin 26 {$if declared(UseHeapTrace)} 27 // Heap trace 28 DeleteFile(ExtractFilePath(ParamStr(0)) + HeapTraceLog); 29 SetHeapTraceOutput(ExtractFilePath(ParamStr(0)) + HeapTraceLog); 30 {$ENDIF} 31 21 32 RequireDerivedFormResource := True; 22 33 Application.Initialize; -
GraphicTest/Packages/Graphics32/Packages/GR32_L.lpk
r452 r521 1 <?xml version="1.0" ?>1 <?xml version="1.0" encoding="UTF-8"?> 2 2 <CONFIG> 3 3 <Package Version="4"> … … 13 13 <IncludeFiles Value=".."/> 14 14 <OtherUnitFiles Value=".."/> 15 <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS) \$(LCLWidgetType)"/>15 <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)-$(BuildMode)\$(LCLWidgetType)"/> 16 16 </SearchPaths> 17 17 <Parsing> … … 23 23 </SyntaxOptions> 24 24 </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> 31 35 </CompilerOptions> 32 36 <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. … … 154 158 <PublishOptions> 155 159 <Version Value="2"/> 156 <IgnoreBinaries Value="False"/>157 160 </PublishOptions> 158 161 <CustomOptions Items="ExternHelp" Version="2"> -
GraphicTest/Packages/bgrabitmap/basiccolorspace.inc
r494 r521 13 13 14 14 // 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 16 17 17 18 procedure BGRASetGamma(AGamma: single = 1.7); … … 42 43 {** Returns the lightness of an gamma-expanded pixel. The lightness is the 43 44 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; 45 46 {** 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; 47 48 {** Sets the lightness of a gamma expanded pixel, provided you already know the current 48 49 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; 50 51 {** Returns the importance of the color. It is similar to saturation 51 52 in HSL colorspace, except it is gamma corrected. A value of zero indicates … … 88 89 {** Hue of the pixel. Extremum values 0 and 65535 are red } 89 90 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) } 91 92 saturation: word; 92 93 {** Lightness of the color. 0 is black, 32768 is normal, and 65535 is white } … … 116 117 {* Pixel color defined in corrected HSL colorspace. G stands for corrected hue 117 118 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; 119 129 120 130 {** Converts a pixel from sRGB to correct HSL color space } … … 127 137 function HtoG(hue: word): word; 128 138 {** 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; 130 141 {** 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; 132 144 {** 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; 134 148 135 149 type 136 { TBGRAPixel Helper }137 138 TBGRAPixel Helper = record helper for TBGRAPixel150 { TBGRAPixelBasicHelper } 151 152 TBGRAPixelBasicHelper = record helper for TBGRAPixel 139 153 function ToExpanded: TExpandedPixel; 140 154 procedure FromExpanded(const AValue: TExpandedPixel); … … 142 156 procedure FromHSLAPixel(const AValue: THSLAPixel); 143 157 function ToGSBAPixel: TGSBAPixel; 144 procedure FromGSBAPixel(const AValue: TGSBAPixel); 158 procedure FromGSBAPixel(const AValue: TGSBAPixel); overload; 159 procedure FromGSBAPixel(const AValue: THSLAPixel); overload; 145 160 function ToColorF(AGammaExpansion: boolean): TColorF; 146 161 procedure FromColorF(const AValue: TColorF; AGammaCompression: boolean); 147 162 end; 148 163 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 180 operator := (const AValue: TExpandedPixel): TColor; 181 operator := (const AValue: TColor): TExpandedPixel; 182 Operator := (const Source: TExpandedPixel): TBGRAPixel; 183 Operator := (const Source: TBGRAPixel): TExpandedPixel; 184 185 type 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 210 Operator := (const Source: THSLAPixel): TBGRAPixel; 211 Operator := (const Source: TBGRAPixel): THSLAPixel; 212 Operator := (const Source: THSLAPixel): TExpandedPixel; 213 Operator := (const Source: TExpandedPixel): THSLAPixel; 214 operator := (const AValue: TColor): THSLAPixel; 215 operator := (const AValue: THSLAPixel): TColor; 216 217 type 218 { TGSBAPixelBasicHelper } 219 220 TGSBAPixelBasicHelper = record helper for TGSBAPixel 221 function ToColor: TColor; 222 procedure FromColor(const AValue: TColor); 152 223 function ToBGRAPixel: TBGRAPixel; 153 224 procedure FromBGRAPixel(AValue: TBGRAPixel); 154 225 function ToHSLAPixel: THSLAPixel; 155 226 procedure FromHSLAPixel(AValue: THSLAPixel); 156 end;157 158 { THSLAPixelHelper }159 160 THSLAPixelHelper = record helper for THSLAPixel161 function ToBGRAPixel: TBGRAPixel;162 procedure FromBGRAPixel(AValue: TBGRAPixel);163 227 function ToExpanded: TExpandedPixel; 164 228 procedure FromExpanded(AValue: TExpandedPixel); 165 229 end; 166 230 167 Operator := (Source: TExpandedPixel): TBGRAPixel; 231 Operator := (const Source: TGSBAPixel): TBGRAPixel; 232 Operator := (const Source: TBGRAPixel): TGSBAPixel; 233 Operator := (const Source: TGSBAPixel): TExpandedPixel; 234 Operator := (const Source: TExpandedPixel): TGSBAPixel; 235 operator := (const AValue: TColor): TGSBAPixel; 236 operator := (const AValue: TGSBAPixel): TColor; 237 Operator := (const Source: TGSBAPixel): THSLAPixel; //no conversion, just copying for backward compatibility (use ToHSLAPixel instead for conversion) 238 Operator := (const Source: THSLAPixel): TGSBAPixel; //no conversion, just copying for backward compatibility (use ToGSBAPixel instead for conversion) 168 239 {$ENDIF} 169 240 … … 317 388 nextpos := round(power(i+0.5, GammaExpFactor) * GammaLinearFactor); 318 389 GammaExpansionTab[i] := midpos; 319 for j := prevpos to nextpos-1 do 390 for j := prevpos to midpos-1 do 391 begin 320 392 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; 321 400 end; 322 401 GammaCompressionTab[0] := 0; … … 358 437 Result.blue := GammaCompressionTab[blue]; 359 438 Result.alpha := alpha shr 8; 439 end; 440 441 function GammaExpansionW(ACompressed: word): word; 442 var 443 intPart: Integer; 444 f,fracPart: Single; 445 begin 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; 460 end; 461 462 function GammaCompressionW(AExpanded: word): word; 463 begin 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; 360 474 end; 361 475 … … 871 985 var lightness: UInt32Or64; 872 986 red,green,blue: Int32or64; 987 hsla: THSLAPixel; 873 988 begin 874 989 red := GammaExpansionTab[c.red]; 875 990 green := GammaExpansionTab[c.green]; 876 991 blue := GammaExpansionTab[c.blue]; 877 result.alpha := c.alpha shl 8 + c.alpha;992 hsla.alpha := c.alpha shl 8 + c.alpha; 878 993 879 994 lightness := (red * redWeightShl10 + green * greenWeightShl10 + 880 995 blue * blueWeightShl10 + 512) shr 10; 881 996 882 ExpandedToHSLAInline(red,green,blue,result); 997 ExpandedToHSLAInline(red,green,blue,hsla); 998 result := TGSBAPixel(hsla); 999 883 1000 if result.lightness > 32768 then 884 1001 result.saturation := result.saturation* UInt32or64(not result.lightness) div 32767; … … 890 1007 var lightness: UInt32Or64; 891 1008 red,green,blue: Int32or64; 1009 hsla: THSLAPixel; 892 1010 begin 893 1011 red := ec.red; 894 1012 green := ec.green; 895 1013 blue := ec.blue; 896 result.alpha := ec.alpha;1014 hsla.alpha := ec.alpha; 897 1015 898 1016 lightness := (red * redWeightShl10 + green * greenWeightShl10 + 899 1017 blue * blueWeightShl10 + 512) shr 10; 900 1018 901 ExpandedToHSLAInline(red,green,blue,result); 1019 ExpandedToHSLAInline(red,green,blue,hsla); 1020 result := TGSBAPixel(hsla); 1021 902 1022 if result.lightness > 32768 then 903 1023 result.saturation := result.saturation* UInt32or64(not result.lightness) div 32767; … … 1002 1122 lightness := c.lightness; 1003 1123 c.lightness := 32768; 1004 ec := HSLAToExpanded( c);1124 ec := HSLAToExpanded(THSLAPixel(c)); 1005 1125 result := GammaCompression(SetLightness(ec, lightness)); 1126 end; 1127 1128 function GSBAToBGRA(const c: THSLAPixel): TBGRAPixel; 1129 begin 1130 result := GSBAToBGRA(TGSBAPixel(c)); 1006 1131 end; 1007 1132 … … 1012 1137 lightness := c.lightness; 1013 1138 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); 1140 end; 1141 1142 function GSBAToExpanded(const c: THSLAPixel): TExpandedPixel; 1143 begin 1144 result := GSBAToExpanded(TGSBAPixel(c)); 1145 end; 1146 1147 function GSBAToHSLA(const c: TGSBAPixel): THSLAPixel; 1148 begin 1149 result := ExpandedToHSLA(GSBAToExpanded(c)); 1150 end; 1151 1152 function GSBAToHSLA(const c: THSLAPixel): THSLAPixel; 1153 begin 1154 result := ExpandedToHSLA(GSBAToExpanded(TGSBAPixel(c))); 1155 end; 1156 1157 function HSLAToGSBA(const c: THSLAPixel): TGSBAPixel; 1158 begin 1159 result := ExpandedToGSBA(HSLAToExpanded(c)); 1160 end; 1161 1162 { TBGRAPixelBasicHelper } 1163 1164 function TBGRAPixelBasicHelper.ToExpanded: TExpandedPixel; 1025 1165 begin 1026 1166 result := GammaExpansion(self); 1027 1167 end; 1028 1168 1029 procedure TBGRAPixel Helper.FromExpanded(const AValue: TExpandedPixel);1169 procedure TBGRAPixelBasicHelper.FromExpanded(const AValue: TExpandedPixel); 1030 1170 begin 1031 1171 Self := GammaCompression(AValue); 1032 1172 end; 1033 1173 1034 function TBGRAPixel Helper.ToHSLAPixel: THSLAPixel;1174 function TBGRAPixelBasicHelper.ToHSLAPixel: THSLAPixel; 1035 1175 begin 1036 1176 result := BGRAToHSLA(Self); 1037 1177 end; 1038 1178 1039 procedure TBGRAPixel Helper.FromHSLAPixel(const AValue: THSLAPixel);1179 procedure TBGRAPixelBasicHelper.FromHSLAPixel(const AValue: THSLAPixel); 1040 1180 begin 1041 1181 Self := HSLAToBGRA(AValue); 1042 1182 end; 1043 1183 1044 function TBGRAPixel Helper.ToGSBAPixel: TGSBAPixel;1184 function TBGRAPixelBasicHelper.ToGSBAPixel: TGSBAPixel; 1045 1185 begin 1046 1186 result := BGRAToGSBA(Self); 1047 1187 end; 1048 1188 1049 procedure TBGRAPixel Helper.FromGSBAPixel(const AValue: TGSBAPixel);1189 procedure TBGRAPixelBasicHelper.FromGSBAPixel(const AValue: TGSBAPixel); 1050 1190 begin 1051 1191 Self := GSBAToBGRA(AValue); 1052 1192 end; 1053 1193 1054 function TBGRAPixelHelper.ToColorF(AGammaExpansion: boolean): TColorF; 1194 procedure TBGRAPixelBasicHelper.FromGSBAPixel(const AValue: THSLAPixel); 1195 begin 1196 Self := GSBAToBGRA(AValue); 1197 end; 1198 1199 function TBGRAPixelBasicHelper.ToColorF(AGammaExpansion: boolean): TColorF; 1055 1200 begin 1056 1201 result := BGRAToColorF(Self,AGammaExpansion); 1057 1202 end; 1058 1203 1059 procedure TBGRAPixel Helper.FromColorF(const AValue: TColorF;1204 procedure TBGRAPixelBasicHelper.FromColorF(const AValue: TColorF; 1060 1205 AGammaCompression: boolean); 1061 1206 begin … … 1063 1208 end; 1064 1209 1065 { TExpandedPixelHelper } 1066 1067 function TExpandedPixelHelper.ToBGRAPixel: TBGRAPixel; 1210 { TExpandedPixelBasicHelper } 1211 1212 function TExpandedPixelBasicHelper.ToFPColor(AGammaCompression: boolean): TFPColor; 1213 begin 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; 1226 end; 1227 1228 procedure TExpandedPixelBasicHelper.FromFPColor(const AValue: TFPColor; 1229 AGammaExpansion: boolean); 1230 begin 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; 1243 end; 1244 1245 function TExpandedPixelBasicHelper.ToColor: TColor; 1246 begin 1247 result := BGRAToColor(GammaCompression(self)); 1248 end; 1249 1250 procedure TExpandedPixelBasicHelper.FromColor(const AValue: TColor); 1251 begin 1252 self := GammaExpansion(ColorToBGRA(AValue)); 1253 end; 1254 1255 function TExpandedPixelBasicHelper.ToBGRAPixel: TBGRAPixel; 1068 1256 begin 1069 1257 result := GammaCompression(Self); 1070 1258 end; 1071 1259 1072 procedure TExpandedPixel Helper.FromBGRAPixel(AValue: TBGRAPixel);1260 procedure TExpandedPixelBasicHelper.FromBGRAPixel(AValue: TBGRAPixel); 1073 1261 begin 1074 1262 Self := GammaExpansion(AValue); 1075 1263 end; 1076 1264 1077 function TExpandedPixel Helper.ToHSLAPixel: THSLAPixel;1265 function TExpandedPixelBasicHelper.ToHSLAPixel: THSLAPixel; 1078 1266 begin 1079 1267 result := ExpandedToHSLA(Self); 1080 1268 end; 1081 1269 1082 procedure TExpandedPixel Helper.FromHSLAPixel(AValue: THSLAPixel);1270 procedure TExpandedPixelBasicHelper.FromHSLAPixel(const AValue: THSLAPixel); 1083 1271 begin 1084 1272 Self := HSLAToExpanded(AValue); 1085 1273 end; 1086 1274 1087 operator :=(Source: TExpandedPixel): TBGRAPixel; 1275 function TExpandedPixelBasicHelper.ToGSBAPixel: TGSBAPixel; 1276 begin 1277 result := ExpandedToGSBA(Self); 1278 end; 1279 1280 procedure TExpandedPixelBasicHelper.FromGSBAPixel(const AValue: TGSBAPixel); 1281 begin 1282 Self := GSBAToExpanded(AValue); 1283 end; 1284 1285 procedure TExpandedPixelBasicHelper.FromGSBAPixel(const AValue: THSLAPixel); 1286 begin 1287 Self := GSBAToExpanded(AValue); 1288 end; 1289 1290 operator := (const AValue: TExpandedPixel): TColor; 1291 begin Result := BGRAToColor(GammaCompression(AValue)); end; 1292 1293 operator := (const AValue: TColor): TExpandedPixel; 1294 begin Result := GammaExpansion(ColorToBGRA(ColorToRGB(AValue))) end; 1295 1296 operator :=(const Source: TExpandedPixel): TBGRAPixel; 1088 1297 begin 1089 1298 result := GammaCompression(Source); 1090 1299 end; 1091 1300 1092 { THSLAPixelHelper } 1093 1094 function THSLAPixelHelper.ToBGRAPixel: TBGRAPixel; 1301 operator :=(const Source: TBGRAPixel): TExpandedPixel; 1302 begin 1303 result := GammaExpansion(Source); 1304 end; 1305 1306 { TFPColorBasicHelper } 1307 1308 function TFPColorBasicHelper.ToColor: TColor; 1309 begin 1310 result := FPColorToTColor(self); 1311 end; 1312 1313 procedure TFPColorBasicHelper.FromColor(const AValue: TColor); 1314 begin 1315 self := TColorToFPColor(AValue); 1316 end; 1317 1318 function TFPColorBasicHelper.ToBGRAPixel: TBGRAPixel; 1319 begin 1320 result := FPColorToBGRA(self); 1321 end; 1322 1323 procedure TFPColorBasicHelper.FromBGRAPixel(AValue: TBGRAPixel); 1324 begin 1325 self := BGRAToFPColor(AValue); 1326 end; 1327 1328 function TFPColorBasicHelper.ToExpanded(AGammaExpansion: boolean): TExpandedPixel; 1329 begin 1330 result.FromFPColor(self, AGammaExpansion); 1331 end; 1332 1333 procedure TFPColorBasicHelper.FromExpanded(const AValue: TExpandedPixel; 1334 AGammaCompression: boolean); 1335 begin 1336 self := AValue.ToFPColor(AGammaCompression); 1337 end; 1338 1339 { THSLAPixelBasicHelper } 1340 1341 function THSLAPixelBasicHelper.ToColor: TColor; 1342 begin 1343 result := BGRAToColor(HSLAToBGRA(self)); 1344 end; 1345 1346 procedure THSLAPixelBasicHelper.FromColor(const AValue: TColor); 1347 begin 1348 self := BGRAToHSLA(ColorToBGRA(AValue)); 1349 end; 1350 1351 function THSLAPixelBasicHelper.ToBGRAPixel: TBGRAPixel; 1095 1352 begin 1096 1353 result := HSLAToBGRA(self); 1097 1354 end; 1098 1355 1099 procedure THSLAPixel Helper.FromBGRAPixel(AValue: TBGRAPixel);1356 procedure THSLAPixelBasicHelper.FromBGRAPixel(AValue: TBGRAPixel); 1100 1357 begin 1101 1358 self := BGRAToHSLA(AValue); 1102 1359 end; 1103 1360 1104 function THSLAPixelHelper.ToExpanded: TExpandedPixel; 1361 function THSLAPixelBasicHelper.ToGSBAPixel: TGSBAPixel; 1362 begin 1363 result := HSLAToGSBA(self); 1364 end; 1365 1366 procedure THSLAPixelBasicHelper.FromGSBAPixel(AValue: TGSBAPixel); 1367 begin 1368 self := GSBAToHSLA(AValue); 1369 end; 1370 1371 function THSLAPixelBasicHelper.ToExpanded: TExpandedPixel; 1105 1372 begin 1106 1373 result := HSLAToExpanded(Self); 1107 1374 end; 1108 1375 1109 procedure THSLAPixel Helper.FromExpanded(AValue: TExpandedPixel);1376 procedure THSLAPixelBasicHelper.FromExpanded(AValue: TExpandedPixel); 1110 1377 begin 1111 1378 Self := ExpandedToHSLA(AValue); 1112 1379 end; 1380 1381 operator :=(const Source: THSLAPixel): TBGRAPixel; 1382 begin 1383 result := HSLAToBGRA(Source); 1384 end; 1385 1386 operator :=(const Source: TBGRAPixel): THSLAPixel; 1387 begin 1388 result := BGRAToHSLA(Source); 1389 end; 1390 1391 operator :=(const Source: THSLAPixel): TExpandedPixel; 1392 begin 1393 result := HSLAToExpanded(Source); 1394 end; 1395 1396 operator:=(const Source: TExpandedPixel): THSLAPixel; 1397 begin 1398 result := ExpandedToHSLA(Source); 1399 end; 1400 1401 operator := (const AValue: TColor): THSLAPixel; 1402 begin Result := BGRAToHSLA(ColorToBGRA(ColorToRGB(AValue))) end; 1403 1404 operator := (const AValue: THSLAPixel): TColor; 1405 begin Result := BGRAToColor(HSLAToBGRA(AValue)) end; 1406 1407 { TGSBAPixelBasicHelper } 1408 1409 function TGSBAPixelBasicHelper.ToColor: TColor; 1410 begin 1411 result := BGRAToColor(GSBAToBGRA(self)); 1412 end; 1413 1414 procedure TGSBAPixelBasicHelper.FromColor(const AValue: TColor); 1415 begin 1416 self := BGRAToGSBA(ColorToBGRA(AValue)); 1417 end; 1418 1419 function TGSBAPixelBasicHelper.ToBGRAPixel: TBGRAPixel; 1420 begin 1421 result := GSBAToBGRA(self); 1422 end; 1423 1424 procedure TGSBAPixelBasicHelper.FromBGRAPixel(AValue: TBGRAPixel); 1425 begin 1426 self := BGRAToGSBA(AValue); 1427 end; 1428 1429 function TGSBAPixelBasicHelper.ToHSLAPixel: THSLAPixel; 1430 begin 1431 result := GSBAToHSLA(self); 1432 end; 1433 1434 procedure TGSBAPixelBasicHelper.FromHSLAPixel(AValue: THSLAPixel); 1435 begin 1436 self := HSLAToGSBA(AValue); 1437 end; 1438 1439 function TGSBAPixelBasicHelper.ToExpanded: TExpandedPixel; 1440 begin 1441 result := GSBAToExpanded(self); 1442 end; 1443 1444 procedure TGSBAPixelBasicHelper.FromExpanded(AValue: TExpandedPixel); 1445 begin 1446 self := ExpandedToGSBA(AValue); 1447 end; 1448 1449 operator :=(const Source: TGSBAPixel): TBGRAPixel; 1450 begin 1451 result := GSBAToBGRA(Source); 1452 end; 1453 1454 operator :=(const Source: TBGRAPixel): TGSBAPixel; 1455 begin 1456 result := BGRAToGSBA(Source); 1457 end; 1458 1459 operator :=(const Source: TGSBAPixel): TExpandedPixel; 1460 begin 1461 result := GSBAToExpanded(Source); 1462 end; 1463 1464 operator:=(const Source: TExpandedPixel): TGSBAPixel; 1465 begin 1466 result := ExpandedToGSBA(Source); 1467 end; 1468 1469 operator := (const AValue: TColor): TGSBAPixel; 1470 begin Result := BGRAToGSBA(ColorToBGRA(ColorToRGB(AValue))) end; 1471 1472 operator := (const AValue: TGSBAPixel): TColor; 1473 begin Result := BGRAToColor(GSBAToBGRA(AValue)) end; 1474 1475 operator :=(const Source: TGSBAPixel): THSLAPixel; 1476 begin 1477 result := THSLAPixel(Pointer(@Source)^); 1478 end; 1479 1480 operator:=(const Source: THSLAPixel): TGSBAPixel; 1481 begin 1482 result := TGSBAPixel(Pointer(@Source)^); 1483 end; 1113 1484 {$ENDIF} -
GraphicTest/Packages/bgrabitmap/bglvirtualscreen.pas
r494 r521 16 16 TBGLElapseEvent = procedure (Sender: TObject; BGLContext: TBGLContext; ElapsedMs: integer) of object; 17 17 TBGLFramesPerSecondEvent = procedure (Sender: TObject; BGLContext: TBGLContext; FramesPerSecond: integer) of object; 18 TBGLUseContextCallback = procedure (Sender: TObject; BGLContext: TBGLContext; Data: Pointer) of object; 18 19 19 20 { TCustomBGLVirtualScreen } … … 60 61 procedure QueryLoadTextures; virtual; 61 62 procedure UnloadTextures; virtual; 63 procedure UseContext(ACallback: TBGLUseContextCallback; AData: Pointer = nil); 62 64 constructor Create(TheOwner: TComponent); override; 63 65 destructor Destroy; override; … … 350 352 end; 351 353 354 procedure TCustomBGLVirtualScreen.UseContext(ACallback: TBGLUseContextCallback; AData: Pointer); 355 var 356 ctx: TBGLContext; 357 begin 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; 366 end; 367 352 368 procedure TCustomBGLVirtualScreen.RedrawContent(ctx: TBGLContext); 353 369 var -
GraphicTest/Packages/bgrabitmap/bgraanimatedgif.pas
r494 r521 39 39 40 40 procedure CheckFrameIndex(AIndex: integer); 41 function GetAverageDelayMs: integer; 41 42 function GetCount: integer; 42 43 function GetFrameDelayMs(AIndex: integer): integer; … … 81 82 EraseColor: TColor; 82 83 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; 87 91 function Duplicate: TBGRAAnimatedGif; 88 92 function AddFrame(AImage: TFPCustomImage; X,Y: integer; ADelayMs: integer; 89 93 ADisposeMode: TDisposeMode = dmErase; AHasLocalPalette: boolean = false) : integer; 90 procedure InsertFrame(AIndex: integer; AImage: T BGRABitmap; X,Y: integer; ADelayMs: integer;94 procedure InsertFrame(AIndex: integer; AImage: TFPCustomImage; X,Y: integer; ADelayMs: integer; 91 95 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); 92 107 93 108 {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; 96 113 procedure LoadFromFile(const AFilenameUTF8: string); override; 97 114 procedure SaveToFile(const AFilenameUTF8: string); override; … … 100 117 procedure SetSize(AWidth,AHeight: integer); virtual; 101 118 procedure SaveToStream(Stream: TStream; AQuantizer: TBGRAColorQuantizerAny; 102 ADitheringAlgorithm: TDitheringAlgorithm); virtual; overload;119 ADitheringAlgorithm: TDitheringAlgorithm); overload; virtual; 103 120 procedure Clear; override; 104 121 destructor Destroy; override; … … 126 143 property AspectRatio: single read FAspectRatio write SetAspectRatio; 127 144 property TotalAnimationTimeMs: Int64 read FTotalAnimationTime; 145 property AverageDelayMs: integer read GetAverageDelayMs; 128 146 end; 129 147 … … 184 202 data.BackgroundColor := BackgroundColor; 185 203 data.Images := FImages; 204 data.LoopCount := LoopCount; 186 205 GIFSaveToStream(data, Stream, AQuantizer, ADitheringAlgorithm); 187 206 end; … … 233 252 Inc(nextImage); 234 253 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; 236 266 237 267 if nextImage = previousImage then 238 268 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; 242 275 break; 243 276 end; … … 370 403 end; 371 404 405 function TBGRAAnimatedGif.GetAverageDelayMs: integer; 406 var sum: int64; 407 i: Integer; 408 begin 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 417 end; 418 372 419 function TBGRAAnimatedGif.GetCount: integer; 373 420 begin … … 437 484 end; 438 485 486 constructor TBGRAAnimatedGif.Create(stream: TStream; AMaxImageCount: integer); 487 begin 488 inherited Create; 489 Init; 490 LoadFromStream(stream, AMaxImageCount); 491 end; 492 439 493 constructor TBGRAAnimatedGif.Create; 440 494 begin … … 478 532 end; 479 533 480 procedure TBGRAAnimatedGif.InsertFrame(AIndex: integer; AImage: T BGRABitmap; X,534 procedure TBGRAAnimatedGif.InsertFrame(AIndex: integer; AImage: TFPCustomImage; X, 481 535 Y: integer; ADelayMs: integer; ADisposeMode: TDisposeMode; 482 536 AHasLocalPalette: boolean); … … 491 545 with FImages[AIndex] do 492 546 begin 493 Image := AImage.Duplicate as TBGRABitmap;547 Image := TBGRABitmap.Create(AImage); 494 548 Position := Point(x,y); 495 549 DelayMs := ADelayMs; … … 500 554 end; 501 555 556 function TBGRAAnimatedGif.AddFullFrame(AImage: TFPCustomImage; 557 ADelayMs: integer; AHasLocalPalette: boolean): integer; 558 begin 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); 564 end; 565 566 procedure TBGRAAnimatedGif.InsertFullFrame(AIndex: integer; 567 AImage: TFPCustomImage; ADelayMs: integer; AHasLocalPalette: boolean); 568 var nextImage: TBGRABitmap; 569 begin 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; 593 end; 594 595 procedure TBGRAAnimatedGif.ReplaceFullFrame(AIndex: integer; 596 AImage: TFPCustomImage; ADelayMs: integer; AHasLocalPalette: boolean); 597 begin 598 DeleteFrame(AIndex, True); 599 if AIndex > 0 then FrameDisposeMode[AIndex-1] := dmErase; 600 InsertFrame(AIndex, AImage, 0,0, ADelayMs, dmErase, AHasLocalPalette); 601 end; 602 603 procedure TBGRAAnimatedGif.DeleteFrame(AIndex: integer; 604 AEnsureNextFrameDoesNotChange: boolean); 605 var 606 nextImage: TBGRABitmap; 607 i: Integer; 608 begin 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; 633 end; 634 502 635 procedure TBGRAAnimatedGif.LoadFromStream(Stream: TStream); 636 begin 637 LoadFromStream(Stream, maxLongint); 638 end; 639 640 procedure TBGRAAnimatedGif.LoadFromStream(Stream: TStream; 641 AMaxImageCount: integer); 503 642 var data: TGIFData; 504 643 i: integer; 505 644 begin 506 data := GIFLoadFromStream(Stream );645 data := GIFLoadFromStream(Stream, AMaxImageCount); 507 646 508 647 ClearViewer; … … 512 651 FBackgroundColor := data.BackgroundColor; 513 652 FAspectRatio:= data.AspectRatio; 653 LoopDone := 0; 654 LoopCount := data.LoopCount; 514 655 515 656 SetLength(FImages, length(data.Images)); … … 519 660 FImages[i] := data.Images[i]; 520 661 FTotalAnimationTime += FImages[i].DelayMs; 662 end; 663 end; 664 665 procedure TBGRAAnimatedGif.LoadFromResource(AFilename: string); 666 var 667 stream: TStream; 668 begin 669 stream := BGRAResource.GetResourceStream(AFilename); 670 try 671 LoadFromStream(stream); 672 finally 673 stream.Free; 521 674 end; 522 675 end; … … 658 811 FImages[i].Image.FreeReference; 659 812 FImages := nil; 813 LoopDone := 0; 814 LoopCount := 0; 660 815 end; 661 816 … … 959 1114 begin 960 1115 BackgroundMode := gbmSaveBackgroundOnce; 1116 LoopCount := 0; 1117 LoopDone := 0; 961 1118 end; 962 1119 … … 981 1138 Mem: TBGRABitmap; 982 1139 begin 983 gif := TBGRAAnimatedGif.Create(Str );1140 gif := TBGRAAnimatedGif.Create(Str, 1); 984 1141 Mem := gif.MemBitmap; 985 1142 if Img is TBGRABitmap then -
GraphicTest/Packages/bgrabitmap/bgrabitmap.inc
r494 r521 17 17 to comment them if the functions are not available } 18 18 {$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 } 20 20 21 21 {$MODESWITCH ADVANCEDRECORDS} 22 {$MODESWITCH TypeHelpers} 23 -
GraphicTest/Packages/bgrabitmap/bgrabitmap.pas
r494 r521 133 133 begin 134 134 ... 135 BGRAReplace( temp, someBmp.Filter... );135 BGRAReplace(someBmp, someBmp.Filter... ); 136 136 end; 137 137 } -
GraphicTest/Packages/bgrabitmap/bgrabitmappack.lpk
r494 r521 9 9 <PathDelim Value="\"/> 10 10 <SearchPaths> 11 <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS) \$(FPCVer)"/>11 <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)-$(BuildMode)"/> 12 12 </SearchPaths> 13 13 <Parsing> … … 18 18 <CodeGeneration> 19 19 <Optimizations> 20 <OptimizationLevel Value=" 3"/>20 <OptimizationLevel Value="0"/> 21 21 <VariablesInRegisters Value="True"/> 22 22 </Optimizations> … … 30 30 <Description Value="Drawing routines with alpha blending and antialiasing"/> 31 31 <License Value="modified LGPL"/> 32 <Version Major="9" Minor=" 3"/>33 <Files Count="1 08">32 <Version Major="9" Minor="9" Release="3"/> 33 <Files Count="120"> 34 34 <Item1> 35 35 <Filename Value="bgraanimatedgif.pas"/> … … 454 454 <Item106> 455 455 <Filename Value="bgramultifiletype.pas"/> 456 <UnitName Value=" bgramultifiletype"/>456 <UnitName Value="BGRAMultiFileType"/> 457 457 </Item106> 458 458 <Item107> … … 464 464 <UnitName Value="BGRALazResource"/> 465 465 </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> 466 514 </Files> 467 515 <RequiredPkgs Count="2"> … … 479 527 <PublishOptions> 480 528 <Version Value="2"/> 481 <IgnoreBinaries Value="False"/>482 529 </PublishOptions> 483 530 <CustomOptions Items="ExternHelp" Version="2"> -
GraphicTest/Packages/bgrabitmap/bgrabitmappack.pas
r494 r521 5 5 unit BGRABitmapPack; 6 6 7 {$warn 5023 off : no warning about unused units} 7 8 interface 8 9 … … 24 25 BGRAWriteBmpMioMap, BGRAOpenGLType, BGRASpriteGL, BGRAOpenGL, BGRACanvasGL, 25 26 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; 27 31 28 32 implementation -
GraphicTest/Packages/bgrabitmap/bgrabitmappack4fpgui.lpk
r494 r521 34 34 <Description Value="Drawing routines with alpha blending and antialiasing"/> 35 35 <License Value="modified LGPL"/> 36 <Version Major="9" Minor=" 3"/>37 <Files Count="9 6">36 <Version Major="9" Minor="9" Release="3"/> 37 <Files Count="97"> 38 38 <Item1> 39 39 <Filename Value="bgraanimatedgif.pas"/> … … 417 417 </Item95> 418 418 <Item96> 419 <Filename Value="bgra lazresource.pas"/>420 <UnitName Value="BGRA LazResource"/>419 <Filename Value="bgraunicode.pas"/> 420 <UnitName Value="BGRAUnicode"/> 421 421 </Item96> 422 <Item97> 423 <Filename Value="bezier.inc"/> 424 <Type Value="Include"/> 425 </Item97> 422 426 </Files> 423 427 <RequiredPkgs Count="3"> -
GraphicTest/Packages/bgrabitmap/bgrabitmappack4fpgui.pas
r494 r521 23 23 BGRAWritePNG, BGRAGifFormat, BGRASceneTypes, BGRARenderer3D, 24 24 BGRAWriteBmpMioMap, BGRAPhoxo, BGRAFilterScanner, BGRAFilterType, 25 BGRAFilterBlur ;25 BGRAFilterBlur, BGRAMultiFileType, BGRAWinResource, BGRAUnicode; 26 26 27 27 implementation -
GraphicTest/Packages/bgrabitmap/bgrabitmappack4nogui.lpk
r494 r521 36 36 <Description Value="Drawing routines with alpha blending and antialiasing"/> 37 37 <License Value="modified LGPL"/> 38 <Version Major="9" Minor=" 3"/>39 <Files Count="10 0">38 <Version Major="9" Minor="9" Release="3"/> 39 <Files Count="101"> 40 40 <Item1> 41 41 <Filename Value="bgraanimatedgif.pas"/> … … 435 435 </Item99> 436 436 <Item100> 437 <Filename Value="bgra lazresource.pas"/>438 <UnitName Value="BGRA LazResource"/>437 <Filename Value="bgraunicode.pas"/> 438 <UnitName Value="BGRAUnicode"/> 439 439 </Item100> 440 <Item101> 441 <Filename Value="bezier.inc"/> 442 <Type Value="Include"/> 443 </Item101> 440 444 </Files> 441 445 <RequiredPkgs Count="2"> -
GraphicTest/Packages/bgrabitmap/bgrabitmappack4nogui.pas
r494 r521 5 5 unit BGRABitmapPack4NoGUI; 6 6 7 {$warn 5023 off : no warning about unused units} 7 8 interface 8 9 … … 23 24 BGRANoGUIBitmap, BGRASceneTypes, BGRARenderer3D, BGRAWriteBmpMioMap, 24 25 BGRASpriteGL, BGRAOpenGLType, BGRAOpenGL, BGRACanvasGL, BGRAPhoxo, 25 BGRAFilterScanner, BGRAFilterType; 26 BGRAFilterScanner, BGRAFilterType, BGRAFilterBlur, BGRAMultiFileType, 27 BGRAWinResource, BGRAUnicode; 26 28 27 29 implementation -
GraphicTest/Packages/bgrabitmap/bgrabitmaptypes.pas
r494 r521 33 33 uses 34 34 Classes, Types, BGRAGraphics, 35 FPImage, FPImgCanv{$IFDEF BGRABITMAP_USE_LCL}, GraphType{$ENDIF},35 FPImage, FPImgCanv{$IFDEF BGRABITMAP_USE_LCL}, LCLType, GraphType, LResources{$ENDIF}, 36 36 BGRAMultiFileType; 37 37 … … 40 40 Int32or64 = {$IFDEF CPU64}Int64{$ELSE}LongInt{$ENDIF}; 41 41 UInt32or64 = {$IFDEF CPU64}UInt64{$ELSE}LongWord{$ENDIF}; 42 HDC = {$IFDEF BGRABITMAP_USE_LCL}LCLType.HDC{$ELSE}PtrUInt{$ENDIF}; 42 43 43 44 {=== Miscellaneous types ===} … … 78 79 79 80 TTextLayout = BGRAGraphics.TTextLayout; 81 TFontBidiMode = (fbmAuto, fbmLeftToRight, fbmRightToLeft); 82 TBidiTextAlignment = (btaNatural, btaOpposite, btaLeftJustify, btaRightJustify, btaCenter); 80 83 81 84 const 85 RadialBlurTypeToStr: array[TRadialBlurType] of string = 86 ('Normal','Disk','Corona','Precise','Fast','Box'); 87 88 82 89 tlTop = BGRAGraphics.tlTop; 83 90 tlCenter = BGRAGraphics.tlCenter; … … 285 292 {** Returns the total size of the string provided using the current font. 286 293 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; 288 299 289 300 {** Draws the UTF8 encoded string, with color ''c''. … … 292 303 If align is taRightJustify, (''x'',''y'') is the top-right corner. 293 304 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; 295 307 296 308 {** Same as above functions, except that the text is filled using texture. 297 309 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; 299 312 300 313 {** 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; 302 315 {** 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; 304 317 305 318 {** Draw the UTF8 encoded string at the coordinate (''x'',''y''), clipped inside the rectangle ''ARect''. 306 319 Additional style information is provided by the style parameter. 307 320 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; 309 322 310 323 {** 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; 312 325 313 326 {** Copy the path for the UTF8 encoded string into ''ADest''. … … 316 329 If ''align'' is ''taRightJustify'', (''x'',''y'') is the top-right corner. } 317 330 procedure CopyTextPathTo({%H-}ADest: IBGRAPath; {%H-}x, {%H-}y: single; {%H-}s: string; {%H-}align: TAlignment); virtual; //optional 331 function HandlesTextPath: boolean; virtual; 318 332 end; 319 333 … … 332 346 byte index } 333 347 function 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 } 335 349 procedure BGRADefaultWordBreakHandler(var ABefore, AAfter: string); 336 350 … … 395 409 ifGif, 396 410 {** BMP format, transparency, no compression. Note that transparency is 397 not supported by all BMP readers so it is notrecommended to avoid411 not supported by all BMP readers so it is recommended to avoid 398 412 storing images with transparency in this format } 399 413 ifBmp, 414 {** iGO BMP (16-bit, rudimentary lossless compression) } 415 ifBmpMioMap, 400 416 {** ICO format, contains different sizes of the same image } 401 417 ifIco, 418 {** CUR format, has hotspot, contains different sizes of the same image } 419 ifCur, 402 420 {** PCX format, opaque, rudimentary lossless compression } 403 421 ifPcx, … … 420 438 {** X-Pixmap, text encoded image, limited support } 421 439 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; 424 462 425 463 {* Options when loading an image } … … 458 496 {$I bgracustombitmap.inc} 459 497 498 operator =(const AGuid1, AGuid2: TGuid): boolean; 499 500 type 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 511 var 512 BGRAResource : TBGRAResourceManager; 513 460 514 implementation 461 515 462 uses Math, SysUtils, BGRAUTF8, 463 FPRead Tiff, FPReadXwd, FPReadXPM,516 uses Math, SysUtils, BGRAUTF8, BGRAUnicode, 517 FPReadXwd, FPReadXPM, 464 518 FPWriteTiff, FPWriteJPEG, BGRAWritePNG, FPWriteBMP, FPWritePCX, 465 519 FPWriteTGA, FPWriteXPM; … … 532 586 533 587 procedure BGRADefaultWordBreakHandler(var ABefore, AAfter: string); 534 var p: integer; 535 begin 536 if (AAfter <> '') and (ABefore <> '') and (AAfter[1]<> ' ') and (ABefore[length(ABefore)] <> ' ') then 588 const spacingChars = [' ']; 589 wordBreakChars = [' ',#9,'-','?','!']; 590 var p, charLen: integer; 591 u: Cardinal; 592 begin 593 if (AAfter <> '') and (ABefore <> '') and not (AAfter[1] in spacingChars) and not (ABefore[length(ABefore)] in wordBreakChars) then 537 594 begin 538 595 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 540 651 if p > 1 then //can put the word after 541 652 begin … … 547 658 end; 548 659 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); 551 662 end; 552 663 … … 567 678 { TBGRACustomFontRenderer } 568 679 680 function TBGRACustomFontRenderer.TextSizeAngle(sUTF8: string; 681 orientationTenthDegCCW: integer): TSize; 682 begin 683 result := TextSize(sUTF8); //ignore orientation by default 684 end; 685 686 procedure TBGRACustomFontRenderer.TextOut(ADest: TBGRACustomBitmap; x, 687 y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment; 688 ARightToLeft: boolean); 689 begin 690 //if RightToLeft is not handled 691 TextOut(ADest,x,y,sUTF8,c,align); 692 end; 693 694 procedure TBGRACustomFontRenderer.TextOut(ADest: TBGRACustomBitmap; x, 695 y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment; 696 ARightToLeft: boolean); 697 begin 698 //if RightToLeft is not handled 699 TextOut(ADest,x,y,sUTF8,texture,align); 700 end; 701 569 702 procedure TBGRACustomFontRenderer.CopyTextPathTo(ADest: IBGRAPath; x, y: single; s: string; align: TAlignment); 570 703 begin {optional implementation} end; 704 705 function TBGRACustomFontRenderer.HandlesTextPath: boolean; 706 begin 707 result := false; 708 end; 571 709 572 710 … … 825 963 end; 826 964 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; 829 973 830 974 if (copy(magicAsText,1,4) = 'PDN3') then … … 852 996 with CreateBGRAImageReader(ifOpenRaster) do 853 997 try 998 AStream.Position := streamStartPos; 854 999 if CheckContents(AStream) then inc(scores[ifOpenRaster],2); 855 1000 finally … … 866 1011 867 1012 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]); 868 1015 869 1016 AStream.Position := streamStartPos; … … 915 1062 if (ext = '.pcx') then result := ifPcx else 916 1063 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 918 1066 if (ext = '.pdn') then result := ifPaintDotNet else 919 1067 if (ext = '.lzp') then result := ifLazPaint else … … 924 1072 if (ext = '.xwd') then result := ifXwd else 925 1073 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; 927 1076 end; 928 1077 … … 934 1083 ifGif: result := 'gif'; 935 1084 ifBmp: result := 'bmp'; 1085 ifBmpMioMap: result := 'bmp'; 936 1086 ifIco: result := 'ico'; 1087 ifCur: result := 'ico'; 937 1088 ifPcx: result := 'pcx'; 938 1089 ifPaintDotNet: result := 'pdn'; 939 1090 ifLazPaint: result := 'lzp'; 940 1091 ifOpenRaster: result := 'ora'; 1092 ifPhoxo: result := 'oXo'; 941 1093 ifPsd: result := 'psd'; 942 1094 ifTarga: result := 'tga'; … … 944 1096 ifXwd: result := 'xwd'; 945 1097 ifXPixMap: result := 'xpm'; 946 if BmpMioMap: result := 'bmp';1098 ifSvg: result := 'svg'; 947 1099 else result := '?'; 948 1100 end; … … 957 1109 ifOpenRaster: raise exception.Create('You need to call BGRAOpenRaster.RegisterOpenRasterFormat to read this image.'); 958 1110 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.'); 959 1112 else 960 1113 raise exception.Create('The image reader is not registered for this image format.'); … … 971 1124 ifUnknown: raise exception.Create('The image format is unknown'); 972 1125 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.'); 973 1127 else 974 1128 raise exception.Create('The image writer is not registered for this image format.'); … … 995 1149 result := DefaultBGRAImageWriter[AFormat].Create; 996 1150 end; 1151 1152 operator =(const AGuid1, AGuid2: TGuid): boolean; 1153 begin 1154 result := CompareMem(@AGuid1, @AGuid2, sizeof(TGuid)); 1155 end; 1156 1157 type 1158 TResourceType = record 1159 ext: string; 1160 code: pchar; 1161 end; 1162 1163 const 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 1175 function TBGRAResourceManager.GetWinResourceType(AExtension: string): pchar; 1176 var 1177 i: Integer; 1178 begin 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); 1185 end; 1186 1187 function TBGRAResourceManager.GetResourceStream(AFilename: string): TStream; 1188 var 1189 name,ext: RawByteString; 1190 rt: PChar; 1191 begin 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); 1200 end; 1201 1202 function TBGRAResourceManager.IsWinResource(AFilename: string): boolean; 1203 var 1204 name,ext: RawByteString; 1205 rt: PChar; 1206 begin 1207 ext := UpperCase(ExtractFileExt(AFilename)); 1208 name := ChangeFileExt(AFilename,''); 1209 rt := GetWinResourceType(ext); 1210 result := FindResource(HINSTANCE, pchar(name), rt)<>0; 1211 end; 1212 1213 {$IFDEF BGRABITMAP_USE_LCL} 1214 type 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 1226 function TLCLResourceManager.FindLazarusResource(AFilename: string): TLResource; 1227 var 1228 name,ext: RawByteString; 1229 begin 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); 1237 end; 1238 1239 function TLCLResourceManager.GetResourceStream(AFilename: string): TStream; 1240 var 1241 res: TLResource; 1242 begin 1243 res := FindLazarusResource(AFilename); 1244 if Assigned(res) then 1245 result := TLazarusResourceStream.CreateFromHandle(res) 1246 else 1247 result := inherited GetResourceStream(AFilename); 1248 end; 1249 1250 function TLCLResourceManager.IsWinResource(AFilename: string): boolean; 1251 begin 1252 if FindLazarusResource(AFilename)<>nil then 1253 result := false 1254 else 1255 Result:=inherited IsWinResource(AFilename); 1256 end; 1257 1258 {$ENDIF} 997 1259 998 1260 initialization … … 1013 1275 //writing XWD not implemented 1014 1276 1015 DefaultBGRAImageReader[ifTiff] := TFPReaderTiff;1016 1277 DefaultBGRAImageReader[ifXwd] := TFPReaderXWD; 1017 1278 //the other readers are registered by their unit 1018 1279 1280 {$IFDEF BGRABITMAP_USE_LCL} 1281 BGRAResource := TLCLResourceManager.Create; 1282 {$ELSE} 1283 BGRAResource := TBGRAResourceManager.Create; 1284 {$ENDIF} 1285 1019 1286 finalization 1020 1287 … … 1024 1291 {$DEFINE INCLUDE_FINAL} 1025 1292 {$I bgrapixel.inc} 1293 1294 BGRAResource.Free; 1026 1295 end. -
GraphicTest/Packages/bgrabitmap/bgrablend.pas
r494 r521 698 698 procedure DrawPixelInlineWithAlphaCheck(dest: PBGRAPixel; const c: TBGRAPixel); 699 699 begin 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; 708 706 end; 709 707 … … 711 709 begin 712 710 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); 721 712 end; 722 713 … … 748 739 begin 749 740 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; 758 747 end; 759 748 760 749 procedure DrawPixelInlineExpandedOrNotWithAlphaCheck(dest: PBGRAPixel; const ec: TExpandedPixel; c: TBGRAPixel); 761 750 begin 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; 770 757 end; 771 758 772 759 procedure DrawPixelInlineNoAlphaCheck(dest: PBGRAPixel; const c: TBGRAPixel); 773 760 var 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; 762 begin 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; 791 792 end; 792 793 … … 794 795 const ec: TExpandedPixel; calpha: byte); 795 796 var 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; 798 begin 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; 813 833 end; 814 834 815 835 procedure FastBlendPixelInline(dest: PBGRAPixel; const c: TBGRAPixel); 816 836 var 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; 838 begin 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; 839 872 end; 840 873 -
GraphicTest/Packages/bgrabitmap/bgracanvas.pas
r494 r521 188 188 Filled: boolean = False; 189 189 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; 191 192 procedure CopyRect(X,Y: Integer; SrcBitmap: TBGRACustomBitmap; SrcRect: TRect); 192 193 procedure StretchDraw(DestRect: TRect; SrcBitmap: TBGRACustomBitmap; HorizFlip: Boolean = false; VertFlip: Boolean = false); … … 420 421 begin 421 422 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); 426 424 end; 427 425 428 426 procedure TBGRAPen.SetPenStyle(const AValue: TPenStyle); 429 427 begin 428 if AValue = psPattern then exit; 430 429 Case AValue of 431 430 psSolid: FCustomPenStyle := SolidPenStyle; … … 811 810 begin 812 811 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; 815 814 Arc65536(x1,y1,x2,y2,angle1, angle2, [aoClosePath,aoFillPath]); 816 815 end; … … 828 827 begin 829 828 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; 832 831 Arc65536(x1,y1,x2,y2,angle1, angle2, [aoPie,aoFillPath]); 833 832 end; … … 1121 1120 multi := TBGRAMultishapeFiller.Create; 1122 1121 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); 1132 1128 multi.Draw(FBitmap); 1133 1129 multi.Free; … … 1434 1430 end; 1435 1431 1432 procedure TBGRACanvas.Draw(X, Y: Integer; SrcBitmap: TBitmap); 1433 begin 1434 FBitmap.PutImage(X,Y,SrcBitmap,dmDrawWithTransparency); 1435 end; 1436 1436 1437 procedure TBGRACanvas.CopyRect(X, Y: Integer; SrcBitmap: TBGRACustomBitmap; 1437 1438 SrcRect: TRect); -
GraphicTest/Packages/bgrabitmap/bgracanvas2d.pas
r494 r521 32 32 procedure addColorStop(APosition: single; AColor: string); 33 33 procedure setColors(ACustomGradient: TBGRACustomGradient); 34 function GetGammaCorrection: boolean; 35 procedure SetGammaCorrection(AValue: boolean); 36 property gammaCorrection: boolean read GetGammaCorrection write SetGammaCorrection; 34 37 end; 35 38 … … 51 54 strokeTextureProvider: IBGRACanvasTextureProvider2D; 52 55 fillColor: TBGRAPixel; 56 fillMode: TFillMode; 53 57 fillTextureProvider: IBGRACanvasTextureProvider2D; 54 58 globalAlpha: byte; … … 91 95 FPathPoints: array of TPointF; 92 96 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; 93 105 FFontRenderer: TBGRACustomFontRenderer; 94 106 FLastCoord, FStartCoord: TPointF; … … 119 131 function GetTextAlignLCL: TAlignment; 120 132 function GetTextBaseline: string; 133 function GetFillMode: TFillMode; 121 134 function GetWidth: Integer; 122 135 procedure SetFontName(AValue: string); … … 131 144 procedure FillPoly(const points: array of TPointF); 132 145 procedure FillStrokePoly(const points: array of TPointF; fillOver: boolean); 146 procedure FillTexts(AErase: boolean); 133 147 procedure SetLineJoinLCL(AValue: TPenJoinStyle); 134 148 procedure SetLineWidth(const AValue: single); … … 145 159 procedure SetTextAlignLCL(AValue: TAlignment); 146 160 procedure SetTextBaseine(AValue: string); 161 procedure SetFillMode(mode: TFillMode); 147 162 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); 149 165 procedure ClearPoly(const points: array of TPointF); 150 166 function ApplyTransform(const points: array of TPointF; matrix: TAffineMatrix): ArrayOfTPointF; overload; … … 163 179 function getCursor: TBGRACustomPathCursor; //IBGRAPath 164 180 public 165 antialiasing, linearBlend : boolean;181 antialiasing, linearBlend, gradientGammaCorrection: boolean; 166 182 constructor Create(ASurface: TBGRACustomBitmap); 167 183 destructor Destroy; override; … … 202 218 procedure shadowNone; 203 219 function getShadowColor: TBGRAPixel; 220 204 221 function createLinearGradient(x0,y0,x1,y1: single): IBGRACanvasGradient2D; overload; 205 222 function createLinearGradient(p0,p1: TPointF): IBGRACanvasGradient2D; overload; 206 223 function createLinearGradient(x0,y0,x1,y1: single; Colors: TBGRACustomGradient): IBGRACanvasGradient2D; overload; 207 224 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 208 231 function createPattern(image: TBGRACustomBitmap; repetition: string): IBGRACanvasTextureProvider2D; overload; 209 232 function createPattern(texture: IBGRAScanner): IBGRACanvasTextureProvider2D; overload; … … 222 245 procedure moveTo(x,y: single); overload; 223 246 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; 226 249 procedure polylineTo(const pts: array of TPointF); 227 250 procedure quadraticCurveTo(cpx,cpy,x,y: single); overload; 228 procedure quadraticCurveTo(const cp,pt: TPointF); overload;251 procedure quadraticCurveTo(constref cp,pt: TPointF); overload; 229 252 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; 231 254 procedure rect(x,y,w,h: single); 232 255 procedure roundRect(x,y,w,h,radius: single); overload; … … 240 263 procedure arc(cx, cy, rx,ry, xAngleRadCW, startAngleRadCW, endAngleRadCW: single; anticlockwise: boolean); overload; 241 264 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; 243 266 procedure arcTo(x1, y1, x2, y2, radius: single); overload; 244 267 procedure arcTo(p1,p2: TPointF; radius: single); overload; … … 297 320 property textAlign: string read GetTextAlign write SetTextAlign; 298 321 property textBaseline: string read GetTextBaseline write SetTextBaseine; 322 323 property fillMode: TFillMode read GetFillMode write SetFillMode; 299 324 300 325 property currentPath: ArrayOfTPointF read GetCurrentPathAsPoints; … … 327 352 nbColorStops: integer; 328 353 FCustomGradient: TBGRACustomGradient; 354 FGammaCorrection: boolean; 329 355 protected 330 356 scanner: TBGRAGradientScanner; … … 332 358 function getColorArray: TGradientArrayOfColors; 333 359 function getPositionArray: TGradientArrayOfPositions; 360 procedure GetBGRAGradient(out ABGRAGradient: TBGRACustomGradient; out AOwned: boolean); 361 function GetGammaCorrection: boolean; 362 procedure SetGammaCorrection(AValue: boolean); 334 363 public 364 constructor Create; 335 365 function getTexture: IBGRAScanner; override; 336 366 destructor Destroy; override; … … 341 371 property texture: IBGRAScanner read GetTexture; 342 372 property colorStopCount: integer read nbColorStops; 373 property gammaCorrection: boolean read GetGammaCorrection write SetGammaCorrection; 343 374 end; 344 375 … … 348 379 protected 349 380 o1,o2: TPointF; 381 FTransform: TAffineMatrix; 350 382 procedure CreateScanner; override; 351 383 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); 354 400 end; 355 401 … … 452 498 GradientColors: TBGRACustomGradient; 453 499 begin 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); 463 501 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; 503 end; 504 505 constructor TBGRACanvasLinearGradient2D.Create(x0, y0, x1, y1: single; transform: TAffineMatrix); 467 506 begin 468 507 o1 := PointF(x0,y0); 469 508 o2 := PointF(x1,y1); 470 end; 471 472 constructor TBGRACanvasLinearGradient2D.Create(p0, p1: TPointF); 509 FTransform := transform; 510 end; 511 512 constructor TBGRACanvasLinearGradient2D.Create(p0, p1: TPointF; transform: TAffineMatrix); 473 513 begin 474 514 o1 := p0; 475 515 o2 := p1; 516 FTransform := transform; 517 end; 518 519 { TBGRACanvasRadialGradient2D } 520 521 procedure TBGRACanvasRadialGradient2D.CreateScanner; 522 var GradientOwner: boolean; 523 GradientColors: TBGRACustomGradient; 524 begin 525 GetBGRAGradient(GradientColors,GradientOwner); 526 scanner := TBGRAGradientScanner.Create(GradientColors,c0,cr0,c1,cr1,GradientOwner); 527 scanner.FlipGradient := not FFlipGradient; 528 scanner.Transform := FTransform; 529 end; 530 531 constructor TBGRACanvasRadialGradient2D.Create(x0, y0, r0, x1, y1, r1: single; 532 transform: TAffineMatrix; flipGradient: boolean); 533 begin 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; 540 end; 541 542 constructor TBGRACanvasRadialGradient2D.Create(p0: TPointF; r0: single; 543 p1: TPointF; r1: single; transform: TAffineMatrix; flipGradient: boolean); 544 begin 545 self.c0 := p0; 546 self.cr0 := r0; 547 self.c1 := p1; 548 self.cr1 := r1; 549 FTransform := transform; 550 FFlipGradient := flipGradient; 476 551 end; 477 552 478 553 { TBGRACanvasGradient2D } 479 554 480 function TBGRACanvasGradient2D. GetTexture: IBGRAScanner;555 function TBGRACanvasGradient2D.getTexture: IBGRAScanner; 481 556 begin 482 557 if scanner = nil then CreateScanner; 483 558 result := scanner; 559 end; 560 561 function TBGRACanvasGradient2D.GetGammaCorrection: boolean; 562 begin 563 result := FGammaCorrection; 564 end; 565 566 procedure TBGRACanvasGradient2D.SetGammaCorrection(AValue: boolean); 567 begin 568 FGammaCorrection:= AValue; 569 FreeAndNil(scanner); 570 end; 571 572 constructor TBGRACanvasGradient2D.Create; 573 begin 574 inherited Create; 575 scanner := nil; 576 FGammaCorrection:= false; 484 577 end; 485 578 … … 500 593 for i := 0 to nbColorStops-1 do 501 594 result[i] := colorStops[i].position; 595 end; 596 597 procedure TBGRACanvasGradient2D.GetBGRAGradient(out 598 ABGRAGradient: TBGRACustomGradient; out AOwned: boolean); 599 begin 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; 502 617 end; 503 618 … … 593 708 result.strokeTextureProvider := strokeTextureProvider; 594 709 result.fillColor := fillColor; 710 result.fillMode := fillMode; 595 711 result.fillTextureProvider := fillTextureProvider; 596 712 result.globalAlpha := globalAlpha; … … 945 1061 procedure TBGRACanvas2D.FillPoly(const points: array of TPointF); 946 1062 var 1063 bfill: boolean; 947 1064 tempScan: TBGRACustomScanner; 948 1065 begin 949 1066 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; 951 1069 if currentState.clipMaskReadOnly <> nil then 952 1070 begin … … 956 1074 tempScan := TBGRASolidColorMaskScanner.Create(currentState.clipMaskReadOnly,Point(0,0),ApplyGlobalAlpha(currentState.fillColor)); 957 1075 if self.antialiasing then 958 BGRAPolygon.FillPolyAntialiasWithTexture(surface, points, tempScan, true, linearBlend)1076 BGRAPolygon.FillPolyAntialiasWithTexture(surface, points, tempScan, bfill, linearBlend) 959 1077 else 960 BGRAPolygon.FillPolyAliasedWithTexture(surface, points, tempScan, true, GetDrawMode);1078 BGRAPolygon.FillPolyAliasedWithTexture(surface, points, tempScan, bfill, GetDrawMode); 961 1079 tempScan.free; 962 1080 end else … … 968 1086 tempScan := TBGRAOpacityScanner.Create(currentState.fillTextureProvider.texture, currentState.globalAlpha); 969 1087 if self.antialiasing then 970 BGRAPolygon.FillPolyAntialiasWithTexture(surface, points, tempScan, true, linearBlend)1088 BGRAPolygon.FillPolyAntialiasWithTexture(surface, points, tempScan, bfill, linearBlend) 971 1089 else 972 BGRAPolygon.FillPolyAliasedWithTexture(surface, points, tempScan, true, GetDrawMode);1090 BGRAPolygon.FillPolyAliasedWithTexture(surface, points, tempScan, bfill, GetDrawMode); 973 1091 tempScan.Free; 974 1092 end else 975 1093 begin 976 1094 if self.antialiasing then 977 BGRAPolygon.FillPolyAntialiasWithTexture(surface, points, currentState.fillTextureProvider.texture, true, linearBlend)1095 BGRAPolygon.FillPolyAntialiasWithTexture(surface, points, currentState.fillTextureProvider.texture, bfill, linearBlend) 978 1096 else 979 BGRAPolygon.FillPolyAliasedWithTexture(surface, points, currentState.fillTextureProvider.texture, true, GetDrawMode);1097 BGRAPolygon.FillPolyAliasedWithTexture(surface, points, currentState.fillTextureProvider.texture, bfill, GetDrawMode); 980 1098 end 981 1099 end … … 983 1101 begin 984 1102 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) 986 1104 else 987 BGRAPolygon.FillPolyAliased(surface, points, ApplyGlobalAlpha(currentState.fillColor), false, true, GetDrawMode)1105 BGRAPolygon.FillPolyAliased(surface, points, ApplyGlobalAlpha(currentState.fillColor), false, bfill, GetDrawMode) 988 1106 end 989 1107 end; … … 997 1115 contour : array of TPointF; 998 1116 texture: IBGRAScanner; 1117 idxContour: Integer; 999 1118 begin 1000 1119 if (length(points) = 0) or (surface = nil) then exit; … … 1002 1121 tempScan2 := nil; 1003 1122 multi := TBGRAMultishapeFiller.Create; 1004 multi.FillMode := fmWinding;1123 multi.FillMode := self.fillMode; 1005 1124 if currentState.clipMaskReadOnly <> nil then 1006 1125 begin … … 1035 1154 else 1036 1155 tempScan2 := TBGRASolidColorMaskScanner.Create(currentState.clipMaskReadOnly,Point(0,0),ApplyGlobalAlpha(currentState.strokeColor)); 1037 multi.AddPolygon(contour,tempScan);1156 idxContour := multi.AddPolygon(contour,tempScan); 1038 1157 end else 1039 1158 begin … … 1042 1161 texture := nil; 1043 1162 if texture = nil then 1044 multi.AddPolygon(contour,ApplyGlobalAlpha(currentState.strokeColor))1163 idxContour := multi.AddPolygon(contour,ApplyGlobalAlpha(currentState.strokeColor)) 1045 1164 else 1046 multi.AddPolygon(contour,texture);1165 idxContour := multi.AddPolygon(contour,texture); 1047 1166 end; 1167 multi.OverrideFillMode(idxContour, fmWinding); 1048 1168 If hasShadow then DrawShadow(points,contour); 1049 1169 end else … … 1056 1176 tempScan2.free; 1057 1177 multi.Free; 1178 end; 1179 1180 procedure TBGRACanvas2D.FillTexts(AErase: boolean); 1181 var 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; 1192 begin 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; 1058 1302 end; 1059 1303 … … 1218 1462 end; 1219 1463 1220 procedure TBGRACanvas2D.DrawShadow(const points, points2: array of TPointF );1221 const invSqrt2 = 1/sqrt(2);1464 procedure TBGRACanvas2D.DrawShadow(const points, points2: array of TPointF; 1465 AFillMode: TFillMode = fmWinding); 1222 1466 var ofsPts,ofsPts2: array of TPointF; 1223 1467 offset: TPointF; 1224 1468 i: Integer; 1225 tempBmp ,blurred: TBGRACustomBitmap;1469 tempBmp: TBGRACustomBitmap; 1226 1470 maxRect: TRect; 1227 1471 foundRect: TRect; … … 1279 1523 1280 1524 tempBmp := surface.NewBitmap(foundRect.Right-foundRect.Left,foundRect.Bottom-foundRect.Top,BGRAPixelTransparent); 1281 tempBmp.FillMode := fmWinding;1525 tempBmp.FillMode := AFillMode; 1282 1526 tempBmp.FillPolyAntialias(ofsPts, getShadowColor); 1283 1527 tempBmp.FillPolyAntialias(ofsPts2, getShadowColor); 1528 DrawShadowMask(foundRect.Left,foundRect.Top, tempBmp, true); 1529 end; 1530 1531 procedure TBGRACanvas2D.DrawShadowMask(X, Y: integer; AMask: TBGRACustomBitmap; AMaskOwned: boolean); 1532 const invSqrt2 = 1/sqrt(2); 1533 var 1534 bmp: TBGRACustomBitmap; 1535 begin 1536 bmp := AMask; 1284 1537 if shadowBlur > 0 then 1285 1538 begin … … 1287 1540 begin 1288 1541 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); 1294 1543 end 1295 1544 else 1296 1545 begin 1297 1546 if (shadowBlur < 5) and (abs(shadowBlur-round(shadowBlur)) > 1e-6) then 1298 b lurred := tempBmp.FilterBlurRadial(round(shadowBlur*10),rbPrecise)1547 bmp := AMask.FilterBlurRadial(round(shadowBlur*10),rbPrecise) 1299 1548 else 1300 blurred := tempBmp.FilterBlurRadial(round(shadowBlur),rbFast); 1301 tempBmp.Free; 1302 tempBmp := blurred; 1549 bmp := AMask.FilterBlurRadial(round(shadowBlur),rbFast); 1303 1550 end; 1304 1551 end; 1305 1552 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; 1309 1560 end; 1310 1561 … … 1436 1687 pixelCenteredCoordinates := false; 1437 1688 antialiasing := true; 1689 gradientGammaCorrection := false; 1438 1690 end; 1439 1691 … … 1606 1858 end; 1607 1859 1860 function TBGRACanvas2D.GetFillMode: TFillMode; 1861 begin 1862 result := currentState.fillMode; 1863 end; 1864 1865 procedure TBGRACanvas2D.SetFillMode(mode: TFillMode); 1866 begin 1867 currentState.fillMode := mode; 1868 end; 1869 1608 1870 procedure TBGRACanvas2D.fillStyle(color: TBGRAPixel); 1609 1871 begin … … 1660 1922 end; 1661 1923 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);1924 function TBGRACanvas2D.createLinearGradient(x0, y0, x1, y1: single): IBGRACanvasGradient2D; 1925 begin 1926 result := createLinearGradient(PointF(x0,y0), PointF(x1,y1)); 1927 end; 1928 1929 function TBGRACanvas2D.createLinearGradient(p0, p1: TPointF): IBGRACanvasGradient2D; 1930 begin 1931 result := TBGRACanvasLinearGradient2D.Create(p0,p1, 1932 AffineMatrixTranslation(FCanvasOffset.x,FCanvasOffset.y)*currentState.matrix); 1933 result.gammaCorrection := gradientGammaCorrection; 1672 1934 end; 1673 1935 … … 1683 1945 begin 1684 1946 result := createLinearGradient(p0,p1); 1947 result.setColors(Colors); 1948 end; 1949 1950 function TBGRACanvas2D.createRadialGradient(x0, y0, r0, x1, y1, r1: single; 1951 flipGradient: boolean): IBGRACanvasGradient2D; 1952 begin 1953 result := createRadialGradient(PointF(x0,y0), r0, PointF(x1,y1), r1, flipGradient); 1954 end; 1955 1956 function TBGRACanvas2D.createRadialGradient(p0: TPointF; r0: single; 1957 p1: TPointF; r1: single; flipGradient: boolean): IBGRACanvasGradient2D; 1958 begin 1959 result := TBGRACanvasRadialGradient2D.Create(p0,r0,p1,r1, 1960 AffineMatrixTranslation(FCanvasOffset.x,FCanvasOffset.y)*currentState.matrix, 1961 flipGradient); 1962 result.gammaCorrection := gradientGammaCorrection; 1963 end; 1964 1965 function TBGRACanvas2D.createRadialGradient(x0, y0, r0, x1, y1, r1: single; 1966 Colors: TBGRACustomGradient; flipGradient: boolean): IBGRACanvasGradient2D; 1967 begin 1968 result := createRadialGradient(x0,y0,r0,x1,y1,r1,flipGradient); 1969 result.setColors(Colors); 1970 end; 1971 1972 function TBGRACanvas2D.createRadialGradient(p0: TPointF; r0: single; 1973 p1: TPointF; r1: single; Colors: TBGRACustomGradient; flipGradient: boolean): IBGRACanvasGradient2D; 1974 begin 1975 result := createRadialGradient(p0,r0,p1,r1,flipGradient); 1685 1976 result.setColors(Colors); 1686 1977 end; … … 1771 2062 FLastCoord := EmptyPointF; 1772 2063 FStartCoord := EmptyPointF; 2064 FTextPaths := nil; 1773 2065 end; 1774 2066 … … 1817 2109 end; 1818 2110 1819 procedure TBGRACanvas2D.moveTo(const pt: TPointF);2111 procedure TBGRACanvas2D.moveTo(constref pt: TPointF); 1820 2112 begin 1821 2113 if (FPathPointCount <> 0) and not isEmptyPointF(FPathPoints[FPathPointCount-1]) then … … 1826 2118 end; 1827 2119 1828 procedure TBGRACanvas2D.lineTo(const pt: TPointF);2120 procedure TBGRACanvas2D.lineTo(constref pt: TPointF); 1829 2121 begin 1830 2122 AddPoint(ApplyTransform(pt)); … … 1852 2144 end; 1853 2145 1854 procedure TBGRACanvas2D.quadraticCurveTo(const cp, pt: TPointF);2146 procedure TBGRACanvas2D.quadraticCurveTo(constref cp, pt: TPointF); 1855 2147 begin 1856 2148 quadraticCurveTo(cp.x,cp.y,pt.x,pt.y); … … 1869 2161 end; 1870 2162 1871 procedure TBGRACanvas2D.bezierCurveTo(const cp1, cp2, pt: TPointF);2163 procedure TBGRACanvas2D.bezierCurveTo(constref cp1, cp2, pt: TPointF); 1872 2164 begin 1873 2165 bezierCurveTo(cp1.x,cp1.y,cp2.x,cp2.y,pt.x,pt.y); … … 2036 2328 end; 2037 2329 2038 procedure TBGRACanvas2D.arc(const arcDef: TArcDef);2330 procedure TBGRACanvas2D.arc(constref arcDef: TArcDef); 2039 2331 var previousMatrix: TAffineMatrix; 2040 2332 begin … … 2084 2376 var renderer : TBGRACustomFontRenderer; 2085 2377 previousMatrix: TAffineMatrix; 2378 fva: TFontVerticalAnchor; 2086 2379 begin 2087 2380 renderer := fontRenderer; 2381 if renderer = nil then exit; 2088 2382 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 2108 2417 FLastCoord := EmptyPointF; 2109 2418 FStartCoord := EmptyPointF; … … 2147 2456 procedure TBGRACanvas2D.fill; 2148 2457 begin 2149 if FPathPointCount = 0 then exit; 2150 FillPoly(slice(FPathPoints,FPathPointCount)); 2458 if FPathPointCount > 0 then 2459 FillPoly(slice(FPathPoints,FPathPointCount)); 2460 FillTexts(false); 2151 2461 end; 2152 2462 2153 2463 procedure TBGRACanvas2D.stroke; 2154 2464 begin 2155 if FPathPointCount = 0 then exit;2156 StrokePoly(slice(FPathPoints,FPathPointCount));2465 if FPathPointCount > 0 then 2466 StrokePoly(slice(FPathPoints,FPathPointCount)); 2157 2467 end; 2158 2468 2159 2469 procedure TBGRACanvas2D.fillOverStroke; 2160 2470 begin 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); 2163 2474 end; 2164 2475 2165 2476 procedure TBGRACanvas2D.strokeOverFill; 2166 2477 begin 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); 2169 2481 end; 2170 2482 2171 2483 procedure TBGRACanvas2D.clearPath; 2172 2484 begin 2173 if FPathPointCount = 0 then exit; 2174 ClearPoly(slice(FPathPoints,FPathPointCount)); 2485 if FPathPointCount > 0 then 2486 ClearPoly(slice(FPathPoints,FPathPointCount)); 2487 FillTexts(true); 2175 2488 end; 2176 2489 … … 2219 2532 begin 2220 2533 setlength(FPathPoints,FPathPointCount); 2221 result := IsPointInPolygon(FPathPoints,pt+FCanvasOffset, True);2534 result := IsPointInPolygon(FPathPoints,pt+FCanvasOffset, fillMode = fmWinding); 2222 2535 end; 2223 2536 end; -
GraphicTest/Packages/bgrabitmap/bgracanvasgl.pas
r494 r521 94 94 function GetUniformVariable(AProgram: DWord; AName: string): DWord; virtual; abstract; 95 95 function GetAttribVariable(AProgram: DWord; AName: string): DWord; virtual; abstract; 96 procedure SetUniformSingle(AVariable: DWord; const AValue; A Count: integer); virtual; abstract;97 procedure SetUniformInteger(AVariable: DWord; const AValue; A Count: 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; 98 98 procedure BindAttribute(AAttribute: TAttributeVariable); virtual; abstract; 99 99 procedure UnbindAttribute(AAttribute: TAttributeVariable); virtual; abstract; … … 110 110 TBGLCustomCanvas = class 111 111 private 112 FActiveFrameBuffer: TBGLCustomFrameBuffer; 112 113 FHeight: integer; 113 114 FWidth: integer; … … 115 116 FClipRect: TRect; 116 117 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; 119 120 procedure InternalArc(cx,cy,rx,ry: single; const StartPoint,EndPoint: TPointF; ABorderColor,AOuterFillColor,ACenterFillColor: TBGRAPixel; AOptions: TArcOptions; ADrawChord: boolean = false); overload; 120 121 procedure InternalArc(cx,cy,rx,ry: single; StartAngleRad,EndAngleRad: Single; ABorderColor,AOuterFillColor,ACenterFillColor: TBGRAPixel; AOptions: TArcOptions; ADrawChord: boolean = false); overload; 121 122 procedure InternalArcInRect(r: TRect; StartAngleRad,EndAngleRad: Single; ABorderColor,AOuterFillColor,ACenterFillColor: TBGRAPixel; AOptions: TArcOptions; ADrawChord: boolean = false); overload; 122 123 function ComputeEllipseC(r: TRect; AHasBorder: boolean; out cx,cy,rx,ry: single): boolean; 124 function GetHeight: integer; virtual; 125 function GetWidth: integer; virtual; 123 126 procedure SetWidth(AValue: integer); virtual; 124 127 procedure SetHeight(AValue: integer); virtual; … … 135 138 function GetFaceCulling: TFaceCulling; virtual; abstract; 136 139 procedure SetFaceCulling(AValue: TFaceCulling); virtual; abstract; 140 procedure SetActiveFrameBuffer(AValue: TBGLCustomFrameBuffer); virtual; 137 141 138 142 function GetLighting: TBGLCustomLighting; virtual; … … 142 146 procedure InternalStartPolygon(const pt: TPointF); virtual; abstract; 143 147 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; 149 153 150 154 procedure InternalEndShape; virtual; abstract; … … 163 167 procedure Fill(AColor: TBGRAPixel); virtual; abstract; 164 168 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; 170 174 procedure Polylines(const APoints: array of TPointF; AColor: TBGRAPixel; ADrawLastPoints: boolean = true); virtual; 171 175 … … 173 177 procedure FillPolyConvex(const APoints: array of TPointF; AColor: TBGRAPixel; APixelCenteredCoordinates: boolean = true); 174 178 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; 204 208 205 209 procedure DrawPath(APath: TBGLPath; c: TBGRAPixel); 206 210 procedure FillPathConvex(APath: TBGLPath; c: TBGRAPixel; APixelCenteredCoordinates: boolean = true); 207 211 208 procedure FillRectLinearColor(r: TRect; ATopLeftColor, ATopRightColor, ABottomRightColor, ABottomLeftColor: TBGRAPixel); virtual; overload;212 procedure FillRectLinearColor(r: TRect; ATopLeftColor, ATopRightColor, ABottomRightColor, ABottomLeftColor: TBGRAPixel); overload; virtual; 209 213 procedure FillRectLinearColor(x1,y1,x2,y2: single; 210 214 ATopLeftColor, ATopRightColor, ABottomRightColor, ABottomLeftColor: TBGRAPixel; 211 APixelCenteredCoordinates: boolean = true); virtual; overload;215 APixelCenteredCoordinates: boolean = true); overload; virtual; 212 216 213 217 procedure Ellipse(cx,cy,rx,ry: single; AColor: TBGRAPixel); overload; … … 247 251 procedure FillRect(r: TRect; AColor: TBGRAPixel); overload; 248 252 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; 250 254 procedure RoundRect(x1,y1,x2,y2,rx,ry: single; ABorderColor: TBGRAPixel; options: TRoundRectangleOptions = []); overload; 251 255 procedure RoundRect(x1,y1,x2,y2,rx,ry: single; ABorderColor,AFillColor: TBGRAPixel; options: TRoundRectangleOptions = []); overload; … … 275 279 procedure ResetTransform; virtual; 276 280 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; 279 283 procedure StartZBuffer; virtual; 280 284 procedure EndZBuffer; virtual; 281 285 procedure WaitForGPU({%H-}AOption: TWaitForGPUOption); virtual; 282 286 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 283 290 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; 286 294 property ClipRect: TRect read GetClipRect write SetClipRect; 287 295 property Matrix: TAffineMatrix read GetMatrix write SetMatrix; … … 346 354 var index: integer; 347 355 begin 356 if ShaderList = nil then ShaderList := TStringList.Create; 348 357 index := ShaderList.IndexOf(AName); 349 358 if index = -1 then … … 356 365 var index: integer; 357 366 begin 367 if ShaderList = nil then ShaderList := TStringList.Create; 358 368 index := ShaderList.IndexOf(AName); 359 369 if AValue = nil then … … 459 469 end; 460 470 result := true; 471 end; 472 473 function TBGLCustomCanvas.GetHeight: integer; 474 begin 475 if FActiveFrameBuffer = nil then 476 result := FHeight 477 else 478 result := FActiveFrameBuffer.Height; 479 end; 480 481 function TBGLCustomCanvas.GetWidth: integer; 482 begin 483 if FActiveFrameBuffer = nil then 484 result := FWidth 485 else 486 result := FActiveFrameBuffer.Width; 461 487 end; 462 488 … … 1189 1215 end; 1190 1216 1217 procedure TBGLCustomCanvas.SetActiveFrameBuffer(AValue: TBGLCustomFrameBuffer); 1218 begin 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); 1225 end; 1226 1191 1227 procedure TBGLCustomCanvas.SwapRect(var r: TRect); 1192 1228 var … … 1714 1750 ATexture: IBGLTexture; AAlpha: byte); 1715 1751 begin 1752 {$PUSH}{$OPTIMIZATION OFF} 1716 1753 ATexture.DrawAffine(Origin, HAxis, VAxis, AAlpha); 1754 {$POP} 1717 1755 end; 1718 1756 … … 1720 1758 ATexture: IBGLTexture; AColor: TBGRAPixel); 1721 1759 begin 1760 {$PUSH}{$OPTIMIZATION OFF} 1722 1761 ATexture.DrawAffine(Origin, HAxis, VAxis, AColor); 1762 {$POP} 1723 1763 end; 1724 1764 … … 1785 1825 end; 1786 1826 1827 function TBGLCustomCanvas.GetImage(x, y, w, h: integer): TBGRACustomBitmap; 1828 begin 1829 result := nil; 1830 end; 1831 1832 function TBGLCustomCanvas.CreateFrameBuffer(AWidth, AHeight: integer): TBGLCustomFrameBuffer; 1833 begin 1834 result := nil; 1835 raise exception.Create('Not implemented'); 1836 end; 1837 1787 1838 end. 1788 1839 -
GraphicTest/Packages/bgrabitmap/bgracolorquantization.pas
r494 r521 41 41 FSeparateAlphaChannel: boolean; 42 42 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; 45 45 protected 46 46 function GetPalette: TBGRACustomApproxPalette; override; … … 56 56 destructor Destroy; override; 57 57 procedure ApplyDitheringInplace(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; ABounds: TRect); override; 58 function GetDitheredBitmap(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; ABounds: TRect): TBGRACustomBitmap; over ride;58 function GetDitheredBitmap(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; ABounds: TRect): TBGRACustomBitmap; overload; override; 59 59 function GetDitheredBitmapIndexedData(ABitDepth: integer; AByteOrder: TRawImageByteOrder; AAlgorithm: TDitheringAlgorithm; 60 ABitmap: TBGRACustomBitmap; out AScanlineSize: PtrInt): Pointer; over ride;60 ABitmap: TBGRACustomBitmap; out AScanlineSize: PtrInt): Pointer; overload; override; 61 61 procedure SaveBitmapToStream(AAlgorithm: TDitheringAlgorithm; 62 62 ABitmap: TBGRACustomBitmap; AStream: TStream; AFormat: TBGRAImageFormat); override; … … 228 228 implementation 229 229 230 uses BGRADithering, FPimage, FPWriteBMP, BGRAWritePNG ;230 uses BGRADithering, FPimage, FPWriteBMP, BGRAWritePNG, math; 231 231 232 232 const MedianMinPercentage = 0.2; … … 1131 1131 begin 1132 1132 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)]; 1137 1137 FAverageColor := FLeaf.AverageColorOrMainColor; 1138 1138 extremumColor := FAverageColor; -
GraphicTest/Packages/bgrabitmap/bgracompressablebitmap.pas
r494 r521 47 47 public 48 48 CompressionLevel: Tcompressionlevel; 49 constructor Create; 50 constructor Create(Source: TBGRABitmap); 49 constructor Create; overload; 50 constructor Create(Source: TBGRABitmap); overload; 51 51 function GetBitmap: TBGRABitmap; 52 52 53 53 //call Compress as many times as necessary 54 54 //when it returns false, it means that … … 69 69 implementation 70 70 71 uses BGRAUTF8; 72 71 73 // size of each chunk treated by Compress function 72 74 const maxPartSize = 524288; … … 153 155 154 156 comp := Tcompressionstream.Create(CompressionLevel,FCompressedDataArray[high(FCompressedDataArray)],true); 155 comp.write(partSize,sizeof(partSize));157 LEWriteLongint(comp, partSize); 156 158 comp.CopyFrom(FUncompressedData,partSize); 157 159 comp.Free; … … 163 165 end; 164 166 165 {$hints off}166 function WinReadLongint(Stream: TStream): longint;167 begin168 stream.Read(Result, sizeof(Result));169 Result := LEtoN(Result);170 end;171 {$hints on}172 173 procedure WinWriteLongint(Stream: TStream; AValue: LongInt);174 begin175 AValue := NtoLE(AValue);176 stream.Write(AValue, sizeof(AValue));177 end;178 179 167 procedure TBGRACompressableBitmap.WriteToStream(AStream: TStream); 180 168 var i:integer; … … 182 170 repeat 183 171 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)); 187 175 AStream.Write(FCaption[1],length(FCaption)); 188 176 if (FWidth=0) or (FHeight = 0) then exit; 189 177 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)); 197 185 for i := 0 to high(FCompressedDataArray) do 198 186 begin 199 WinWriteLongint(AStream,FCompressedDataArray[i].Size);187 LEWriteLongint(AStream,FCompressedDataArray[i].Size); 200 188 FCompressedDataArray[i].Position := 0; 201 189 AStream.CopyFrom(FCompressedDataArray[i],FCompressedDataArray[i].Size); … … 207 195 begin 208 196 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)); 212 200 AStream.Read(FCaption[1],length(FCaption)); 213 201 if (FWidth=0) or (FHeight = 0) then … … 217 205 end; 218 206 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)); 226 214 for i := 0 to high(FCompressedDataArray) do 227 215 begin 228 size := WinReadLongint(AStream);216 size := LEReadLongint(AStream); 229 217 FCompressedDataArray[i] := TMemoryStream.Create; 230 218 FCompressedDataArray[i].CopyFrom(AStream,size); … … 246 234 FCompressedDataArray[i].Position := 0; 247 235 decomp := Tdecompressionstream.Create(FCompressedDataArray[i],true); 248 {$hints off} 249 decomp.read(partSize,sizeof(partSize)); 250 {$hints on} 236 partSize := LEReadLongint(decomp); 251 237 FUncompressedData.CopyFrom(decomp,partSize); 252 238 decomp.Free; -
GraphicTest/Packages/bgrabitmap/bgracustombitmap.inc
r494 r521 37 37 {** Returns the corresponding OpenGL texture. The value is ''nil'' if no texture is associated. **} 38 38 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; 41 41 function ProvidesScanline(ARect: TRect): boolean; 42 42 function GetScanlineAt(X,Y: integer): PBGRAPixel; … … 66 66 function IsScanPutPixelsDefined: boolean; virtual; 67 67 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; 70 70 function ProvidesScanline({%H-}ARect: TRect): boolean; virtual; 71 71 function GetScanlineAt({%H-}X,{%H-}Y: integer): PBGRAPixel; virtual; … … 92 92 procedure SetFontAntialias(const AValue: Boolean); 93 93 protected 94 { accessors to properies } 94 FXorMask: TBGRACustomBitmap; 95 96 { accessors to properies } 95 97 function GetArrowEndRepeat: integer; virtual; abstract; 96 98 function GetArrowStartRepeat: integer; virtual; abstract; … … 114 116 function GetNbPixels: integer; virtual; abstract; 115 117 function CheckEmpty: boolean; virtual; abstract; 118 function CheckIsZero: boolean; virtual; abstract; 116 119 function GetHasTransparentPixels: boolean; virtual; abstract; 120 function GetHasSemiTransparentPixels: boolean; virtual; abstract; 117 121 function GetAverageColor: TColor; virtual; abstract; 118 122 function GetAveragePixel: TBGRAPixel; virtual; abstract; … … 133 137 function GetFontFullHeight: integer; virtual; abstract; 134 138 procedure SetFontFullHeight(AHeight: integer); virtual; abstract; 139 function GetFontVerticalAnchorOffset: single; virtual; abstract; 135 140 function GetPenJoinStyle: TPenJoinStyle; virtual; abstract; 136 141 procedure SetPenJoinStyle(const AValue: TPenJoinStyle); virtual; abstract; … … 153 158 154 159 function GetTextureGL: IUnknown; virtual; 160 function GetFontRightToLeftFor(AText: string): boolean; 155 161 156 162 public … … 175 181 ScanOffset: TPoint; 176 182 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 177 195 {** Width of the image in pixels } 178 196 property Width: integer Read GetWidth; … … 208 226 {** Returns True if the bitmap only contains transparent pixels or has a size of zero } 209 227 property Empty: boolean Read CheckEmpty; 228 property IsZero: boolean Read CheckIsZero; 210 229 211 230 {** Returns True if there are transparent or semitransparent pixels, 212 231 and so if the image would be stored with an alpha channel } 213 232 property HasTransparentPixels: boolean Read GetHasTransparentPixels; 233 property HasSemiTransparentPixels: boolean Read GetHasSemiTransparentPixels; 214 234 215 235 {** Average color of the image } … … 289 309 FontVerticalAnchor: TFontVerticalAnchor; 290 310 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 291 317 {** Specifies the height of the font in pixels without taking into account 292 318 additional line spacing. A negative value means that it is the … … 300 326 {** Simplified property to specify the quality (see ''FontQuality'') } 301 327 property FontAntialias: Boolean read GetFontAntialias write SetFontAntialias; 328 329 property FontVerticalAnchorOffset: single read GetFontVerticalAnchorOffset; 330 302 331 {** Returns measurement for the current font in pixels } 303 332 property FontPixelMetric: TFontPixelMetric read GetFontPixelMetric; … … 317 346 318 347 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; 335 364 336 365 //there are UTF8 functions that are different from standard function as those … … 338 367 {==== Load and save files ====} 339 368 {** 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; 342 371 {** 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; 345 374 {** 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; 347 376 {** 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; 349 378 {** 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; 352 381 {** 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; 355 390 356 391 {** 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; 358 393 {** 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; 360 395 {** 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; 362 397 {** 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; 364 399 365 400 {** Save image to a stream with the specified image writer }{inherited … … 374 409 375 410 {** 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; 377 412 {** 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; 379 414 {** Fills the content with a screenshot of the primary monitor } 380 415 procedure TakeScreenshotOfPrimaryMonitor; virtual; abstract; … … 385 420 386 421 {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; 391 426 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; 393 428 procedure FastBlendPixel(x, y: int32or64; c: TBGRAPixel); virtual; abstract; 394 429 procedure ErasePixel(x, y: int32or64; alpha: byte); virtual; abstract; 395 430 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; 397 432 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; 404 439 405 440 {Line primitives} 406 441 procedure SetHorizLine(x, y, x2: int32or64; c: TBGRAPixel); virtual; abstract; 407 442 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; 410 445 procedure DrawHorizLine(x, y, x2: int32or64; texture: IBGRAScanner); overload; 411 446 procedure FastBlendHorizLine(x, y, x2: int32or64; c: TBGRAPixel); virtual; abstract; 412 447 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; 414 449 procedure DrawHorizLineDiff(x, y, x2: int32or64; c, compare: TBGRAPixel; maxDiff: byte); virtual; abstract; 415 450 procedure AlphaHorizLine(x, y, x2: int32or64; alpha: byte); virtual; abstract; … … 423 458 424 459 {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; 438 473 439 474 procedure ArrowStartAsNone; virtual; abstract; … … 448 483 449 484 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; 457 492 458 493 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; 468 503 procedure DrawPolygon(const points: array of TPoint; c: TBGRAPixel; ADrawMode: TDrawMode=dmDrawWithTransparency); 469 504 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; 473 509 474 510 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; 478 514 procedure ErasePolyLine(const points: array of TPoint; alpha: byte; DrawLastPixel: boolean); 479 515 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; 481 517 procedure ErasePolygonOutline(const points: array of TPoint; alpha: byte); 482 518 procedure ErasePolygonOutlineAntialias(const points: array of TPoint; alpha: byte); 483 519 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; 507 543 procedure FillQuadAffineMapping(Orig,HAxis,VAxis: TPointF; AImage: TBGRACustomBitmap; APixelCenteredCoordinates: boolean = true; ADrawMode: TDrawMode = dmDrawWithTransparency; AOpacity: byte = 255); virtual; abstract; 508 544 procedure FillQuadAffineMappingAntialias(Orig,HAxis,VAxis: TPointF; AImage: TBGRACustomBitmap; APixelCenteredCoordinates: boolean = true; AOpacity: byte = 255); virtual; abstract; 509 545 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; 528 564 procedure EraseShapeAntialias(shape: TBGRACustomFillInfo; alpha: byte); virtual; abstract; 529 565 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; 537 582 538 583 procedure Arc(cx,cy,rx,ry: single; const StartPoint,EndPoint: TPointF; AColor: TBGRAPixel; w: single; ADrawChord: boolean; AFillColor: TBGRAPixel); overload; … … 554 599 procedure FillPieInRect(const ARect: TRect; StartAngleRad,EndAngleRad: Single; texture: IBGRAScanner); overload; 555 600 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; 565 610 procedure RectangleWithin(x1,y1,x2,y2: single; ABorderColor: TBGRAPixel; w: single; AFillColor: TBGRAPixel; APixelCenteredCoordinates: boolean = true); overload; 566 611 procedure RectangleWithin(r: TRect; ABorderColor: TBGRAPixel; w: single; AFillColor: TBGRAPixel); overload; 567 612 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; 577 623 procedure EraseRoundRectAntialias(x,y,x2,y2,rx,ry: single; alpha: byte; options: TRoundRectangleOptions = []; pixelCenteredCoordinates: boolean = true); virtual; abstract; 578 624 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; 597 646 procedure EraseRectAntialias(x, y, x2, y2: single; alpha: byte; pixelCenteredCoordinates: boolean = true); virtual; abstract; 598 647 procedure AlphaFillRect(x, y, x2, y2: integer; alpha: byte); virtual; abstract; 599 648 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; 611 668 612 669 { Draw the UTF8 encoded string, (x,y) being the top-left corner. The color c or texture is used to fill the text. 613 670 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; 617 679 618 680 { Draw the UTF8 encoded string in the rectangle ARect. Text is wrapped if necessary. 619 681 The position depends on the specified horizontal alignment halign and vertical alignement valign. 620 682 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; 623 685 624 686 {Spline} 625 687 function ComputeClosedSpline(const APoints: array of TPointF; AStyle: TSplineStyle): ArrayOfTPointF; virtual; abstract; 626 688 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; 634 696 function ComputeWidePolygon(const points: array of TPointF; w: single): ArrayOfTPointF; virtual; abstract; 635 697 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; 640 704 function ComputeArc65536(x,y,rx,ry: single; start65536,end65536: word; quality: single = 1): ArrayOfTPointF; virtual; abstract; 641 705 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; 644 708 function ComputePie65536(x,y,rx,ry: single; start65536,end65536: word; quality: single = 1): ArrayOfTPointF; virtual; abstract; 645 709 function ComputePieRad(x,y,rx,ry: single; startRad,endRad: single; quality: single = 1): ArrayOfTPointF; virtual; abstract; … … 648 712 procedure FillTransparent; virtual; 649 713 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; 657 721 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; 672 737 procedure FloodFill(X, Y: integer; Color: TBGRAPixel; 673 738 mode: TFloodfillMode; Tolerance: byte = 0); virtual; … … 677 742 gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode; 678 743 gammaColorCorrection: boolean = True; Sinus: Boolean=False; 679 ditherAlgo: TDitheringAlgorithm = daNearestNeighbor); virtual; abstract; overload;744 ditherAlgo: TDitheringAlgorithm = daNearestNeighbor); overload; virtual; abstract; 680 745 procedure GradientFill(x, y, x2, y2: integer; gradient: TBGRACustomGradient; 681 746 gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode; 682 747 Sinus: Boolean=False; 683 ditherAlgo: TDitheringAlgorithm = daNearestNeighbor); virtual; abstract; overload;748 ditherAlgo: TDitheringAlgorithm = daNearestNeighbor); overload; virtual; abstract; 684 749 function CreateBrushTexture(ABrushStyle: TBrushStyle; APatternColor, ABackgroundColor: TBGRAPixel; 685 750 AWidth: integer = 8; AHeight: integer = 8; APenWidth: single = 1): TBGRACustomBitmap; virtual; abstract; … … 688 753 procedure DataDrawTransparent(ACanvas: TCanvas; Rect: TRect; 689 754 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; 691 756 ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); virtual; abstract; 692 757 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; 695 760 procedure DrawPart(ARect: TRect; ACanvas: TCanvas; x, y: integer; Opaque: boolean); virtual; 696 761 function GetPart(ARect: TRect): TBGRACustomBitmap; virtual; abstract; … … 700 765 701 766 {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; 705 771 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); 706 773 procedure PutImageSubpixel(x, y: single; Source: TBGRACustomBitmap; AOpacity: byte = 255); 707 774 procedure PutImagePart(x,y: integer; Source: TBGRACustomBitmap; SourceRect: TRect; mode: TDrawMode; AOpacity: byte = 255); … … 712 779 procedure PutImageAffine(AMatrix: TAffineMatrix; Source: TBGRACustomBitmap; AOpacity: Byte=255; ACorrectBlur: Boolean = false); overload; 713 780 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; 715 783 procedure PutImageAffine(AMatrix: TAffineMatrix; Source: TBGRACustomBitmap; AOutputBounds: TRect; AOpacity: Byte=255; ACorrectBlur: Boolean = false); overload; 716 784 function GetImageAffineBounds(Origin,HAxis,VAxis: TPointF; Source: TBGRACustomBitmap): TRect; overload; 717 785 function GetImageAffineBounds(Origin,HAxis,VAxis: TPointF; ASourceWidth, ASourceHeight: integer; const ASourceBounds: TRect; AClipOutput: boolean = true): TRect; overload; 718 786 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; 721 789 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; 722 790 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; … … 729 797 procedure BlendImageOver(x, y: integer; Source: TBGRACustomBitmap; operation: TBlendOperation; AOpacity: byte = 255; 730 798 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; 734 802 function Resample(newWidth, newHeight: integer; 735 803 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; 740 808 function RotateCW: TBGRACustomBitmap; virtual; abstract; 741 809 function RotateCCW: TBGRACustomBitmap; virtual; abstract; … … 744 812 procedure LinearNegative; virtual; abstract; 745 813 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; 750 818 procedure ConvertToLinearRGB; virtual; abstract; 751 819 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; 754 823 procedure GrayscaleToAlpha; virtual; abstract; 755 824 procedure AlphaToGrayscale; virtual; abstract; 756 825 procedure ApplyMask(mask: TBGRACustomBitmap); overload; 757 826 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; 763 833 function GetDifferenceBounds(ABitmap: TBGRACustomBitmap): TRect; virtual; abstract; 764 834 function MakeBitmapCopy(BackgroundColor: TColor): TBitmap; virtual; abstract; … … 768 838 function FilterMedian(Option: TMedianOption): TBGRACustomBitmap; virtual; abstract; 769 839 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; 772 842 function FilterContour: TBGRACustomBitmap; virtual; abstract; 773 843 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; 791 861 function FilterRotate(origin: TPointF; angle: single; correctBlur: boolean = false): TBGRACustomBitmap; virtual; abstract; 792 862 function FilterAffine(AMatrix: TAffineMatrix; correctBlur: boolean = false): TBGRACustomBitmap; virtual; abstract; 793 863 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; 796 866 function FilterCylinder: TBGRACustomBitmap; virtual; abstract; 797 867 function FilterPlane: TBGRACustomBitmap; virtual; abstract; … … 1055 1125 end; 1056 1126 1127 function TBGRACustomBitmap.GetFontRightToLeftFor(AText: string): boolean; 1128 begin 1129 case FontBidiMode of 1130 fbmAuto: result := IsRightToLeftUTF8(AText); 1131 fbmRightToLeft: result := true; 1132 else 1133 {fbmLeftToRight} 1134 result := false; 1135 end; 1136 end; 1137 1057 1138 procedure TBGRACustomBitmap.InternalArc(cx, cy, rx, ry: single; 1058 1139 const StartPoint, EndPoint: TPointF; ABorderColor: TBGRAPixel; w: single; AFillColor: TBGRAPixel; AOptions: TArcOptions; … … 1297 1378 end; 1298 1379 1380 procedure TBGRACustomBitmap.LoadFromResource(AFilename: string); 1381 begin 1382 LoadFromResource(AFilename, [loKeepTransparentRGB]); 1383 end; 1384 1385 procedure TBGRACustomBitmap.LoadFromResource(AFilename: string; 1386 Handler: TFPCustomImageReader); 1387 begin 1388 LoadFromResource(AFilename, Handler, [loKeepTransparentRGB]); 1389 end; 1390 1391 procedure TBGRACustomBitmap.LoadFromResource(AFilename: string; 1392 Handler: TFPCustomImageReader; AOptions: TBGRALoadingOptions); 1393 var 1394 stream: TStream; 1395 begin 1396 stream := BGRAResource.GetResourceStream(AFilename); 1397 try 1398 LoadFromStream(stream,Handler,AOptions); 1399 finally 1400 stream.Free; 1401 end; 1402 end; 1403 1299 1404 { Look for a pixel considering the bitmap is repeated in both directions } 1300 1405 function TBGRACustomBitmap.GetPixelCycle(x, y: int32or64): TBGRAPixel; … … 1338 1443 procedure TBGRACustomBitmap.DrawPolyLine(const points: array of TPoint; 1339 1444 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); 1445 var i,start: integer; 1446 begin 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; 1349 1458 end; 1350 1459 … … 1352 1461 procedure TBGRACustomBitmap.DrawPolyLineAntialias(const points: array of TPoint; 1353 1462 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)); 1463 var i,start: integer; 1464 begin 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; 1363 1476 end; 1364 1477 1365 1478 procedure TBGRACustomBitmap.DrawPolyLineAntialias(const points: array of TPoint; c1, 1366 1479 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); 1480 var i,start,dashPos: integer; 1481 begin 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; 1378 1498 end; 1379 1499 1380 1500 procedure TBGRACustomBitmap.DrawPolygon(const points: array of TPoint; 1381 1501 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; 1502 var i,start: integer; 1503 begin 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; 1394 1516 end; 1395 1517 1396 1518 procedure TBGRACustomBitmap.DrawPolygonAntialias(const points: array of TPoint; 1397 1519 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; 1520 var i,start: integer; 1521 begin 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; 1534 end; 1535 1536 procedure TBGRACustomBitmap.DrawPolygonAntialias(const points: array of TPoint; 1537 c1, c2: TBGRAPixel; dashLen: integer); 1538 var i,start,dashPos: integer; 1539 begin 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; 1410 1557 end; 1411 1558 1412 1559 procedure TBGRACustomBitmap.ErasePolyLine(const points: array of TPoint; alpha: byte; 1413 1560 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)); 1561 var i,start: integer; 1562 begin 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; 1423 1574 end; 1424 1575 1425 1576 procedure TBGRACustomBitmap.ErasePolyLineAntialias( 1426 1577 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)); 1578 var i,start: integer; 1579 begin 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; 1436 1591 end; 1437 1592 1438 1593 procedure TBGRACustomBitmap.ErasePolygonOutline(const points: array of TPoint; 1439 1594 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; 1595 var i,start: integer; 1596 begin 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; 1452 1609 end; 1453 1610 1454 1611 procedure TBGRACustomBitmap.ErasePolygonOutlineAntialias( 1455 1612 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; 1613 var i,start: integer; 1614 begin 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; 1468 1627 end; 1469 1628 … … 1639 1798 end; 1640 1799 1800 procedure TBGRACustomBitmap.FillEllipseInRect(r: TRect; 1801 FillTexture: IBGRAScanner; ADrawMode: TDrawMode); 1802 begin 1803 FillRoundRect(r.left,r.top,r.right,r.bottom,abs(r.right-r.left),abs(r.bottom-r.top),FillTexture,ADrawMode); 1804 end; 1805 1641 1806 procedure TBGRACustomBitmap.FillRect(r: TRect; c: TColor); 1642 1807 begin … … 1689 1854 begin 1690 1855 FillRect(x,y,x2,y2,texture,mode,Point(0,0),ditheringAlgorithm); 1856 end; 1857 1858 procedure TBGRACustomBitmap.FillRectAntialias(ARect: TRectF; c: TBGRAPixel; 1859 pixelCenteredCoordinates: boolean); 1860 begin 1861 FillRectAntialias(ARect.Left,ARect.Top,ARect.Right,ARect.Bottom, c, pixelCenteredCoordinates); 1862 end; 1863 1864 procedure TBGRACustomBitmap.FillRectAntialias(ARect: TRectF; 1865 texture: IBGRAScanner; pixelCenteredCoordinates: boolean); 1866 begin 1867 FillRectAntialias(ARect.Left,ARect.Top,ARect.Right,ARect.Bottom, texture, pixelCenteredCoordinates); 1691 1868 end; 1692 1869 … … 1719 1896 end; 1720 1897 1898 procedure TBGRACustomBitmap.TextMultiline(x, y: single; sUTF8: string; 1899 c: TBGRAPixel; AAlign: TBidiTextAlignment; AVertAlign: TTextLayout; AParagraphSpacing: single); 1900 begin 1901 TextMultiline(x, y, EmptySingle, sUTF8, c, AAlign, AVertAlign, AParagraphSpacing); 1902 end; 1903 1904 procedure TBGRACustomBitmap.TextMultiline(x, y: single; sUTF8: string; 1905 ATexture: IBGRAScanner; AAlign: TBidiTextAlignment; AVertAlign: TTextLayout; AParagraphSpacing: single); 1906 begin 1907 TextMultiline(x, y, EmptySingle, sUTF8, ATexture, AAlign, AVertAlign, AParagraphSpacing); 1908 end; 1909 1910 procedure TBGRACustomBitmap.TextOut(x, y: single; sUTF8: string; c: TBGRAPixel; 1911 align: TAlignment); 1912 begin 1913 TextOut(x,y,sUTF8,c,align, GetFontRightToLeftFor(sUTF8)); 1914 end; 1915 1916 procedure TBGRACustomBitmap.TextOut(x, y: single; sUTF8: string; 1917 texture: IBGRAScanner; align: TAlignment); 1918 begin 1919 TextOut(x,y,sUTF8,texture,align, GetFontRightToLeftFor(sUTF8)); 1920 end; 1921 1721 1922 { Draw the UTF8 encoded string, (x,y) being the top-left corner. The color c is used to fill the text. 1722 1923 The value of FontOrientation is taken into account, so that the text may be rotated. } … … 1726 1927 end; 1727 1928 1929 procedure TBGRACustomBitmap.TextOut(x, y: single; sUTF8: string; c: TBGRAPixel; 1930 ARightToLeft: boolean); 1931 begin 1932 TextOut(x, y, sUTF8, c, taLeftJustify, ARightToLeft); 1933 end; 1934 1728 1935 { Draw the UTF8 encoded string, (x,y) being the top-left corner. The color c is used to fill the text. 1729 1936 The value of FontOrientation is taken into account, so that the text may be rotated. } … … 1731 1938 begin 1732 1939 TextOut(x, y, sUTF8, ColorToBGRA(c)); 1940 end; 1941 1942 procedure TBGRACustomBitmap.TextOut(x, y: single; sUTF8: string; c: TColor; 1943 ARightToLeft: boolean); 1944 begin 1945 TextOut(x, y, sUTF8, ColorToBGRA(c), ARightToLeft); 1733 1946 end; 1734 1947 … … 1739 1952 begin 1740 1953 TextOut(x, y, sUTF8, texture, taLeftJustify); 1954 end; 1955 1956 procedure TBGRACustomBitmap.TextOut(x, y: single; sUTF8: string; 1957 texture: IBGRAScanner; ARightToLeft: boolean); 1958 begin 1959 TextOut(x, y, sUTF8, texture, taLeftJustify, ARightToLeft); 1741 1960 end; 1742 1961 … … 1757 1976 style.ShowPrefix := false; 1758 1977 style.Clipping := false; 1978 style.RightToLeft := GetFontRightToLeftFor(sUTF8); 1979 if FontBidiMode = fbmAuto then sUTF8 := AddParagraphBidiUTF8(sUTF8, style.RightToLeft); 1759 1980 TextRect(ARect,ARect.Left,ARect.Top,sUTF8,style,c); 1760 1981 end; … … 1776 1997 style.ShowPrefix := false; 1777 1998 style.Clipping := false; 1999 style.RightToLeft := GetFontRightToLeftFor(sUTF8); 2000 if FontBidiMode = fbmAuto then sUTF8 := AddParagraphBidiUTF8(sUTF8, style.RightToLeft); 1778 2001 TextRect(ARect,ARect.Left,ARect.Top,sUTF8,style,texture); 1779 2002 end; … … 1835 2058 partial: TBGRACustomBitmap; 1836 2059 begin 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; 2071 end; 2072 2073 procedure TBGRACustomBitmap.PutImage(x, y: integer; Source: TBitmap; 2074 mode: TDrawMode; AOpacity: byte); 2075 var bgra: TBGRACustomBitmap; 2076 begin 2077 bgra := BGRABitmapFactory.create(Source); 2078 PutImage(x,y, bgra, mode, AOpacity); 2079 bgra.free; 2080 end; 2081 2082 procedure TBGRACustomBitmap.StretchPutImageProportionally(ARect: TRect; 2083 AHorizAlign: TAlignment; AVertAlign: TTextLayout; Source: TBGRACustomBitmap; 2084 mode: TDrawMode; AOpacity: byte); 2085 var 2086 ratio: single; 2087 imgRect: TRect; 2088 begin 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); 1843 2103 end; 1844 2104 … … 1902 2162 Source: TBGRACustomBitmap; AOutputBounds: TRect; 1903 2163 AResampleFilter: TResampleFilter; AMode: TDrawMode; AOpacity: Byte); 1904 var m: TAffineMatrix; 2164 var m: TAffineMatrix; w,h: integer; 1905 2165 begin 1906 2166 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; 1909 2171 PutImageAffine(m,Source,AOutputBounds,AResampleFilter,AMode,AOpacity); 1910 2172 end; … … 1932 2194 Source: TBGRACustomBitmap; AResampleFilter: TResampleFilter; AOpacity: Byte); 1933 2195 begin 2196 PutImageAffine(AMatrix, Source, AResampleFilter, dmDrawWithTransparency, AOpacity); 2197 end; 2198 2199 procedure TBGRACustomBitmap.PutImageAffine(AMatrix: TAffineMatrix; 2200 Source: TBGRACustomBitmap; AResampleFilter: TResampleFilter; 2201 AMode: TDrawMode; AOpacity: Byte); 2202 begin 1934 2203 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); 1936 2206 end; 1937 2207 … … 1964 2234 else 1965 2235 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) 1966 2238 m[1,1] := (HAxis.x-Origin.x)/(ASourceWidth-1); m[1,2] := (VAxis.x-Origin.x)/(ASourceHeight-1); m[1,3] := Origin.x; 1967 2239 m[2,1] := (HAxis.y-Origin.y)/(ASourceWidth-1); m[2,2] := (VAxis.y-Origin.y)/(ASourceHeight-1); m[2,3] := Origin.y; … … 2047 2319 sina := -sin(-angle*Pi/180); 2048 2320 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); 2051 2325 end; 2052 2326 -
GraphicTest/Packages/bgrabitmap/bgracustomtextfx.pas
r494 r521 33 33 FOffset: TPoint; 34 34 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; 37 37 function InternalDrawShaded(ADest: TBGRACustomBitmap; X,Y: integer; Shader: TCustomPhongShading; Altitude: integer; AColor: TBGRAPixel; ATexture: IBGRAScanner; ARounded: Boolean): TRect; 38 38 public … … 41 41 procedure ApplyVerticalCylinder; 42 42 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; 61 61 destructor Destroy; override; 62 62 property TextMask: TBGRACustomBitmap read FTextMask; … … 417 417 else 418 418 FTextMask := AMask; 419 FShadowQuality:= rbFast; 419 420 end; 420 421 -
GraphicTest/Packages/bgrabitmap/bgradefaultbitmap.pas
r494 r521 34 34 uses 35 35 SysUtils, Classes, Types, FPImage, BGRAGraphics, BGRABitmapTypes, FPImgCanv, 36 BGRACanvas, BGRACanvas2D, BGRAArrow, BGRAPen, BGRATransform ;36 BGRACanvas, BGRACanvas2D, BGRAArrow, BGRAPen, BGRATransform, BGRATextBidi; 37 37 38 38 type … … 59 59 gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode; 60 60 gammaColorCorrection: boolean = True; Sinus: Boolean=False; 61 ditherAlgo: TDitheringAlgorithm = daFloydSteinberg); 61 ditherAlgo: TDitheringAlgorithm = daFloydSteinberg); overload; 62 62 procedure GradientFillDithered(x, y, x2, y2: integer; gradient: TBGRACustomGradient; 63 63 gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode; 64 64 Sinus: Boolean=False; 65 ditherAlgo: TDitheringAlgorithm = daFloydSteinberg); 65 ditherAlgo: TDitheringAlgorithm = daFloydSteinberg); overload; 66 66 protected 67 67 FRefCount: integer; //reference counter (not related to interface reference counter) … … 152 152 function SimpleStretch(NewWidth, NewHeight: integer): TBGRACustomBitmap; 153 153 function CheckEmpty: boolean; override; 154 function CheckIsZero: boolean; override; 154 155 function GetHasTransparentPixels: boolean; override; 156 function GetHasSemiTransparentPixels: boolean; override; 155 157 function GetAverageColor: TColor; override; 156 158 function GetAveragePixel: TBGRAPixel; override; … … 190 192 procedure SetFontRenderer(AValue: TBGRACustomFontRenderer); override; 191 193 function CreateDefaultFontRenderer: TBGRACustomFontRenderer; virtual; abstract; 192 function GetFont AnchorVerticalOffset: 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; 195 197 196 198 function GetClipRect: TRect; override; … … 201 203 function GetArrow: TBGRAArrow; 202 204 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); 203 206 204 207 function CheckClippedRectBounds(var x,y,x2,y2: integer): boolean; … … 227 230 function GetUnique: TBGRACustomBitmap; 228 231 232 { ** Allocate xor mask } 233 procedure NeedXorMask; override; 234 235 { ** Free reference to xor mask } 236 procedure DiscardXorMask; override; 237 229 238 {==== Constructors ====} 230 239 231 240 {------------------------- Constructors from TFPCustomImage----------------} 232 241 {** Creates a new bitmap, initialize properties and bitmap data } 233 constructor Create(AWidth, AHeight: integer); over ride;242 constructor Create(AWidth, AHeight: integer); overload; override; 234 243 {** Can only be called with an existing instance of ''TBGRABitmap''. 235 244 Sets the dimensions of an existing ''TBGRABitmap'' instance. } … … 239 248 {** Creates an image of width and height equal to zero. In this case, 240 249 ''Data'' = '''nil''' } 241 constructor Create; over ride;250 constructor Create; overload; override; 242 251 {** Creates an image by copying the content of a ''TFPCustomImage'' } 243 constructor Create(AFPImage: TFPCustomImage); over ride;252 constructor Create(AFPImage: TFPCustomImage); overload; override; 244 253 {** Creates an image by copying the content of a ''TBitmap'' } 245 constructor Create(ABitmap: TBitmap; AUseTransparent: boolean = true); over ride;254 constructor Create(ABitmap: TBitmap; AUseTransparent: boolean = true); overload; override; 246 255 {** Creates an image of dimensions ''AWidth'' and ''AHeight'' and fills it with the opaque color ''Color'' } 247 constructor Create(AWidth, AHeight: integer; Color: TColor); over ride;256 constructor Create(AWidth, AHeight: integer; Color: TColor); overload; override; 248 257 {** Creates an image of dimensions ''AWidth'' and ''AHeight'' and fills it with ''Color'' } 249 constructor Create(AWidth, AHeight: integer; Color: TBGRAPixel); over ride;258 constructor Create(AWidth, AHeight: integer; Color: TBGRAPixel); overload; override; 250 259 251 260 {** Creates an image by loading its content from the file ''AFilename''. 252 261 The encoding of the string is the default one for the operating system. 253 262 It is recommended to use the next constructor and UTF8 encoding } 254 constructor Create(AFilename: string); over ride;263 constructor Create(AFilename: string); overload; override; 255 264 256 265 {** Creates an image by loading its content from the file ''AFilename''. 257 266 The boolean ''AIsUtf8Filename'' specifies if UTF8 encoding is assumed 258 267 for the filename } 259 constructor Create(AFilename: string; AIsUtf8: boolean); over ride;260 constructor Create(AFilename: string; AIsUtf8: boolean; AOptions: TBGRALoadingOptions); over ride;268 constructor Create(AFilename: string; AIsUtf8: boolean); overload; override; 269 constructor Create(AFilename: string; AIsUtf8: boolean; AOptions: TBGRALoadingOptions); overload; override; 261 270 262 271 {** Creates an image by loading its content from the stream ''AStream'' } 263 constructor Create(AStream: TStream); over ride;272 constructor Create(AStream: TStream); overload; override; 264 273 {** Free the object and all its resources } 265 274 destructor Destroy; override; … … 269 278 Creates a new instance with dimensions ''AWidth'' and ''AHeight'', 270 279 containing transparent pixels. } 271 function NewBitmap(AWidth, AHeight: integer): TBGRACustomBitmap; over ride;280 function NewBitmap(AWidth, AHeight: integer): TBGRACustomBitmap; overload; override; 272 281 273 282 {** Can only be called from an existing instance of ''TBGRABitmap''. 274 283 Creates a new instance with dimensions ''AWidth'' and ''AHeight'', 275 284 and fills it with Color } 276 function NewBitmap(AWidth, AHeight: integer; Color: TBGRAPixel): TBGRACustomBitmap; over ride;285 function NewBitmap(AWidth, AHeight: integer; Color: TBGRAPixel): TBGRACustomBitmap; overload; override; 277 286 278 287 {** Can only be called from an existing instance of ''TBGRABitmap''. … … 280 289 from the file ''Filename''. The encoding of the string 281 290 is the default one for the operating system } 282 function NewBitmap(Filename: string): TBGRACustomBitmap; over ride;291 function NewBitmap(Filename: string): TBGRACustomBitmap; overload; override; 283 292 284 293 {** Can only be called from an existing instance of ''TBGRABitmap''. 285 294 Creates a new instance with by loading its content 286 295 from the file ''Filename'' } 287 function NewBitmap(Filename: string; AIsUtf8: boolean): TBGRACustomBitmap; over ride;288 function NewBitmap(Filename: string; AIsUtf8: boolean; AOptions: TBGRALoadingOptions): TBGRACustomBitmap; over ride;296 function NewBitmap(Filename: string; AIsUtf8: boolean): TBGRACustomBitmap; overload; override; 297 function NewBitmap(Filename: string; AIsUtf8: boolean; AOptions: TBGRALoadingOptions): TBGRACustomBitmap; overload; override; 289 298 290 299 {** Can only be called from an existing instance of ''TBGRABitmap''. 291 300 Creates an image by copying the content of a ''TFPCustomImage'' } 292 function NewBitmap(AFPImage: TFPCustomImage): TBGRACustomBitmap; over ride;301 function NewBitmap(AFPImage: TFPCustomImage): TBGRACustomBitmap; overload; override; 293 302 294 303 {** 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; 296 308 297 309 {** Assign the content of the specified ''Source''. It can be a ''TBGRACustomBitmap'' or 298 310 a ''TFPCustomImage'' } 299 procedure Assign(Source: TPersistent); over ride;311 procedure Assign(Source: TPersistent); overload; override; 300 312 procedure Assign(Source: TBitmap; AUseTransparent: boolean); overload; 301 313 {** Stores the image in the stream without compression nor header } … … 322 334 {** Sets the pixel by replacing the content at (''x'',''y'') with the specified color. 323 335 Alpha value is set to 255 (opaque) } 324 procedure SetPixel(x, y: int32or64; c: TColor); over ride;336 procedure SetPixel(x, y: int32or64; c: TColor); overload; override; 325 337 {** Sets the pixel at (''x'',''y'') with the specified content } 326 procedure SetPixel(x, y: int32or64; c: TBGRAPixel); over ride;338 procedure SetPixel(x, y: int32or64; c: TBGRAPixel); overload; override; 327 339 {** Applies a logical '''xor''' to the content of the pixel with the specified value. 328 340 This includes the alpha channel, so if you want to preserve the opacity, provide … … 371 383 * ''AResampleFilter'' specifies how pixels must be interpolated. Accepted 372 384 values are ''rfBox'', ''rfLinear'', ''rfHalfCosine'' and ''rfCosine'' } 373 function GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; over ride;385 function GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; overload; override; 374 386 {** Similar to previous ''GetPixel'' function, but the fractional part of 375 387 the coordinate is supplied with a number from 0 to 255. The actual 376 388 coordinate is (''x'' + ''fracX256''/256, ''y'' + ''fracY256''/256) } 377 function GetPixelCycle256(x, y, fracX256,fracY256: int32or64; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; over ride;389 function GetPixelCycle256(x, y, fracX256,fracY256: int32or64; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; overload; override; 378 390 {** Computes the value of the pixel at a floating point coordiante 379 391 by interpolating the values of the pixels around it. ''repeatX'' and … … 381 393 * ''AResampleFilter'' specifies how pixels must be interpolated. Accepted 382 394 values are ''rfBox'', ''rfLinear'', ''rfHalfCosine'' and ''rfCosine'' } 383 function GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter; repeatX: boolean; repeatY: boolean): TBGRAPixel; over ride;395 function GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter; repeatX: boolean; repeatY: boolean): TBGRAPixel; overload; override; 384 396 {** Similar to previous ''GetPixel'' function, but the fractional part of 385 397 the coordinate is supplied with a number from 0 to 255. The actual 386 398 coordinate is (''x'' + ''fracX256''/256, ''y'' + ''fracY256''/256) } 387 function GetPixelCycle256(x, y, fracX256,fracY256: int32or64; AResampleFilter: TResampleFilter; repeatX: boolean; repeatY: boolean): TBGRAPixel; over ride;399 function GetPixelCycle256(x, y, fracX256,fracY256: int32or64; AResampleFilter: TResampleFilter; repeatX: boolean; repeatY: boolean): TBGRAPixel; overload; override; 388 400 389 401 {==== Drawing lines and polylines (integer coordinates) ====} … … 452 464 {** Draws an antialiased line from (x1,y1) to (x2,y2) using an improved version of Bresenham's algorithm 453 465 ''c'' specifies the color. ''DrawLastPixel'' specifies if (x2,y2) must be drawn } 454 procedure DrawLineAntialias(x1, y1, x2, y2: integer; c: TBGRAPixel; DrawLastPixel: boolean); over ride;466 procedure DrawLineAntialias(x1, y1, x2, y2: integer; c: TBGRAPixel; DrawLastPixel: boolean); overload; override; 455 467 {** 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); over ride;468 procedure DrawLineAntialias(x1, y1, x2, y2: integer; c1, c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean); overload; override; 457 469 {** Draws an antialiased line with two colors ''c1'' and ''c2'' as dashes of lenght ''dashLen''. 458 470 ''DashPos'' can be used to specify the start dash position and to retrieve the dash position at the end … … 477 489 478 490 {** 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); over ride;491 procedure DrawLineAntialias(x1, y1, x2, y2: single; c: TBGRAPixel; w: single); overload; override; 480 492 {** Draws a line from (x1,y1) to (x2,y2) using current pen style/cap/join. 481 493 ''texture'' specifies the source color to use when filling the line } 482 procedure DrawLineAntialias(x1, y1, x2, y2: single; texture: IBGRAScanner; w: single); over ride;494 procedure DrawLineAntialias(x1, y1, x2, y2: single; texture: IBGRAScanner; w: single); overload; override; 483 495 {** Draws a line from (x1,y1) to (x2,y2) using current pen style/cap/join. 484 496 ''Closed'' specifies if the end of the line is closed. If it is not closed, 485 497 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); over ride;498 procedure DrawLineAntialias(x1, y1, x2, y2: single; c: TBGRAPixel; w: single; ClosedCap: boolean); overload; override; 487 499 {** 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); over ride;500 procedure DrawLineAntialias(x1, y1, x2, y2: single; texture: IBGRAScanner; w: single; ClosedCap: boolean); overload; override; 489 501 490 502 {** Draws a polyline using current pen style/cap/join } 491 procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single); over ride;503 procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single); overload; override; 492 504 {** Draws a polyline using current pen style/cap/join. 493 505 ''texture'' specifies the source color to use when filling the line } 494 procedure DrawPolyLineAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single); over ride;506 procedure DrawPolyLineAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single); overload; override; 495 507 {** Draws a polyline using current pen style/cap/join. 496 508 ''Closed'' specifies if the end of the line is closed. If it is not closed, 497 509 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); over ride;499 procedure DrawPolyLineAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single; ClosedCap: boolean); over ride;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; 500 512 {** Draws a polyline using current pen style/cap/join. 501 513 ''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); over ride;514 procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single; fillcolor: TBGRAPixel); overload; override; 503 515 {** Draws a polyline using current pen style/cap/join. 504 516 The last point considered as a join with the first point if it has … … 509 521 The polygon is always closed. You don't need to set the last point 510 522 to be the same as the first point } 511 procedure DrawPolygonAntialias(const points: array of TPointF; c: TBGRAPixel; w: single); over ride;523 procedure DrawPolygonAntialias(const points: array of TPointF; c: TBGRAPixel; w: single); overload; override; 512 524 {** Draws a polygon using current pen style/cap/join. 513 525 The polygon is always closed. You don't need to set the last point 514 526 to be the same as the first point } 515 procedure DrawPolygonAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single); over ride;527 procedure DrawPolygonAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single); overload; override; 516 528 {** Draws a filled polygon using current pen style/cap/join. 517 529 The polygon is always closed. You don't need to set the last point 518 530 to be the same as the first point. } 519 procedure DrawPolygonAntialias(const points: array of TPointF; c: TBGRAPixel; w: single; fillcolor: TBGRAPixel); over ride;531 procedure DrawPolygonAntialias(const points: array of TPointF; c: TBGRAPixel; w: single; fillcolor: TBGRAPixel); overload; override; 520 532 521 533 {** Erases a line from (x1,y1) to (x2,y2) using current pen style/cap/join } … … 538 550 {** Draw a size border of a rectangle, 539 551 using the specified ''mode'' } 540 procedure Rectangle(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); over ride;552 procedure Rectangle(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); overload; override; 541 553 {** Draw a filled rectangle with a border of color ''BorderColor'', 542 554 using the specified ''mode'' } 543 procedure Rectangle(x, y, x2, y2: integer; BorderColor, FillColor: TBGRAPixel; mode: TDrawMode); over ride;555 procedure Rectangle(x, y, x2, y2: integer; BorderColor, FillColor: TBGRAPixel; mode: TDrawMode); overload; override; 544 556 {** Fills completely a rectangle, without any border, with the specified ''mode'' } 545 procedure FillRect(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); over ride; overload;557 procedure FillRect(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); overload; override; 546 558 {** Fills completely a rectangle, without any border, with the specified ''texture'' and 547 559 with the specified ''mode'' } 548 procedure FillRect(x, y, x2, y2: integer; texture: IBGRAScanner; mode: TDrawMode; AScanOffset: TPoint); over ride; overload;549 procedure FillRect(x, y, x2, y2: integer; texture: IBGRAScanner; mode: TDrawMode; AScanOffset: TPoint; ditheringAlgorithm: TDitheringAlgorithm); over ride; 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; 550 562 {** Sets the alpha value within the specified rectangle } 551 563 procedure AlphaFillRect(x, y, x2, y2: integer; alpha: byte); override; … … 554 566 {** Draws a round rectangle, with corners having an elliptical diameter of ''DX'' and ''DY'' } 555 567 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; 556 569 557 570 {==== Rectangles and ellipses (floating point coordinates) ====} … … 572 585 {** Fills a rectangle with antialiasing. For example (-0.5,-0.5,0.5,0.5) 573 586 fills one pixel } 574 procedure FillRectAntialias(x, y, x2, y2: single; c: TBGRAPixel; pixelCenteredCoordinates: boolean = true); over ride;587 procedure FillRectAntialias(x, y, x2, y2: single; c: TBGRAPixel; pixelCenteredCoordinates: boolean = true); overload; override; 575 588 {** Fills a rectangle with a texture } 576 procedure FillRectAntialias(x, y, x2, y2: single; texture: IBGRAScanner; pixelCenteredCoordinates: boolean = true); over ride;589 procedure FillRectAntialias(x, y, x2, y2: single; texture: IBGRAScanner; pixelCenteredCoordinates: boolean = true); overload; override; 577 590 {** Erases the content of a rectangle with antialiasing } 578 591 procedure EraseRectAntialias(x, y, x2, y2: single; alpha: byte; pixelCenteredCoordinates: boolean = true); override; … … 581 594 elliptical radius of ''rx'' and ''ry''. ''options'' specifies how to 582 595 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 = []); over ride;596 procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; c: TBGRAPixel; w: single; options: TRoundRectangleOptions = []); overload; override; 584 597 {** Draws a rounded rectangle border with the specified texture. 585 598 The corners have an elliptical radius of ''rx'' and ''ry''. 586 599 ''options'' specifies how to draw the corners. 587 600 See [[BGRABitmap Geometry types|geometry types]] } 588 procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; texture: IBGRAScanner; w: single; options: TRoundRectangleOptions = []); over ride;601 procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; texture: IBGRAScanner; w: single; options: TRoundRectangleOptions = []); overload; override; 589 602 {** Draws and fills a round rectangle } 590 procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; pencolor: TBGRAPixel; w: single; fillcolor: TBGRAPixel; options: TRoundRectangleOptions = []); over ride;603 procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; pencolor: TBGRAPixel; w: single; fillcolor: TBGRAPixel; options: TRoundRectangleOptions = []); overload; override; 591 604 {** 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 = []); over ride;605 procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; penTexture: IBGRAScanner; w: single; fillTexture: IBGRAScanner; options: TRoundRectangleOptions = []); overload; override; 593 606 594 607 {** Fills a rounded rectangle with antialiasing. The corners have an 595 608 elliptical radius of ''rx'' and ''ry''. ''options'' specifies how to 596 609 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); over ride;610 procedure FillRoundRectAntialias(x,y,x2,y2,rx,ry: single; c: TBGRAPixel; options: TRoundRectangleOptions = []; pixelCenteredCoordinates: boolean = true); overload; override; 598 611 {** Fills a rounded rectangle with a texture } 599 procedure FillRoundRectAntialias(x,y,x2,y2,rx,ry: single; texture: IBGRAScanner; options: TRoundRectangleOptions = []; pixelCenteredCoordinates: boolean = true); over ride;612 procedure FillRoundRectAntialias(x,y,x2,y2,rx,ry: single; texture: IBGRAScanner; options: TRoundRectangleOptions = []; pixelCenteredCoordinates: boolean = true); overload; override; 600 613 {** 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; 603 620 {** Draws an ellipse with antialising. ''rx'' is the horizontal radius and 604 621 ''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; 606 624 {** 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; 608 627 {** 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; 610 630 {** 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; 612 633 {** 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; 614 636 {** Fills an ellipse with a gradient of color. ''outercolor'' specifies 615 637 the end color of the gradient on the border of the ellipse and 616 638 ''innercolor'' the end color of the gradient at the center of the 617 639 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; 619 642 {** 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; 621 645 622 646 {==== 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; 629 653 630 654 procedure FillTriangleLinearColor(pt1,pt2,pt3: TPointF; c1,c2,c3: TBGRAPixel); override; … … 652 676 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; 653 677 654 procedure FillShape(shape: TBGRACustomFillInfo; c: TBGRAPixel; drawmode: TDrawMode); over ride;655 procedure FillShape(shape: TBGRACustomFillInfo; texture: IBGRAScanner; drawmode: TDrawMode); over ride;656 procedure FillShapeAntialias(shape: TBGRACustomFillInfo; c: TBGRAPixel); over ride;657 procedure FillShapeAntialias(shape: TBGRACustomFillInfo; texture: IBGRAScanner); over ride;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; 658 682 procedure EraseShape(shape: TBGRACustomFillInfo; alpha: byte); override; 659 683 procedure EraseShapeAntialias(shape: TBGRACustomFillInfo; alpha: byte); override; 660 684 661 procedure DrawPath(APath: IBGRAPath; AStrokeColor: TBGRAPixel; AWidth: single; AFillColor: TBGRAPixel); over ride;662 procedure DrawPath(APath: IBGRAPath; AStrokeTexture: IBGRAScanner; AWidth: single; AFillColor: TBGRAPixel); over ride;663 procedure DrawPath(APath: IBGRAPath; AStrokeColor: TBGRAPixel; AWidth: single; AFillTexture: IBGRAScanner); over ride;664 procedure DrawPath(APath: IBGRAPath; AStrokeTexture: IBGRAScanner; AWidth: single; AFillTexture: IBGRAScanner); over ride;665 procedure DrawPath(APath: IBGRAPath; AStrokeColor: TBGRAPixel; AWidth: single); over ride;666 procedure DrawPath(APath: IBGRAPath; AStrokeTexture: IBGRAScanner; AWidth: single); over ride;667 procedure FillPath(APath: IBGRAPath; AFillColor: TBGRAPixel); over ride;668 procedure FillPath(APath: IBGRAPath; AFillTexture: IBGRAScanner); over ride;669 procedure ErasePath(APath: IBGRAPath; alpha: byte); over ride;670 671 procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeColor: TBGRAPixel; AWidth: single; AFillColor: TBGRAPixel); over ride;672 procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeTexture: IBGRAScanner; AWidth: single; AFillColor: TBGRAPixel); over ride;673 procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeColor: TBGRAPixel; AWidth: single; AFillTexture: IBGRAScanner); over ride;674 procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeTexture: IBGRAScanner; AWidth: single; AFillTexture: IBGRAScanner); over ride;675 procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeColor: TBGRAPixel; AWidth: single); over ride;676 procedure DrawPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AStrokeTexture: IBGRAScanner; AWidth: single); over ride;677 procedure FillPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AFillColor: TBGRAPixel); over ride;678 procedure FillPath(APath: IBGRAPath; AMatrix: TAffineMatrix; AFillTexture: IBGRAScanner); over ride;679 procedure ErasePath(APath: IBGRAPath; AMatrix: TAffineMatrix; alpha: byte); over ride;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; 680 704 681 705 procedure ArrowStartAsNone; override; … … 694 718 If align is taRightJustify, (x,y) is the top-right corner. 695 719 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; 697 721 698 722 { Same as above functions, except that the text is filled using texture. 699 723 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; 701 725 702 726 { 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; 708 735 709 736 { Draw the UTF8 encoded string at the coordinate (x,y), clipped inside the rectangle ARect. 710 737 Additional style information is provided by the style parameter. 711 738 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); over ride; overload;713 procedure TextRect(ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; texture: IBGRAScanner); over ride; 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; 714 741 715 742 { 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. } 717 744 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; 718 754 719 755 {Spline} … … 721 757 function ComputeOpenedSpline(const APoints: array of TPointF; AStyle: TSplineStyle): ArrayOfTPointF; override; 722 758 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; 734 772 function ComputeArc65536(x,y,rx,ry: single; start65536,end65536: word; quality: single = 1): ArrayOfTPointF; override; 735 773 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; over ride;737 function ComputeRoundRect(x1,y1,x2,y2,rx,ry: single; options: TRoundRectangleOptions; quality: single = 1): ArrayOfTPointF; over ride;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; 738 776 function ComputePie65536(x,y,rx,ry: single; start65536,end65536: word; quality: single = 1): ArrayOfTPointF; override; 739 777 function ComputePieRad(x,y,rx,ry: single; startRad,endRad: single; quality: single = 1): ArrayOfTPointF; override; … … 741 779 {Filling} 742 780 procedure NoClip; override; 743 procedure Fill(texture: IBGRAScanner; mode: TDrawMode); over ride;744 procedure Fill(texture: IBGRAScanner); over ride;745 procedure Fill(c: TBGRAPixel; start, Count: integer); over ride;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; 746 784 procedure DrawPixels(c: TBGRAPixel; start, Count: integer); override; 747 785 procedure AlphaFill(alpha: byte; start, Count: integer); override; 748 786 procedure FillMask(x,y: integer; AMask: TBGRACustomBitmap; color: TBGRAPixel; ADrawMode: TDrawMode); override; 749 787 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; 750 789 procedure FillClearTypeMask(x,y: integer; xThird: integer; AMask: TBGRACustomBitmap; color: TBGRAPixel; ARGBOrder: boolean = true); override; 751 790 procedure FillClearTypeMask(x,y: integer; xThird: integer; AMask: TBGRACustomBitmap; texture: IBGRAScanner; ARGBOrder: boolean = true); override; … … 775 814 776 815 {Canvas drawing functions} 777 procedure Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean = True); over ride;778 procedure Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean = True); over ride;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; 779 818 procedure InvalidateBitmap; override; //call if you modify with Scanline 780 819 procedure LoadFromBitmapIfNeeded; override; //call to ensure that bitmap data is up to date 781 820 782 821 {BGRA bitmap functions} 783 procedure CrossFade(ARect: TRect; Source1, Source2: IBGRAScanner; AFadePosition: byte; mode: TDrawMode = dmDrawWithTransparency); over ride;784 procedure CrossFade(ARect: TRect; Source1, Source2: IBGRAScanner; AFadeMask: IBGRAScanner; mode: TDrawMode = dmDrawWithTransparency); over ride;785 procedure PutImage(x, y: integer; Source: TBGRACustomBitmap; mode: TDrawMode; AOpacity: byte = 255); over ride;786 procedure PutImageAffine(AMatrix: TAffineMatrix; Source: TBGRACustomBitmap; AOutputBounds: TRect; AResampleFilter: TResampleFilter; AMode: TDrawMode; AOpacity: Byte=255); over ride; overload;787 function GetImageAffineBounds(AMatrix: TAffineMatrix; ASourceBounds: TRect; AClipOutput: boolean = true): TRect; over ride; 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; 789 828 790 829 procedure StretchPutImage(ARect: TRect; Source: TBGRACustomBitmap; mode: TDrawMode; AOpacity: byte = 255); override; … … 796 835 function GetPart(ARect: TRect): TBGRACustomBitmap; override; 797 836 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; 799 838 procedure CopyPropertiesTo(ABitmap: TBGRADefaultBitmap); 800 function Equals(comp: TBGRACustomBitmap): boolean; over ride;801 function Equals(comp: TBGRAPixel): boolean; over ride;839 function Equals(comp: TBGRACustomBitmap): boolean; overload; override; 840 function Equals(comp: TBGRAPixel): boolean; overload; override; 802 841 function GetDifferenceBounds(ABitmap: TBGRACustomBitmap): TRect; override; 803 842 function MakeBitmapCopy(BackgroundColor: TColor): TBitmap; override; … … 805 844 function Resample(newWidth, newHeight: integer; 806 845 mode: TResampleMode = rmFineResample): TBGRACustomBitmap; override; 807 procedure VerticalFlip(ARect: TRect); over ride; overload;808 procedure HorizontalFlip(ARect: TRect); over ride; overload;846 procedure VerticalFlip(ARect: TRect); overload; override; 847 procedure HorizontalFlip(ARect: TRect); overload; override; 809 848 function RotateCW: TBGRACustomBitmap; override; 810 849 function RotateCCW: TBGRACustomBitmap; override; … … 813 852 procedure LinearNegative; override; 814 853 procedure LinearNegativeRect(ABounds: TRect); override; 815 procedure InplaceGrayscale(AGammaCorrection: boolean = true); over ride;816 procedure InplaceGrayscale(ABounds: TRect; AGammaCorrection: boolean = true); over ride;817 procedure InplaceNormalize(AEachChannel: boolean = True); over ride;818 procedure InplaceNormalize(ABounds: TRect; AEachChannel: boolean = True); over ride;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; 819 858 procedure SwapRedBlue; override; 820 859 procedure SwapRedBlue(ARect: TRect); override; 821 860 procedure GrayscaleToAlpha; override; 822 861 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; 824 864 procedure ApplyGlobalOpacity(alpha: byte); override; 825 865 procedure ApplyGlobalOpacity(ABounds: TRect; alpha: byte); override; 826 866 procedure ConvertToLinearRGB; override; 827 867 procedure ConvertFromLinearRGB; override; 828 procedure DrawCheckers(ARect: TRect; AColorEven,AColorOdd: TBGRAPixel); 868 procedure DrawCheckers(ARect: TRect; AColorEven,AColorOdd: TBGRAPixel); override; 829 869 830 870 {Filters} … … 832 872 function FilterMedian(Option: TMedianOption): TBGRACustomBitmap; override; 833 873 function FilterSmooth: TBGRACustomBitmap; override; 834 function FilterSharpen(Amount: single = 1): TBGRACustomBitmap; over ride;835 function FilterSharpen(ABounds: TRect; Amount: single = 1): TBGRACustomBitmap; over ride;874 function FilterSharpen(Amount: single = 1): TBGRACustomBitmap; overload; override; 875 function FilterSharpen(ABounds: TRect; Amount: single = 1): TBGRACustomBitmap; overload; override; 836 876 function FilterContour: TBGRACustomBitmap; override; 837 877 function FilterPixelate(pixelSize: integer; useResample: boolean; filter: TResampleFilter = rfLinear): TBGRACustomBitmap; override; 838 function FilterBlurRadial(radius: single; blurType: TRadialBlurType): TBGRACustomBitmap; over ride;839 function FilterBlurRadial(ABounds: TRect; radius: single; blurType: TRadialBlurType): TBGRACustomBitmap; over ride;840 function FilterBlurRadial(radiusX, radiusY: single; blurType: TRadialBlurType): TBGRACustomBitmap; over ride;841 function FilterBlurRadial(ABounds: TRect; radiusX, radiusY: single; blurType: TRadialBlurType): TBGRACustomBitmap; over ride;842 function FilterBlurMotion(distance: single; angle: single; oriented: boolean): TBGRACustomBitmap; over ride;843 function FilterBlurMotion(ABounds: TRect; distance: single; angle: single; oriented: boolean): TBGRACustomBitmap; over ride;844 function FilterCustomBlur(mask: TBGRACustomBitmap): TBGRACustomBitmap; over ride;845 function FilterCustomBlur(ABounds: TRect; mask: TBGRACustomBitmap): TBGRACustomBitmap; over ride;846 function FilterEmboss(angle: single; AStrength: integer= 64; AOptions: TEmbossOptions = []): TBGRACustomBitmap; over ride;847 function FilterEmboss(angle: single; ABounds: TRect; AStrength: integer= 64; AOptions: TEmbossOptions = []): TBGRACustomBitmap; over ride;848 function FilterEmbossHighlight(FillSelection: boolean): TBGRACustomBitmap; over ride;849 function FilterEmbossHighlight(FillSelection: boolean; BorderColor: TBGRAPixel): TBGRACustomBitmap; over ride;850 function FilterEmbossHighlight(FillSelection: boolean; BorderColor: TBGRAPixel; var Offset: TPoint): TBGRACustomBitmap; over ride;851 function FilterGrayscale: TBGRACustomBitmap; over ride;852 function FilterGrayscale(ABounds: TRect): TBGRACustomBitmap; over ride;853 function FilterNormalize(eachChannel: boolean = True): TBGRACustomBitmap; over ride;854 function FilterNormalize(ABounds: TRect; eachChannel: boolean = True): TBGRACustomBitmap; over ride;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; 855 895 function FilterRotate(origin: TPointF; angle: single; correctBlur: boolean = false): TBGRACustomBitmap; override; 856 896 function FilterAffine(AMatrix: TAffineMatrix; correctBlur: boolean = false): TBGRACustomBitmap; override; 857 897 function FilterSphere: TBGRACustomBitmap; override; 858 function FilterTwirl(ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap; over ride;859 function FilterTwirl(ABounds: TRect; ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap; over ride;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; 860 900 function FilterCylinder: TBGRACustomBitmap; override; 861 901 function FilterPlane: TBGRACustomBitmap; override; … … 880 920 public 881 921 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; 883 923 procedure SetDataPtr(AData: Pointer); 884 924 property LineOrder: TRawImageLineOrder Read GetLineOrder Write SetLineOrder; … … 893 933 procedure TakeScreenshot({%H-}ARect: TRect); override; 894 934 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; 897 937 end; 898 938 … … 935 975 begin 936 976 if FUser <> nil then 977 begin 937 978 FUser.FBitmapModified := True; 979 FUser.FAlphaCorrectionNeeded := true; 980 end; 938 981 inherited Changed(Sender); 939 982 end; … … 966 1009 end; 967 1010 1011 function TBGRADefaultBitmap.CheckIsZero: boolean; 1012 var 1013 i: integer; 1014 p: PBGRAPixel; 1015 begin 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; 1032 end; 1033 968 1034 function TBGRADefaultBitmap.GetCanvasAlphaCorrection: boolean; 969 1035 begin … … 1055 1121 procedure TBGRADefaultBitmap.SetArrowEndSize(AValue: TPointF); 1056 1122 begin 1123 {$PUSH}{$OPTIMIZATION OFF} 1057 1124 GetArrow.EndSize := AValue; 1125 {$POP} 1058 1126 end; 1059 1127 1060 1128 procedure TBGRADefaultBitmap.SetArrowStartSize(AValue: TPointF); 1061 1129 begin 1130 {$PUSH}{$OPTIMIZATION OFF} 1062 1131 GetArrow.StartSize := AValue; 1132 {$POP} 1063 1133 end; 1064 1134 … … 1148 1218 end; 1149 1219 1150 function TBGRADefaultBitmap.GetFont AnchorVerticalOffset: single;1220 function TBGRADefaultBitmap.GetFontVerticalAnchorOffset: single; 1151 1221 begin 1152 1222 case FontVerticalAnchor of … … 1173 1243 ACustomOrientation: integer): TPointF; 1174 1244 begin 1175 result := PointF(0, GetFont AnchorVerticalOffset);1245 result := PointF(0, GetFontVerticalAnchorOffset); 1176 1246 if ACustomOrientation <> 0 then 1177 1247 result := AffineMatrixRotationDeg(-ACustomOrientation*0.1)*result; … … 1205 1275 function TBGRADefaultBitmap.NewReference: TBGRACustomBitmap; 1206 1276 begin 1207 Inc(FRefCount);1277 if self <> nil then Inc(FRefCount); 1208 1278 Result := self; 1209 1279 end; … … 1239 1309 end; 1240 1310 1311 procedure TBGRADefaultBitmap.NeedXorMask; 1312 begin 1313 if FXorMask = nil then 1314 FXorMask := BGRABitmapFactory.Create(Width,Height); 1315 end; 1316 1317 procedure TBGRADefaultBitmap.DiscardXorMask; 1318 begin 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; 1328 end; 1329 1241 1330 { Creates a new bitmap with dimensions AWidth and AHeight and filled with 1242 1331 transparent pixels. Internally, it uses the same type so that if you … … 1309 1398 OldJpegPerf: TJPEGReadPerformance; 1310 1399 begin 1400 DiscardXorMask; 1311 1401 if (loBmpAutoOpaque in AOptions) and (Handler is TBGRAReaderBMP) then 1312 1402 begin … … 1324 1414 end else 1325 1415 inherited LoadFromStream(Str, Handler, AOptions); 1416 end; 1417 1418 procedure TBGRADefaultBitmap.LoadFromResource(AFilename: string; 1419 AOptions: TBGRALoadingOptions); 1420 var 1421 stream: TStream; 1422 format: TBGRAImageFormat; 1423 reader: TFPCustomImageReader; 1424 magic: array[1..2] of char; 1425 startPos: Int64; 1426 ext: String; 1427 begin 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; 1326 1448 end; 1327 1449 … … 1357 1479 ReallocData; 1358 1480 NoClip; 1481 DiscardXorMask; 1359 1482 end; 1360 1483 … … 1412 1535 destructor TBGRADefaultBitmap.Destroy; 1413 1536 begin 1537 DiscardXorMask; 1414 1538 FPenStroker.Free; 1415 1539 FFontRenderer.Free; … … 1499 1623 SetSize(TBGRACustomBitmap(Source).Width, TBGRACustomBitmap(Source).Height); 1500 1624 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; 1501 1637 end else 1502 1638 if Source is TFPCustomImage then … … 1964 2100 function TBGRADefaultBitmap.GetCanvas: TCanvas; 1965 2101 begin 1966 Result := Bitmap.Canvas; 2102 if FDataModified or (FBitmap = nil) then 2103 begin 2104 RebuildBitmap; 2105 FDataModified := False; 2106 end; 2107 Result := FBitmap.Canvas; 1967 2108 end; 1968 2109 … … 1990 2131 1991 2132 procedure TBGRADefaultBitmap.CrossFade(ARect: TRect; Source1, Source2: IBGRAScanner; AFadePosition: byte; mode: TDrawMode = dmDrawWithTransparency); 1992 var constScanner: TBGRAConstantScanner;1993 2133 begin 1994 2134 if AFadePosition = 0 then … … 1996 2136 if AFadePosition = 255 then 1997 2137 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); 2003 2139 end; 2004 2140 2005 2141 procedure 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; 2142 begin 2143 InternalCrossFade(ARect, Source1,Source2, 0,AFadeMask, mode); 2032 2144 end; 2033 2145 … … 2384 2496 end; 2385 2497 2498 procedure TBGRADefaultBitmap.InternalCrossFade(ARect: TRect; Source1, 2499 Source2: IBGRAScanner; AFadePos: byte; AFadeMask: IBGRAScanner; mode: TDrawMode); 2500 var xb,yb: NativeInt; 2501 pdest: PBGRAPixel; 2502 c: TBGRAPixel; 2503 buf1,buf2: ArrayOfTBGRAPixel; 2504 begin 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; 2530 end; 2531 2386 2532 procedure TBGRADefaultBitmap.InternalArc(cx, cy, rx, ry: single; StartAngleRad, 2387 2533 EndAngleRad: Single; ABorderColor: TBGRAPixel; w: single; AFillColor: TBGRAPixel; AOptions: TArcOptions; … … 2441 2587 end; 2442 2588 2443 function TBGRADefaultBitmap.IsAffineRoughlyTranslation(AMatrix: TAffineMatrix; ASourceBounds: TRect): boolean;2589 class function TBGRADefaultBitmap.IsAffineRoughlyTranslation(AMatrix: TAffineMatrix; ASourceBounds: TRect): boolean; 2444 2590 const oneOver512 = 1/512; 2445 2591 var Orig,HAxis,VAxis: TPointF; … … 2653 2799 tempPath := TBGRAPath.Create(APath); 2654 2800 multi := TBGRAMultishapeFiller.Create; 2801 multi.FillMode := FillMode; 2655 2802 multi.PolygonOrder := poLastOnTop; 2656 2803 multi.AddPathFill(tempPath,AMatrix,AFillColor); … … 2668 2815 tempPath := TBGRAPath.Create(APath); 2669 2816 multi := TBGRAMultishapeFiller.Create; 2817 multi.FillMode := FillMode; 2670 2818 multi.PolygonOrder := poLastOnTop; 2671 2819 multi.AddPathFill(tempPath,AMatrix,AFillColor); … … 2683 2831 tempPath := TBGRAPath.Create(APath); 2684 2832 multi := TBGRAMultishapeFiller.Create; 2833 multi.FillMode := FillMode; 2685 2834 multi.PolygonOrder := poLastOnTop; 2686 2835 multi.AddPathFill(tempPath,AMatrix,AFillTexture); … … 2699 2848 tempPath := TBGRAPath.Create(APath); 2700 2849 multi := TBGRAMultishapeFiller.Create; 2850 multi.FillMode := FillMode; 2701 2851 multi.PolygonOrder := poLastOnTop; 2702 2852 multi.AddPathFill(tempPath,AMatrix,AFillTexture); … … 3038 3188 3039 3189 procedure 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); 3191 begin 3192 BGRAPolygon.FillPolyAliased(self, points, c, FEraseMode, FillMode = fmWinding, drawmode, APixelCenteredCoordinates); 3043 3193 end; 3044 3194 3045 3195 procedure 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); 3197 begin 3198 BGRAPolygon.FillPolyAliasedWithTexture(self, points, texture, FillMode = fmWinding, drawmode, APixelCenteredCoordinates); 3049 3199 end; 3050 3200 … … 3057 3207 end; 3058 3208 3059 procedure TBGRADefaultBitmap.FillPolyAntialias(const points: array of TPointF; c: TBGRAPixel );3060 begin 3061 BGRAPolygon.FillPolyAntialias(self, points, c, FEraseMode, FillMode = fmWinding, LinearAntialiasing );3209 procedure TBGRADefaultBitmap.FillPolyAntialias(const points: array of TPointF; c: TBGRAPixel; APixelCenteredCoordinates: boolean); 3210 begin 3211 BGRAPolygon.FillPolyAntialias(self, points, c, FEraseMode, FillMode = fmWinding, LinearAntialiasing, APixelCenteredCoordinates); 3062 3212 end; 3063 3213 3064 3214 procedure 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); 3216 begin 3217 BGRAPolygon.FillPolyAntialiasWithTexture(self, points, texture, FillMode = fmWinding, LinearAntialiasing, APixelCenteredCoordinates); 3068 3218 end; 3069 3219 3070 3220 procedure 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); 3222 begin 3223 BGRAPolygon.FillPolyAliased(self, points, BGRA(0, 0, 0, alpha), True, FillMode = fmWinding, dmDrawWithTransparency, APixelCenteredCoordinates); 3224 end; 3225 3226 procedure TBGRADefaultBitmap.ErasePolyAntialias(const points: array of TPointF; alpha: byte; APixelCenteredCoordinates: boolean); 3077 3227 begin 3078 3228 FEraseMode := True; 3079 FillPolyAntialias(points, BGRA(0, 0, 0, alpha) );3229 FillPolyAntialias(points, BGRA(0, 0, 0, alpha), APixelCenteredCoordinates); 3080 3230 FEraseMode := False; 3081 3231 end; … … 3155 3305 c: TBGRAPixel; w: single); 3156 3306 begin 3157 if (PenStyle = psClear) or (c.alpha = 0) then exit;3307 if (PenStyle = psClear) or (c.alpha = 0) or (w = 0) then exit; 3158 3308 if (PenStyle = psSolid) then 3159 3309 BGRAPolygon.BorderEllipseAntialias(self, x, y, rx, ry, w, c, FEraseMode, LinearAntialiasing) … … 3162 3312 end; 3163 3313 3314 procedure TBGRADefaultBitmap.EllipseAntialias(AOrigin, AXAxis, AYAxis: TPointF; 3315 c: TBGRAPixel; w: single); 3316 begin 3317 if (PenStyle = psClear) or (c.alpha = 0) or (w = 0) then exit; 3318 DrawPolygonAntialias(ComputeEllipseContour(AOrigin, AXAxis, AYAxis),c,w); 3319 end; 3320 3164 3321 procedure TBGRADefaultBitmap.EllipseAntialias(x, y, rx, ry: single; 3165 3322 texture: IBGRAScanner; w: single); 3166 3323 begin 3167 if (PenStyle = psClear) then exit;3324 if (PenStyle = psClear) or (w = 0) then exit; 3168 3325 if (PenStyle = psSolid) then 3169 3326 BGRAPolygon.BorderEllipseAntialiasWithTexture(self, x, y, rx, ry, w, texture, LinearAntialiasing) … … 3172 3329 end; 3173 3330 3331 procedure TBGRADefaultBitmap.EllipseAntialias(AOrigin, AXAxis, AYAxis: TPointF; 3332 texture: IBGRAScanner; w: single); 3333 begin 3334 if (PenStyle = psClear) or (w = 0) then exit; 3335 DrawPolygonAntialias(ComputeEllipseContour(AOrigin, AXAxis, AYAxis),texture,w); 3336 end; 3337 3174 3338 procedure TBGRADefaultBitmap.EllipseAntialias(x, y, rx, ry: single; 3175 3339 c: TBGRAPixel; w: single; back: TBGRAPixel); … … 3177 3341 hw: single; 3178 3342 begin 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; 3180 3348 rx := abs(rx); 3181 3349 ry := abs(ry); … … 3188 3356 { use multishape filler for fine junction between polygons } 3189 3357 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; 3204 3369 multi.Draw(self); 3205 3370 multi.Free; 3206 3371 end; 3207 3372 3373 procedure TBGRADefaultBitmap.EllipseAntialias(AOrigin, AXAxis, AYAxis: TPointF; 3374 c: TBGRAPixel; w: single; back: TBGRAPixel); 3375 var multi: TBGRAMultishapeFiller; 3376 pts: ArrayOfTPointF; 3377 begin 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; 3392 end; 3393 3208 3394 procedure TBGRADefaultBitmap.FillEllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel); 3209 3395 begin 3210 3396 BGRAPolygon.FillEllipseAntialias(self, x, y, rx, ry, c, FEraseMode, LinearAntialiasing); 3397 end; 3398 3399 procedure TBGRADefaultBitmap.FillEllipseAntialias(AOrigin, AXAxis, 3400 AYAxis: TPointF; c: TBGRAPixel); 3401 var 3402 pts: array of TPointF; 3403 begin 3404 if c.alpha = 0 then exit; 3405 pts := ComputeEllipseContour(AOrigin,AXAxis,AYAxis); 3406 FillPolyAntialias(pts, c); 3211 3407 end; 3212 3408 … … 3215 3411 begin 3216 3412 BGRAPolygon.FillEllipseAntialiasWithTexture(self, x, y, rx, ry, texture, LinearAntialiasing); 3413 end; 3414 3415 procedure TBGRADefaultBitmap.FillEllipseAntialias(AOrigin, AXAxis, 3416 AYAxis: TPointF; texture: IBGRAScanner); 3417 var 3418 pts: array of TPointF; 3419 begin 3420 pts := ComputeEllipseContour(AOrigin,AXAxis,AYAxis); 3421 FillPolyAntialias(pts, texture); 3217 3422 end; 3218 3423 … … 3241 3446 end; 3242 3447 3448 procedure TBGRADefaultBitmap.FillEllipseLinearColorAntialias(AOrigin, AXAxis, 3449 AYAxis: TPointF; outercolor, innercolor: TBGRAPixel); 3450 var 3451 grad: TBGRAGradientScanner; 3452 affine: TBGRAAffineScannerTransform; 3453 begin 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; 3460 end; 3461 3243 3462 procedure TBGRADefaultBitmap.EraseEllipseAntialias(x, y, rx, ry: single; alpha: byte); 3244 3463 begin 3245 3464 FEraseMode := True; 3246 3465 FillEllipseAntialias(x, y, rx, ry, BGRA(0, 0, 0, alpha)); 3466 FEraseMode := False; 3467 end; 3468 3469 procedure TBGRADefaultBitmap.EraseEllipseAntialias(AOrigin, AXAxis, 3470 AYAxis: TPointF; alpha: byte); 3471 begin 3472 FEraseMode := True; 3473 FillEllipseAntialias(AOrigin, AXAxis, AYAxis, BGRA(0, 0, 0, alpha)); 3247 3474 FEraseMode := False; 3248 3475 end; … … 3707 3934 c: TBGRAPixel; options: TRoundRectangleOptions; pixelCenteredCoordinates: boolean); 3708 3935 begin 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); 3717 3937 end; 3718 3938 … … 3720 3940 ry: single; texture: IBGRAScanner; options: TRoundRectangleOptions; pixelCenteredCoordinates: boolean); 3721 3941 begin 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); 3730 3943 end; 3731 3944 … … 3733 3946 ry: single; alpha: byte; options: TRoundRectangleOptions; pixelCenteredCoordinates: boolean); 3734 3947 begin 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); 3949 end; 3950 3951 procedure TBGRADefaultBitmap.Ellipse(x, y, rx, ry: single; c: TBGRAPixel; 3952 w: single; ADrawMode: TDrawMode); 3953 begin 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); 3959 end; 3960 3961 procedure TBGRADefaultBitmap.Ellipse(AOrigin, AXAxis, AYAxis: TPointF; 3962 c: TBGRAPixel; w: single; ADrawMode: TDrawMode); 3963 begin 3964 if (PenStyle = psClear) or (c.alpha = 0) or (w = 0) then exit; 3965 FillPoly(ComputeWidePolygon(ComputeEllipseContour(AOrigin, AXAxis, AYAxis),w),c,ADrawMode); 3743 3966 end; 3744 3967 … … 3755 3978 end; 3756 3979 3980 procedure TBGRADefaultBitmap.FillRoundRect(X1, Y1, X2, Y2: integer; DX, 3981 DY: integer; FillTexture: IBGRAScanner; ADrawMode: TDrawMode); 3982 begin 3983 BGRAFillRoundRectAliased(self,X1,Y1,X2,Y2,DX,DY,BGRAPixelTransparent,FillTexture,ADrawMode); 3984 end; 3985 3757 3986 {------------------------- Text functions ---------------------------------------} 3758 3987 … … 3781 4010 end; 3782 4011 4012 procedure TBGRADefaultBitmap.TextMultiline(ALeft, ATop, AWidth: single; sUTF8: string; 4013 c: TBGRAPixel; AAlign: TBidiTextAlignment; AVertAlign: TTextLayout; AParagraphSpacing: single); 4014 var 4015 layout: TBidiTextLayout; 4016 i: Integer; 4017 begin 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; 4033 end; 4034 4035 procedure TBGRADefaultBitmap.TextMultiline(ALeft, ATop, AWidth: single; 4036 sUTF8: string; ATexture: IBGRAScanner; AAlign: TBidiTextAlignment; 4037 AVertAlign: TTextLayout; AParagraphSpacing: single); 4038 var 4039 layout: TBidiTextLayout; 4040 i: Integer; 4041 begin 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; 4057 end; 4058 3783 4059 procedure 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); 4061 begin 4062 FontRenderer.TextOut(self,x,y,CleanTextOutString(sUTF8),texture,align, ARightToLeft); 3787 4063 end; 3788 4064 3789 4065 procedure TBGRADefaultBitmap.TextOut(x, y: single; sUTF8: string; 3790 c: TBGRAPixel; align: TAlignment );4066 c: TBGRAPixel; align: TAlignment; ARightToLeft: boolean); 3791 4067 begin 3792 4068 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); 3794 4070 end; 3795 4071 … … 3812 4088 function TBGRADefaultBitmap.TextSize(sUTF8: string): TSize; 3813 4089 begin 3814 result := FontRenderer.TextSize(sUTF8); 4090 result := FontRenderer.TextSize(CleanTextOutString(sUTF8)); 4091 end; 4092 4093 function TBGRADefaultBitmap.TextAffineBox(sUTF8: string): TAffineBox; 4094 var size: TSize; 4095 m: TAffineMatrix; 4096 dy: single; 4097 begin 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)); 4102 end; 4103 4104 function TBGRADefaultBitmap.TextSize(sUTF8: string; AMaxWidth: integer): TSize; 4105 begin 4106 result := FontRenderer.TextSize(sUTF8, AMaxWidth, GetFontRightToLeftFor(sUTF8)); 4107 end; 4108 4109 function TBGRADefaultBitmap.TextSize(sUTF8: string; AMaxWidth: integer; 4110 ARightToLeft: boolean): TSize; 4111 begin 4112 result := FontRenderer.TextSize(sUTF8, AMaxWidth, ARightToLeft); 4113 end; 4114 4115 function TBGRADefaultBitmap.TextFitInfo(sUTF8: string; AMaxWidth: integer 4116 ): integer; 4117 begin 4118 result := FontRenderer.TextFitInfo(sUTF8, AMaxWidth); 3815 4119 end; 3816 4120 … … 3874 4178 end; 3875 4179 4180 function TBGRADefaultBitmap.ComputeEllipseContour(AOrigin, AXAxis, 4181 AYAxis: TPointF; quality: single): ArrayOfTPointF; 4182 begin 4183 result := BGRAPath.ComputeEllipse(AOrigin,AXAxis,AYAxis, quality); 4184 end; 4185 3876 4186 function TBGRADefaultBitmap.ComputeEllipseBorder(x, y, rx, ry, w: single; quality: single): ArrayOfTPointF; 3877 4187 begin 3878 4188 result := ComputeWidePolygon(ComputeEllipseContour(x,y,rx,ry, quality),w); 4189 end; 4190 4191 function TBGRADefaultBitmap.ComputeEllipseBorder(AOrigin, AXAxis, 4192 AYAxis: TPointF; w: single; quality: single): ArrayOfTPointF; 4193 begin 4194 result := ComputeWidePolygon(ComputeEllipseContour(AOrigin,AXAxis,AYAxis, quality),w); 3879 4195 end; 3880 4196 … … 3980 4296 self.FillRect(X,Y,X+AMask.Width,Y+AMask.Height,scan,ADrawMode); 3981 4297 scan.Free; 4298 end; 4299 4300 procedure TBGRADefaultBitmap.EraseMask(x, y: integer; AMask: TBGRACustomBitmap; 4301 alpha: byte); 4302 var 4303 x0,y0,x2, y2, yb,xb, tx, delta: integer; 4304 p, psrc: PBGRAPixel; 4305 begin 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; 3982 4347 end; 3983 4348 … … 4175 4540 exit; 4176 4541 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; 4179 4545 else 4180 4546 EndMask := 1 shl ((X2 and 31) + 1) - 1; 4547 end; 4181 4548 StartPos := X1 shr 5 + AY * VisitedLineSize; 4182 4549 EndPos := X2 shr 5 + AY * VisitedLineSize; … … 4653 5020 end; 4654 5021 InvalidateBitmap; 5022 if (Source is TBGRADefaultBitmap) and Assigned(TBGRADefaultBitmap(Source).XorMask) then 5023 PutImage(x,y,TBGRADefaultBitmap(Source).XorMask,dmXor,AOpacity); 4655 5024 end; 4656 5025 dmDrawWithTransparency: … … 4680 5049 end; 4681 5050 InvalidateBitmap; 5051 if (Source is TBGRADefaultBitmap) and Assigned(TBGRADefaultBitmap(Source).XorMask) then 5052 PutImage(x,y,TBGRADefaultBitmap(Source).XorMask,dmXor,AOpacity); 4682 5053 end; 4683 5054 dmFastBlend: … … 4706 5077 end; 4707 5078 InvalidateBitmap; 5079 if (Source is TBGRADefaultBitmap) and Assigned(TBGRADefaultBitmap(Source).XorMask) then 5080 PutImage(x,y,TBGRADefaultBitmap(Source).XorMask,dmXor,AOpacity); 4708 5081 end; 4709 5082 dmXor: … … 4875 5248 procedure TBGRADefaultBitmap.StretchPutImage(ARect: TRect; 4876 5249 Source: TBGRACustomBitmap; mode: TDrawMode; AOpacity: byte); 5250 var noTransition: boolean; 4877 5251 begin 4878 5252 If (Source = nil) or (AOpacity = 0) then exit; … … 4880 5254 PutImage(ARect.Left,ARect.Top,Source,mode,AOpacity) 4881 5255 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; 4883 5264 end; 4884 5265 4885 5266 { Duplicate bitmap content. Optionally, bitmap properties can be also duplicated } 4886 function TBGRADefaultBitmap.Duplicate(DuplicateProperties: Boolean = False ): TBGRACustomBitmap;5267 function TBGRADefaultBitmap.Duplicate(DuplicateProperties: Boolean = False; DuplicateXorMask: Boolean = False): TBGRACustomBitmap; 4887 5268 var Temp: TBGRADefaultBitmap; 4888 5269 begin … … 4893 5274 if DuplicateProperties then 4894 5275 CopyPropertiesTo(Temp); 5276 if DuplicateXorMask and Assigned(XorMask) then 5277 Temp.FXorMask := FXorMask.Duplicate(True) as TBGRADefaultBitmap; 4895 5278 Result := Temp; 4896 5279 end; … … 4908 5291 ABitmap.FontAntialias := FontAntialias; 4909 5292 ABitmap.FontOrientation := FontOrientation; 5293 ABitmap.FontBidiMode:= FontBidiMode; 4910 5294 ABitmap.LineCap := LineCap; 4911 5295 ABitmap.JoinStyle := JoinStyle; 4912 5296 ABitmap.FillMode := FillMode; 4913 5297 ABitmap.ClipRect := ClipRect; 5298 ABitmap.HotSpot := HotSpot; 4914 5299 end; 4915 5300 … … 5185 5570 end; 5186 5571 5572 function TBGRADefaultBitmap.GetHasSemiTransparentPixels: boolean; 5573 var 5574 n: integer; 5575 p: PBGRAPixel; 5576 begin 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; 5588 end; 5589 5187 5590 function TBGRADefaultBitmap.GetAverageColor: TColor; 5188 5591 var … … 5318 5721 freemem(line); 5319 5722 InvalidateBitmap; 5723 5724 if Assigned(XorMask) then XorMask.VerticalFlip(ARect); 5320 5725 end; 5321 5726 … … 5351 5756 end; 5352 5757 InvalidateBitmap; 5758 5759 if Assigned(XorMask) then XorMask.HorizontalFlip(ARect); 5353 5760 end; 5354 5761 … … 5377 5784 end; 5378 5785 end; 5786 5787 if Assigned(XorMask) then TBGRADefaultBitmap(result).FXorMask := self.XorMask.RotateCW; 5379 5788 end; 5380 5789 … … 5403 5812 end; 5404 5813 end; 5814 5815 if Assigned(XorMask) then TBGRADefaultBitmap(result).FXorMask := self.XorMask.RotateCCW; 5405 5816 end; 5406 5817 … … 5549 5960 end; 5550 5961 InvalidateBitmap; 5962 end; 5963 5964 function TBGRADefaultBitmap.GetMaskFromAlpha: TBGRACustomBitmap; 5965 var y,x: integer; 5966 psrc, pdest: PBGRAPixel; 5967 begin 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; 5551 5980 end; 5552 5981 … … 5963 6392 end; 5964 6393 5965 function TBGRAPtrBitmap.Duplicate(DuplicateProperties: Boolean = False ): TBGRACustomBitmap;6394 function TBGRAPtrBitmap.Duplicate(DuplicateProperties: Boolean = False; DuplicateXorMask: Boolean = False): TBGRACustomBitmap; 5966 6395 begin 5967 6396 Result := NewBitmap(Width, Height); 5968 6397 if DuplicateProperties then CopyPropertiesTo(TBGRADefaultBitmap(Result)); 6398 if DuplicateXorMask and Assigned(XorMask) then 6399 TBGRADefaultBitmap(Result).FXorMask := FXorMask.Duplicate(True); 5969 6400 end; 5970 6401 … … 6007 6438 end; 6008 6439 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;6440 procedure TBGRAPtrBitmap.LoadFromDevice(DC: HDC); 6441 begin 6442 NotImplemented; 6443 end; 6444 6445 procedure TBGRAPtrBitmap.LoadFromDevice(DC: HDC; ARect: TRect); 6446 begin 6447 NotImplemented; 6017 6448 end; 6018 6449 -
GraphicTest/Packages/bgrabitmap/bgradithering.pas
r494 r521 78 78 procedure SetTransparentColorIndex(AValue: integer); 79 79 public 80 constructor Create(APalette: TBGRACustomApproxPalette; AIgnoreAlpha: boolean; ABitsPerPixelForIndices: integer); //use platform byte order81 constructor Create(APalette: TBGRACustomApproxPalette; AIgnoreAlpha: boolean; ABitsPerPixelForIndices: integer; AByteOrder: TRawImageByteOrder); //maybe necessary if larger than 8 bits per pixel80 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 82 82 83 83 function DitherImage(AAlgorithm: TDitheringAlgorithm; AImage: TBGRACustomBitmap): Pointer; overload; //use minimum scanline size -
GraphicTest/Packages/bgrabitmap/bgradnetdeserial.pas
r494 r521 63 63 FContainer: TDotNetDeserialization; 64 64 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; 67 67 function GetFieldCount: longword; virtual; abstract; 68 68 function GetFieldName(Index: longword): string; virtual; abstract; … … 147 147 function FindObject(typeName: string): TCustomSerializedObject; 148 148 function GetSimpleField(obj: TCustomSerializedObject; Name: string): string; 149 function GetObjectField(obj: TCustomSerializedObject; Name: string): TCustomSerializedObject; 150 function GetObjectField(obj: TCustomSerializedObject; index: integer): TCustomSerializedObject; 151 function GetObject(id: string): TCustomSerializedObject; 152 function GetObject(id: longword): TCustomSerializedObject; 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; 153 153 function IsBoxedValue(obj: TCustomSerializedObject; index: integer): boolean; 154 154 function GetBoxedValue(obj: TCustomSerializedObject; index: integer): string; -
GraphicTest/Packages/bgrabitmap/bgrafillinfo.pas
r494 r521 111 111 public 112 112 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); 114 114 function SegmentsCurved: boolean; override; 115 115 function GetBounds: TRect; override; … … 129 129 var inter: ArrayOfTIntersectionInfo; var nbInter: integer); override; 130 130 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); 132 132 function GetBounds: TRect; override; 133 133 function SegmentsCurved: boolean; override; … … 161 161 function NbMaxIntersection: integer; override; 162 162 procedure SetIntersectionValues(AInter: TIntersectionInfo; AInterX: Single; AWinding, ANumSegment: integer; {%H-}dy: single; {%H-}AData: pointer); virtual; 163 procedure InitPoints(const points: array of TPointF); 163 164 public 164 constructor Create(const points: array of TPointF );165 constructor Create(const points: array of TPointF; APixelCenteredCoordinates: boolean = true); 165 166 function CreateSegmentData(numPt,nextPt: integer; x,y: single): pointer; virtual; 166 167 procedure FreeSegmentData(data: pointer); virtual; … … 180 181 var inter: ArrayOfTIntersectionInfo; var nbInter: integer); override; 181 182 public 182 constructor Create(const points: array of TPointF );183 constructor Create(const points: array of TPointF; APixelCenteredCoordinates: boolean = true); 183 184 destructor Destroy; override; 184 185 function GetSliceIndex: integer; override; … … 216 217 var inter: ArrayOfTIntersectionInfo; var nbInter: integer); override; 217 218 public 218 constructor Create(const points: array of TPointF );219 constructor Create(const points: array of TPointF; APixelCenteredCoordinates: boolean = true); 219 220 function CreateIntersectionArray: ArrayOfTIntersectionInfo; override; 220 221 function GetSliceIndex: integer; override; … … 454 455 procedure TFillShapeInfo.SortIntersection(var inter: ArrayOfTIntersectionInfo; nbInter: integer); 455 456 var 456 i,j : Integer;457 i,j,k: Integer; 457 458 tempInter: TIntersectionInfo; 458 459 begin … … 460 461 begin 461 462 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; 468 470 end; 469 471 end; … … 482 484 if (windingSum = 0) xor (prevSum = 0) then 483 485 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; 487 492 inc(nbAlternate); 488 493 end; … … 628 633 { TCustomFillPolyInfo } 629 634 630 constructor TCustomFillPolyInfo.Create(const points: array of TPointF );635 constructor TCustomFillPolyInfo.Create(const points: array of TPointF; APixelCenteredCoordinates: boolean); 631 636 var 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 639 begin 640 InitPoints(points); 665 641 666 642 //look for empty points, correct coordinate and successors … … 669 645 670 646 cur := -1; 671 First := -1;647 first := -1; 672 648 for i := 0 to high(FPoints) do 673 649 if not isEmptyPointF(FPoints[i]) then 674 650 begin 675 651 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; 678 657 if cur <> -1 then 679 658 FNext[cur] := i; 680 if First = -1 then681 First := i;659 if first = -1 then 660 first := i; 682 661 cur := i; 683 662 end 684 663 else 685 664 begin 686 if ( First <> -1) and (cur <> First) then687 FNext[cur] := First;665 if (first <> -1) and (cur <> first) then 666 FNext[cur] := first; 688 667 689 668 FEmptyPt[i] := True; 690 669 FNext[i] := -1; 691 670 cur := -1; 692 First := -1;693 end; 694 if ( First <> -1) and (cur <> First) then695 FNext[cur] := First;671 first := -1; 672 end; 673 if (first <> -1) and (cur <> first) then 674 FNext[cur] := first; 696 675 697 676 setlength(FPrev, length(FPoints)); … … 779 758 end; 780 759 760 procedure TCustomFillPolyInfo.InitPoints(const points: array of TPointF); 761 const 762 minDist = 0.00390625; //1 over 256 763 764 var 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 791 begin 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); 817 end; 818 781 819 { TFillPolyInfo } 782 820 … … 807 845 end; 808 846 809 constructor TFillPolyInfo.Create(const points: array of TPointF );847 constructor TFillPolyInfo.Create(const points: array of TPointF; APixelCenteredCoordinates: boolean); 810 848 function AddSeg(numSlice: integer): integer; 811 849 begin … … 824 862 825 863 begin 826 inherited Create(points );864 inherited Create(points, APixelCenteredCoordinates); 827 865 828 866 //slice … … 1042 1080 end; 1043 1081 1044 constructor TOnePassFillPolyInfo.Create(const points: array of TPointF );1082 constructor TOnePassFillPolyInfo.Create(const points: array of TPointF; APixelCenteredCoordinates: boolean); 1045 1083 var i,j: integer; 1046 1084 p: POnePassRecord; 1047 1085 temp: single; 1048 1086 begin 1049 inherited create(points );1087 inherited create(points, APixelCenteredCoordinates); 1050 1088 1051 1089 FShouldInitializeDrawing := true; … … 1293 1331 { TFillRoundRectangleInfo } 1294 1332 1295 constructor TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry: single; options: TRoundRectangleOptions );1333 constructor TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry: single; options: TRoundRectangleOptions; APixelCenteredCoordinates: boolean); 1296 1334 var 1297 1335 temp: Single; … … 1309 1347 x2 := temp; 1310 1348 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; 1315 1362 FRX := abs(rx); 1316 1363 FRY := abs(ry); … … 1422 1469 { TFillBorderRoundRectInfo } 1423 1470 1424 constructor TFillBorderRoundRectInfo.Create(x1, y1, x2, y2, rx, ry, w: single; options: TRoundRectangleOptions );1471 constructor TFillBorderRoundRectInfo.Create(x1, y1, x2, y2, rx, ry, w: single; options: TRoundRectangleOptions; APixelCenteredCoordinates: boolean); 1425 1472 var rdiff: single; 1426 1473 temp: Single; … … 1446 1493 if 2*ry > y2-y1 then ry := (y2-y1)/2; 1447 1494 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); 1449 1496 if (abs(x2-x1) > w) and (abs(y2-y1) > w) then 1450 1497 begin 1451 1498 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) 1453 1500 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); 1455 1502 FInnerBorder.WindingFactor := -1; 1456 1503 end -
GraphicTest/Packages/bgrabitmap/bgrafilterblur.pas
r494 r521 32 32 public 33 33 constructor Create(bmp: TBGRACustomBitmap; ABounds: TRect; radius: single; 34 blurType: TRadialBlurType); 34 blurType: TRadialBlurType); overload; 35 35 constructor Create(bmp: TBGRACustomBitmap; ABounds: TRect; radiusX,radiusY: single; 36 blurType: TRadialBlurType); 36 blurType: TRadialBlurType); overload; 37 37 protected 38 38 procedure DoExecute; override; … … 57 57 58 58 procedure FilterBlur(bmp: TBGRACustomBitmap; ABounds: TRect; 59 blurMask: TBGRACustomBitmap; ADestination: TBGRACustomBitmap; ACheckShouldStop: TCheckShouldStopFunc); forward; 59 blurMask: TBGRACustomBitmap; ADestination: TBGRACustomBitmap; ACheckShouldStop: TCheckShouldStopFunc); forward; overload; 60 60 procedure 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; 62 62 procedure 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; 64 64 65 65 type … … 71 71 FRadiusX,FRadiusY: single; 72 72 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; 75 75 protected 76 76 {$IFNDEF CPU64} … … 310 310 311 311 procedure FilterBlurRadial(bmp: TBGRACustomBitmap; ABounds: TRect; radius: single; 312 blurType: TRadialBlurType; ADestination: TBGRACustomBitmap; ACheckShouldStop: TCheckShouldStopFunc); 312 blurType: TRadialBlurType; ADestination: TBGRACustomBitmap; ACheckShouldStop: TCheckShouldStopFunc); overload; 313 313 begin 314 314 if radius = 0 then … … 347 347 end; 348 348 349 function FilterBlurRadial(bmp: TBGRACustomBitmap; radius: single; 350 blurType: TRadialBlurType): TBGRACustomBitmap; 349 function FilterBlurRadial(bmp: TBGRACustomBitmap; radius: single; blurType: TRadialBlurType): TBGRACustomBitmap; overload; 351 350 begin 352 351 if blurType = rbBox then … … 361 360 362 361 function FilterBlurRadial(bmp: TBGRACustomBitmap; radiusX: single; 363 radiusY: single; blurType: TRadialBlurType): TBGRACustomBitmap; 362 radiusY: single; blurType: TRadialBlurType): TBGRACustomBitmap; overload; 364 363 begin 365 364 if blurType = rbBox then … … 374 373 375 374 function CreateRadialBlurTask(ABmp: TBGRACustomBitmap; ABounds: TRect; ARadius: single; 376 ABlurType: TRadialBlurType): TFilterTask; 375 ABlurType: TRadialBlurType): TFilterTask; overload; 377 376 begin 378 377 if ABlurType = rbBox then … … 383 382 384 383 function CreateRadialBlurTask(ABmp: TBGRACustomBitmap; ABounds: TRect; 385 ARadiusX, ARadiusY: single; ABlurType: TRadialBlurType): TFilterTask; 384 ARadiusX, ARadiusY: single; ABlurType: TRadialBlurType): TFilterTask; overload; 386 385 begin 387 386 if ABlurType = rbBox then … … 432 431 433 432 function FilterBlurMotion(bmp: TBGRACustomBitmap; distance: single; 434 angle: single; oriented: boolean): TBGRACustomBitmap; 433 angle: single; oriented: boolean): TBGRACustomBitmap; overload; 435 434 begin 436 435 result := bmp.NewBitmap(bmp.Width,bmp.Height); … … 463 462 end; 464 463 465 function FilterBlur(bmp: TBGRACustomBitmap; blurMask: TBGRACustomBitmap): TBGRACustomBitmap; 464 function FilterBlur(bmp: TBGRACustomBitmap; blurMask: TBGRACustomBitmap): TBGRACustomBitmap; overload; 466 465 begin 467 466 result := bmp.NewBitmap(bmp.Width,bmp.Height); -
GraphicTest/Packages/bgrabitmap/bgrafilters.pas
r494 r521 29 29 30 30 { Grayscale converts colored pixel into grayscale with same luminosity } 31 function FilterGrayscale(bmp: TBGRACustomBitmap): TBGRACustomBitmap; 32 function FilterGrayscale(bmp: TBGRACustomBitmap; ABounds: TRect): TBGRACustomBitmap; 31 function FilterGrayscale(bmp: TBGRACustomBitmap): TBGRACustomBitmap; overload; 32 function FilterGrayscale(bmp: TBGRACustomBitmap; ABounds: TRect): TBGRACustomBitmap; overload; 33 33 function CreateGrayscaleTask(bmp: TBGRACustomBitmap; ABounds: TRect): TFilterTask; 34 34 … … 36 36 and light colors lightest possible } 37 37 function FilterNormalize(bmp: TBGRACustomBitmap; 38 eachChannel: boolean = True): TBGRACustomBitmap; 38 eachChannel: boolean = True): TBGRACustomBitmap; overload; 39 39 function FilterNormalize(bmp: TBGRACustomBitmap; ABounds: TRect; 40 eachChannel: boolean = True): TBGRACustomBitmap; 40 eachChannel: boolean = True): TBGRACustomBitmap; overload; 41 41 42 42 ////////////////////// 3X3 FILTERS //////////////////////////////////////////// 43 43 44 44 { 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; 45 function FilterSharpen(bmp: TBGRACustomBitmap; AAmount: integer = 256): TBGRACustomBitmap; overload; 46 function FilterSharpen(bmp: TBGRACustomBitmap; ABounds: TRect; AAmount: integer = 256): TBGRACustomBitmap; overload; 47 47 48 48 { Compute a contour, as if the image was drawn with a 2 pixels-wide black pencil } … … 50 50 51 51 { 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; 52 function FilterEmboss(bmp: TBGRACustomBitmap; angle: single; AStrength: integer= 64; AOptions: TEmbossOptions = []): TBGRACustomBitmap; overload; 53 function FilterEmboss(bmp: TBGRACustomBitmap; angle: single; ABounds: TRect; AStrength: integer= 64; AOptions: TEmbossOptions = []): TBGRACustomBitmap; overload; 54 54 55 55 { Emboss highlight computes a sort of emboss with 45 degrees angle and … … 72 72 73 73 { 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; 74 function FilterTwirl(bmp: TBGRACustomBitmap; ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap; overload; 75 function FilterTwirl(bmp: TBGRACustomBitmap; ABounds: TRect; ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap; overload; 76 76 77 77 { Distort the image as if it were on a vertical cylinder } … … 91 91 with rbFast blur, the optimization entails an hyperbolic shape. } 92 92 type 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; 93 function FilterBlurRadial(bmp: TBGRACustomBitmap; radius: single; blurType: TRadialBlurType): TBGRACustomBitmap; overload; 94 function FilterBlurRadial(bmp: TBGRACustomBitmap; radiusX: single; radiusY: single; blurType: TRadialBlurType): TBGRACustomBitmap; overload; 95 function CreateRadialBlurTask(ABmp: TBGRACustomBitmap; ABounds: TRect; ARadius: single; ABlurType: TRadialBlurType): TRadialBlurTask; overload; 96 function CreateRadialBlurTask(ABmp: TBGRACustomBitmap; ABounds: TRect; ARadiusX,ARadiusY: single; ABlurType: TRadialBlurType): TRadialBlurTask; overload; 97 97 98 98 { The precise blur allow to specify the blur radius with subpixel accuracy } -
GraphicTest/Packages/bgrabitmap/bgrafilterscanner.pas
r494 r521 61 61 ADest: PBGRAPixel; ACount: integer); override; 62 62 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; 65 65 property SourceBorderColor: TBGRAPixel read FSourceBorderColor write FSourceBorderColor; 66 66 property DestinationBorderColor: TBGRAPixel read FDestinationBorderColor write FDestinationBorderColor; … … 79 79 public 80 80 constructor Create(ASource: IBGRAScanner; ABounds: TRect; 81 AGammaCorrection: boolean = False); 81 AGammaCorrection: boolean = False); overload; 82 82 constructor Create(ASource: TBGRACustomBitmap; 83 AGammaCorrection: boolean = False); 83 AGammaCorrection: boolean = False); overload; 84 84 property Opacity: Byte read FOpacity write FOpacity; 85 85 end; … … 93 93 public 94 94 constructor Create(ASource: IBGRAScanner; ABounds: TRect; 95 AAmount: integer = 256); 95 AAmount: integer = 256); overload; 96 96 constructor Create(ASource: TBGRACustomBitmap; 97 AAmount: integer = 256); 97 AAmount: integer = 256); overload; 98 98 end; 99 99 … … 108 108 procedure SetSourceChannel(AValue: TChannel); 109 109 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; 112 112 property FillSelection: boolean read FFillSelection write FFillSelection; 113 113 property SourceChannel: TChannel read FSourceChannel write SetSourceChannel; … … 138 138 highlight: TBGRAPixel; 139 139 begin 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)^); 143 146 sum := 128 - sum div 3; 144 147 if sum > 255 then … … 711 714 begin 712 715 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)); 714 717 Inc(ADest); 715 718 dec(ACount); … … 738 741 ADest^ := BGRAPixelTransparent 739 742 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)); 741 744 inc(ASource); 742 745 Inc(ADest); -
GraphicTest/Packages/bgrabitmap/bgrafontgl.pas
r494 r521 107 107 function CreateGlyph(AIdentifier: string): TRenderedGlyph; virtual; 108 108 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); over ride;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; 111 111 procedure DoTextRect(X, Y, Width, Height: Single; const Text : UTF8String; AColor: TBGRAPixel); override; 112 112 function GetClipped: boolean; override; -
GraphicTest/Packages/bgrabitmap/bgrafpguibitmap.pas
r494 r521 46 46 procedure TakeScreenshot({%H-}ARect: TRect); override; //not available 47 47 procedure TakeScreenshotOfPrimaryMonitor; override; //not available 48 procedure LoadFromDevice({%H-}DC: System.THandle); override; //not available49 procedure LoadFromDevice({%H-}DC: System.THandle; {%H-}ARect: TRect); override; //not available48 procedure LoadFromDevice({%H-}DC: HDC); override; //not available 49 procedure LoadFromDevice({%H-}DC: HDC; {%H-}ARect: TRect); override; //not available 50 50 property BitmapTransparent: boolean read GetBitmapTransparent write SetBitmapTransparent; 51 51 property Canvas: TBGRACanvas read GetPseudoCanvas; … … 254 254 end; 255 255 256 procedure TBGRAfpGUIBitmap.LoadFromDevice(DC: System.THandle);257 begin 258 NotAvailable; 259 end; 260 261 procedure TBGRAfpGUIBitmap.LoadFromDevice(DC: System.THandle; ARect: TRect);256 procedure TBGRAfpGUIBitmap.LoadFromDevice(DC: HDC); 257 begin 258 NotAvailable; 259 end; 260 261 procedure TBGRAfpGUIBitmap.LoadFromDevice(DC: HDC; ARect: TRect); 262 262 begin 263 263 NotAvailable; -
GraphicTest/Packages/bgrabitmap/bgrafreetype.pas
r494 r521 51 51 procedure UpdateFont; 52 52 procedure Init; 53 procedure TextOutAnglePatch(ADest: TBGRACustomBitmap; x, y: single; orientation: integer; s: string; 54 c: TBGRAPixel; tex: IBGRAScanner; align: TAlignment); 53 55 public 54 56 FontHinted: boolean; … … 66 68 OutlineTexture: IBGRAScanner; 67 69 68 constructor Create; 69 constructor Create(AShader: TCustomPhongShading; AShaderOwner: boolean); 70 constructor Create; overload; 71 constructor Create(AShader: TCustomPhongShading; AShaderOwner: boolean); overload; 70 72 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; 78 82 destructor Destroy; override; 79 83 property Collection: TCustomFreeTypeFontCollection read GetCollection; … … 112 116 113 117 constructor Create(ADestination: TBGRACustomBitmap); 114 procedure DrawText(AText: string; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TFPColor); over ride; overload;118 procedure DrawText(AText: string; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TFPColor); overload; override; 115 119 procedure DrawText(AText: string; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TBGRAPixel); overload; 116 120 procedure DrawText(AText: string; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TBGRAPixel; AAlign: TFreeTypeAlignments); overload; … … 122 126 {$ENDIF} 123 127 {$IFDEF BGRABITMAP_USE_LCL15} 124 procedure DrawGlyph(AGlyph: integer; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TFPColor); over ride; overload;128 procedure DrawGlyph(AGlyph: integer; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TFPColor); overload; override; 125 129 procedure DrawGlyph(AGlyph: integer; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TBGRAPixel); overload; 126 130 procedure DrawGlyph(AGlyph: integer; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TBGRAPixel; AAlign: TFreeTypeAlignments); overload; … … 133 137 implementation 134 138 135 uses BGRABlend, Math ;139 uses BGRABlend, Math, BGRATransform; 136 140 137 141 { TBGRAFreeTypeFontRenderer } … … 242 246 end; 243 247 248 procedure TBGRAFreeTypeFontRenderer.TextOutAnglePatch(ADest: TBGRACustomBitmap; 249 x, y: single; orientation: integer; s: string; c: TBGRAPixel; 250 tex: IBGRAScanner; align: TAlignment); 251 const orientationToDeg = -0.1; 252 var 253 temp: TBGRACustomBitmap; 254 coord: TPointF; 255 angleDeg: single; 256 OldOrientation: integer; 257 filter: TResampleFilter; 258 OldFontQuality: TBGRAFontQuality; 259 begin 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; 294 end; 295 244 296 constructor TBGRAFreeTypeFontRenderer.Create; 245 297 begin … … 269 321 y: single; orientation: integer; s: string; c: TBGRAPixel; align: TAlignment); 270 322 begin 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); 327 const orientationToDeg = -0.1; 328 var 329 temp: TBGRABitmap; 330 coord: TPointF; 331 angleDeg: single; 332 begin 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; 351 end; } 271 352 272 353 end; … … 276 357 align: TAlignment); 277 358 begin 278 359 TextOutAnglePatch(ADest, x,y, orientation, s, BGRAPixelTransparent, texture, align); 279 360 end; 280 361 … … 368 449 result.cx := round(FFont.TextWidth(s)); 369 450 result.cy := round(FFont.LineFullHeight); 451 end; 452 453 function TBGRAFreeTypeFontRenderer.TextSize(sUTF8: string; AMaxWidth: integer; 454 ARightToLeft: boolean): TSize; 455 var 456 remains: string; 457 w,h,totalH: single; 458 begin 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); 472 end; 473 474 function TBGRAFreeTypeFontRenderer.TextFitInfo(sUTF8: string; AMaxWidth: integer): integer; 475 var 476 remains: string; 477 begin 478 UpdateFont; 479 FFont.SplitText(sUTF8, AMaxWidth, remains); 480 result := length(sUTF8); 370 481 end; 371 482 -
GraphicTest/Packages/bgrabitmap/bgragifformat.pas
r494 r521 72 72 AspectRatio: single; 73 73 BackgroundColor: TColor; 74 LoopCount: Word; 74 75 Images: array of TGifSubImage; 75 76 end; … … 89 90 GIFExtensionIntroducer = $21; 90 91 GIFBlockTerminator = $00; 92 GIFFileTerminator = $3B; 91 93 92 94 GIFGraphicControlExtension_TransparentFlag = $01; //transparent color index is provided … … 104 106 GIFCodeTableSize = 4096; 105 107 108 NetscapeApplicationIdentifier = 'NETSCAPE2.0'; 109 NetscapeSubBlockIdLoopCount = 1; 110 NetscapeSubBlockIdBuffering = 2; 111 106 112 function CeilLn2(AValue: Integer): integer; 107 113 function BGRAToPackedRgbTriple(color: TBGRAPixel): TPackedRGBTriple; 108 114 function PackedRgbTribleToBGRA(rgb: TPackedRGBTriple): TBGRAPixel; 109 function GIFLoadFromStream(stream: TStream ): TGIFData;115 function GIFLoadFromStream(stream: TStream; MaxImageCount: integer = maxLongint): TGIFData; 110 116 procedure GIFSaveToStream(AData: TGifData; Stream: TStream; AQuantizerFactory: TBGRAColorQuantizerAny; 111 117 ADitheringAlgorithm: TDitheringAlgorithm); … … 117 123 //Adapted from the work of Udo Schmal, http://www.gocher.me/FPWriteGIF 118 124 procedure GIFEncodeLZW(AStream: TStream; AImageData: PByte; 119 AImageWidth, AImageHeight: integer; ABitDepth: integer);125 AImageWidth, AImageHeight: integer; ABitDepth: byte); 120 126 121 127 implementation … … 224 230 if (bytinbuf = 0) then 225 231 begin 226 AStream.Read(bytinbuf, 1); 232 if AStream.Read(bytinbuf, 1) <> 1 then 233 raise exception.Create('Unexpected end of stream'); 234 227 235 if (bytinbuf = 0) then 236 begin 228 237 endofsrc := True; 238 result := endcode; 239 exit; 240 end; 229 241 AStream.Read(bytbuf, bytinbuf); 230 242 bytbufidx := 0; … … 238 250 bitbuf := bitbuf shr codelen; 239 251 Dec(bitsinbuf, codelen); 252 //write(inttostr(result)+'@'+inttostr(codelen)+' '); 240 253 end; 241 254 … … 278 291 if interlaced then 279 292 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 282 297 Inc(pass); 283 298 ycnt := GIFInterlacedStart[pass]; 284 299 ystep := GIFInterlacedStep[pass]; 285 300 end; 286 end ;301 end else exit; 287 302 end; 288 303 … … 346 361 InitStringTable; 347 362 curcode := getnextcode; 363 //Write('Reading '); 348 364 while (curcode <> endcode) and (pass < 5) and not endofsrc do 349 365 begin … … 370 386 begin 371 387 if (curcode > stridx) then 388 begin 389 //write('!Invalid! '); 372 390 break; 391 end; 373 392 AddStr2Tab(Code2Str(oldcode), firstchar(Code2Str(oldcode))); 374 393 WriteStr(Code2Str(stridx - 1)); … … 379 398 end; 380 399 DoneStringTable; 400 //Writeln; 381 401 if not endofsrc then 382 402 begin 383 403 bytinbuf:= 0; 384 AStream.Read (bytinbuf, 1);404 AStream.ReadBuffer(bytinbuf, 1); 385 405 if bytinbuf <> 0 then 386 406 raise exception.Create('Invalid GIF format: expecting block terminator'); … … 391 411 //Adapted from the work of Udo Schmal, http://www.gocher.me/FPWriteGIF 392 412 procedure GIFEncodeLZW(AStream: TStream; AImageData: PByte; 393 AImageWidth, AImageHeight: integer; ABitDepth: integer); 413 AImageWidth, AImageHeight: integer; ABitDepth: byte); 414 415 var //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 425 var // 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 446 type TCode = Word; 447 394 448 var 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 485 type 486 PCodeTableEntry = ^TCodeTableEntry; 487 TCodeTableEntry = packed record 488 Prefix: TCode; 489 LongerFirst, LongerLast: TCode; 490 Suffix, Padding: Byte; 491 NextWithPrefix: TCode; 492 end; 493 494 var 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 520 var 521 CurValue: Byte; 522 i: TCode; 523 found: boolean; // decoded string in prefix table? 524 begin 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 419 548 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 421 555 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 496 562 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; 501 599 end; 502 600 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); 504 609 end; 505 610 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; 614 617 end; 615 618 616 function GIFLoadFromStream(stream: TStream ): TGIFData;619 function GIFLoadFromStream(stream: TStream; MaxImageCount: integer = maxLongint): TGIFData; 617 620 618 621 procedure DumpData; … … 625 628 stream.position := stream.position + Count; 626 629 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)); 627 640 end; 628 641 … … 715 728 GIFExtensionBlock: TGIFExtensionBlock; 716 729 GIFGraphicControlExtension: TGIFGraphicControlExtension; 717 mincount, Count: byte; 730 mincount, Count, SubBlockId: byte; 731 app: String; 718 732 719 733 begin 720 734 stream.ReadBuffer({%H-}GIFExtensionBlock, sizeof(GIFExtensionBlock)); 721 735 case GIFExtensionBlock.FunctionCode of 722 $F9: 736 $F9: //graphic control extension 723 737 begin 724 738 Count := 0; … … 745 759 DumpData; 746 760 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 747 787 else 748 788 begin … … 758 798 result.Images := nil; 759 799 result.AspectRatio := 1; 800 result.LoopCount := 1; 760 801 if stream = nil then exit; 761 802 … … 790 831 case GIFBlockID of 791 832 ';': ; 792 ',': LoadImage; 833 ',': begin 834 if NbImages >= MaxImageCount then break; 835 LoadImage; 836 end; 793 837 '!': ReadExtension; 794 838 else … … 1009 1053 for x := 0 to Image.Width -1 do 1010 1054 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)); 1012 1059 inc(psource); 1013 1060 inc(pdest); … … 1087 1134 for i := 0 to ImageCount-1 do 1088 1135 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); 1089 1160 end; 1090 1161 … … 1106 1177 WriteGlobalPalette; 1107 1178 1179 WriteLoopExtension; 1180 1108 1181 WriteImages; 1109 Stream.WriteByte( $3B); //end of file1182 Stream.WriteByte(GIFFileTerminator); //end of file 1110 1183 1111 1184 finally -
GraphicTest/Packages/bgrabitmap/bgragradients.pas
r494 r521 29 29 function nGradientInfo(StartColor, StopColor: TBGRAPixel; Direction: TGradientDirection; EndPercent: Single): TnGradientInfo; 30 30 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); 31 function nGradientAlphaFill(ARect: TRect; ADir: TGradientDirection; const AGradient: array of TnGradientInfo): TBGRABitmap; overload; 32 function nGradientAlphaFill(AWidth, AHeight: Integer; ADir: TGradientDirection; const AGradient: array of TnGradientInfo): TBGRABitmap; overload; 33 procedure nGradientAlphaFill(ACanvas: TCanvas; ARect: TRect; ADir: TGradientDirection; const AGradient: array of TnGradientInfo); overload; 34 procedure nGradientAlphaFill(ABitmap: TBGRABitmap; ARect: TRect; ADir: TGradientDirection; const AGradient: array of TnGradientInfo); overload; 35 35 36 36 function 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; 38 38 function 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; 40 40 procedure 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; 42 42 procedure 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; 44 44 45 45 {----------------------------------------------------------------------} … … 155 155 { Create a precise height map for a rectangle height map with a border (not grayscale anymore but more precise) } 156 156 function CreateRectanglePreciseMap(width,height,border: integer; options: TRectangleMapOptions = []): TBGRABitmap; 157 function CreateRectanglePreciseMap(width, height, borderWidth, borderHeight: integer; options: TRectangleMapOptions): TBGRABitmap; 157 158 158 159 { Create a round rectangle height map with a border } … … 161 162 { Create a precise height map for a round rectangle height map with a border (not grayscale anymore but more precise) } 162 163 function CreateRoundRectanglePreciseMap(width,height,border: integer; options: TRectangleMapOptions = []): TBGRABitmap; 164 function CreateRoundRectanglePreciseMap(width,height,borderWidth,borderHeight: integer; options: TRectangleMapOptions = []): TBGRABitmap; 163 165 164 166 {---------- Perlin Noise -------------} … … 177 179 implementation 178 180 179 uses Types, SysUtils{$IFDEF BGRABITMAP_USE_LCL}, BGRATextFX{$ENDIF}; {GraphType unit used by phongdraw.inc}181 uses Types, Math, SysUtils{$IFDEF BGRABITMAP_USE_LCL}, BGRATextFX{$ENDIF}; {GraphType unit used by phongdraw.inc} 180 182 181 183 {$IFDEF BGRABITMAP_USE_LCL}function TextShadow(AWidth, AHeight: Integer; AText: String; … … 767 769 end; 768 770 771 procedure MapBorderLimit(width,height: integer; options: TRectangleMapOptions; var borderHoriz,borderVert: integer); 772 var maxHoriz,maxVert: integer; 773 begin 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; 783 end; 784 769 785 function CreateSpherePreciseMap(width, height: integer): TBGRABitmap; 770 786 var cx,cy,rx,ry,d: single; … … 898 914 if rmoLinearBorder in options then h := h/border else 899 915 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); 924 end; 925 926 function CreateRectanglePreciseMap(width, height, borderWidth, borderHeight: integer; 927 options: TRectangleMapOptions): TBGRABitmap; 928 var xb,yb, minBorder: integer; 929 p: PBGRAPixel; 930 h: single; 931 smallStep: single; 932 begin 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); 900 964 901 965 p^ := MapHeightToBGRA(h,255); … … 1090 1154 end; 1091 1155 1156 function CreateRoundRectanglePreciseMap(width, height, borderWidth, 1157 borderHeight: integer; options: TRectangleMapOptions): TBGRABitmap; 1158 var d: single; 1159 xb,yb: integer; 1160 p: PBGRAPixel; 1161 h,smallStep,factor: single; 1162 minBorder: integer; 1163 begin 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; 1207 end; 1208 1092 1209 initialization 1093 1210 -
GraphicTest/Packages/bgrabitmap/bgragradientscanner.pas
r494 r521 11 11 12 12 type 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 17 20 FColor1,FColor2: TBGRAPixel; 18 21 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; 19 27 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; 21 30 function GetColorAt(position: integer): TBGRAPixel; override; 22 31 function GetColorAtF(position: single): TBGRAPixel; override; … … 24 33 function GetExpandedColorAtF(position: single): TExpandedPixel; override; 25 34 function GetAverageColor: TBGRAPixel; override; 26 function GetMonochrome: boolean; override;27 end;28 29 { TBGRASimpleGradientWithGammaCorrection }30 31 TBGRASimpleGradientWithGammaCorrection = class(TBGRACustomGradient)32 private33 FColor1,FColor2: TBGRAPixel;34 ec1,ec2: TExpandedPixel;35 public36 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;42 35 function GetAverageExpandedColor: TExpandedPixel; override; 43 36 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 47 65 THueGradientOptions = set of THueGradientOption; 48 66 49 67 { TBGRAHueGradient } 50 68 51 TBGRAHueGradient = class(TBGRA CustomGradient)69 TBGRAHueGradient = class(TBGRASimpleGradient) 52 70 private 53 FColor1,FColor2: TBGRAPixel;54 ec1,ec2: TExpandedPixel;55 71 hsla1,hsla2: THSLAPixel; 56 72 hue1,hue2: longword; 57 73 FOptions: THueGradientOptions; 58 74 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; 60 79 public 61 80 constructor Create(Color1,Color2: TBGRAPixel; options: THueGradientOptions); overload; 81 constructor Create(Color1,Color2: TExpandedPixel; options: THueGradientOptions); overload; 62 82 constructor Create(Color1,Color2: THSLAPixel; options: THueGradientOptions); overload; 63 83 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;70 84 function GetMonochrome: boolean; override; 71 85 end; … … 96 110 end; 97 111 112 TBGRAGradientScannerInternalScanNextFunc = function():single of object; 113 TBGRAGradientScannerInternalScanAtFunc = function(const p: TPointF):single of object; 114 98 115 { TBGRAGradientScanner } 99 116 … … 101 118 protected 102 119 FGradientType: TGradientType; 103 FOrigin1,FOrigin2: TPointF; 120 FOrigin,FDir1,FDir2: TPointF; 121 FRelativeFocal: TPointF; 122 FRadius, FFocalRadius: single; 123 FTransform, FHiddenTransform: TAffineMatrix; 104 124 FSinus: Boolean; 105 u: TPointF;106 len,aFactor,aFactorF: single;107 mergedColor: TBGRAPixel;108 mergedExpandedColor: TExpandedPixel;109 125 FGradient: TBGRACustomGradient; 110 126 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; 111 140 FHorizColor: TBGRAPixel; 112 141 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 117 169 function ScanNextInline: TBGRAPixel; inline; 118 170 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; 119 175 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; 123 195 destructor Destroy; override; 124 196 procedure ScanMoveTo(X, Y: Integer); override; … … 129 201 procedure ScanPutPixels(pdest: PBGRAPixel; count: integer; mode: TDrawMode); override; 130 202 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; 131 207 end; 132 208 … … 143 219 FOpacity: byte; 144 220 FGrayscale: boolean; 221 FRandomBuffer, FRandomBufferCount: integer; 145 222 public 146 223 constructor Create(AGrayscale: Boolean; AOpacity: byte); … … 213 290 private 214 291 FTexture: IBGRAScanner; 292 FOwnedScanner: TBGRACustomScanner; 215 293 FGlobalOpacity: Byte; 216 294 FScanNext : TScanNextPixelFunction; … … 219 297 public 220 298 constructor Create(ATexture: IBGRAScanner; AGlobalOpacity: Byte = 255); 299 constructor Create(ATexture: TBGRACustomScanner; AGlobalOpacity: Byte; AOwned: boolean); 221 300 destructor Destroy; override; 222 301 function IsScanPutPixelsDefined: boolean; override; … … 231 310 uses BGRABlend, Math; 232 311 312 { TBGRASimpleGradient } 313 314 constructor TBGRASimpleGradient.Create(AColor1, AColor2: TBGRAPixel; ARepetition: TBGRAGradientRepetition); 315 begin 316 FColor1 := AColor1; 317 FColor2 := AColor2; 318 ec1 := GammaExpansion(AColor1); 319 ec2 := GammaExpansion(AColor2); 320 FRepetition:= ARepetition; 321 end; 322 323 constructor TBGRASimpleGradient.Create(AColor1, AColor2: TExpandedPixel; 324 ARepetition: TBGRAGradientRepetition); 325 begin 326 FColor1 := GammaCompression(AColor1); 327 FColor2 := GammaCompression(AColor2); 328 ec1 := AColor1; 329 ec2 := AColor2; 330 FRepetition:= ARepetition; 331 end; 332 333 class function TBGRASimpleGradient.CreateAny(AInterpolation: TBGRAColorInterpolation; 334 AColor1, AColor2: TBGRAPixel; ARepetition: TBGRAGradientRepetition): TBGRASimpleGradient; 335 begin 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; 345 end; 346 347 class function TBGRASimpleGradient.CreateAny(AInterpolation: TBGRAColorInterpolation; 348 AColor1, AColor2: TExpandedPixel; ARepetition: TBGRAGradientRepetition): TBGRASimpleGradient; 349 begin 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; 359 end; 360 361 function TBGRASimpleGradient.GetAverageColor: TBGRAPixel; 362 begin 363 result := InterpolateToBGRA(32768); 364 end; 365 366 function TBGRASimpleGradient.GetAverageExpandedColor: TExpandedPixel; 367 begin 368 Result:= InterpolateToExpanded(32768); 369 end; 370 371 function TBGRASimpleGradient.GetColorAt(position: integer): TBGRAPixel; 372 begin 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; 404 end; 405 406 function TBGRASimpleGradient.GetColorAtF(position: single): TBGRAPixel; 407 begin 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; 417 end; 418 419 function TBGRASimpleGradient.GetExpandedColorAt(position: integer 420 ): TExpandedPixel; 421 begin 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; 453 end; 454 455 function TBGRASimpleGradient.GetExpandedColorAtF(position: single 456 ): TExpandedPixel; 457 begin 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; 467 end; 468 469 function TBGRASimpleGradient.GetMonochrome: boolean; 470 begin 471 Result:= (FColor1 = FColor2); 472 end; 473 233 474 { TBGRAConstantScanner } 234 475 … … 244 485 FGrayscale:= AGrayscale; 245 486 FOpacity:= AOpacity; 487 FRandomBufferCount := 0; 246 488 end; 247 489 … … 252 494 253 495 function TBGRARandomScanner.ScanNextPixel: TBGRAPixel; 496 var rgb: integer; 254 497 begin 255 498 if FGrayscale then 256 499 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; 258 508 result.green := result.red; 259 509 result.blue := result.red; 260 510 result.alpha:= FOpacity; 261 511 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; 263 516 end; 264 517 … … 272 525 procedure TBGRAHueGradient.Init(c1, c2: THSLAPixel; AOptions: THueGradientOptions); 273 526 begin 274 FColor1 := HSLAToBGRA(c1);275 FColor2 := HSLAToBGRA(c2);276 ec1 := GammaExpansion(FColor1);277 ec2 := GammaExpansion(FColor2);278 527 FOptions:= AOptions; 279 528 if (hgoLightnessCorrection in AOptions) then 280 529 begin 281 hsla1 := BGRAToGSBA(FColor1);282 hsla2 := BGRAToGSBA(FColor2);530 hsla1 := ExpandedToGSBA(ec1); 531 hsla2 := ExpandedToGSBA(ec2); 283 532 end else 284 533 begin … … 305 554 end; 306 555 307 function TBGRAHueGradient. GetColorNoBoundCheck(position: integer): THSLAPixel;556 function TBGRAHueGradient.InterpolateToHSLA(position: word): THSLAPixel; 308 557 var b,b2: LongWord; 309 558 begin … … 325 574 end; 326 575 576 function TBGRAHueGradient.InterpolateToBGRA(position: word): TBGRAPixel; 577 begin 578 if hgoLightnessCorrection in FOptions then 579 result := GSBAToBGRA(InterpolateToHSLA(position)) 580 else 581 result := HSLAToBGRA(InterpolateToHSLA(position)); 582 end; 583 584 function TBGRAHueGradient.InterpolateToExpanded(position: word): TExpandedPixel; 585 begin 586 if hgoLightnessCorrection in FOptions then 587 result := GSBAToExpanded(InterpolateToHSLA(position)) 588 else 589 result := HSLAToExpanded(InterpolateToHSLA(position)); 590 end; 591 327 592 constructor TBGRAHueGradient.Create(Color1, Color2: TBGRAPixel;options: THueGradientOptions); 328 593 begin 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 329 601 Init(BGRAToHSLA(Color1),BGRAToHSLA(Color2),options); 330 602 end; 331 603 604 constructor TBGRAHueGradient.Create(Color1, Color2: TExpandedPixel; 605 options: THueGradientOptions); 606 begin 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); 615 end; 616 332 617 constructor TBGRAHueGradient.Create(Color1, Color2: THSLAPixel; options: THueGradientOptions); 333 618 begin 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 334 626 Init(Color1,Color2, options); 335 627 end; … … 338 630 Lightness: Word; options: THueGradientOptions); 339 631 begin 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); 475 633 end; 476 634 … … 670 828 { TBGRASimpleGradientWithGammaCorrection } 671 829 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 830 function TBGRASimpleGradientWithGammaCorrection.InterpolateToBGRA(position: word 682 831 ): TBGRAPixel; 683 832 var b,b2: cardinal; 684 833 ec: TExpandedPixel; 685 834 begin 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); 842 end; 843 844 function TBGRASimpleGradientWithGammaCorrection.InterpolateToExpanded( 845 position: word): TExpandedPixel; 702 846 var 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; 847 begin 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; 854 end; 855 856 constructor TBGRASimpleGradientWithGammaCorrection.Create(Color1, 857 Color2: TBGRAPixel; ARepetition: TBGRAGradientRepetition); 858 begin 859 inherited Create(Color1,Color2,ARepetition); 860 end; 861 862 constructor TBGRASimpleGradientWithGammaCorrection.Create(Color1, 863 Color2: TExpandedPixel; ARepetition: TBGRAGradientRepetition); 864 begin 865 inherited Create(Color1,Color2,ARepetition); 866 end; 867 868 { TBGRASimpleGradientWithoutGammaCorrection } 869 870 function TBGRASimpleGradientWithoutGammaCorrection.InterpolateToBGRA( 871 position: word): TBGRAPixel; 727 872 var b,b2: cardinal; 728 873 begin 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; 880 end; 881 882 function TBGRASimpleGradientWithoutGammaCorrection.InterpolateToExpanded( 883 position: word): TExpandedPixel; 811 884 var b,b2: cardinal; 812 885 rw,gw,bw: word; 813 886 begin 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 825 896 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 826 901 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 827 906 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; 909 end; 910 911 constructor TBGRASimpleGradientWithoutGammaCorrection.Create(Color1, 912 Color2: TBGRAPixel; ARepetition: TBGRAGradientRepetition); 913 begin 914 inherited Create(Color1,Color2,ARepetition); 915 end; 916 917 constructor TBGRASimpleGradientWithoutGammaCorrection.Create(Color1, 918 Color2: TExpandedPixel; ARepetition: TBGRAGradientRepetition); 919 begin 920 inherited Create(Color1,Color2,ARepetition); 850 921 end; 851 922 … … 946 1017 { TBGRAGradientScanner } 947 1018 948 procedure TBGRAGradientScanner.Init(gtype: TGradientType; o1, o2: TPointF; 949 Sinus: Boolean); 950 begin 951 FGradientType:= gtype; 952 FOrigin1 := o1; 953 FOrigin2 := o2; 1019 procedure TBGRAGradientScanner.SetTransform(AValue: TAffineMatrix); 1020 begin 1021 if FTransform=AValue then Exit; 1022 FTransform:=AValue; 1023 InitTransform; 1024 end; 1025 1026 constructor TBGRAGradientScanner.Create(AGradientType: TGradientType; AOrigin, d1: TPointF); 1027 begin 1028 FGradient := nil; 1029 SetGradient(BGRABlack,BGRAWhite,False); 1030 Init(AGradientType,AOrigin,d1,AffineMatrixIdentity,False); 1031 end; 1032 1033 constructor TBGRAGradientScanner.Create(AGradientType: TGradientType; AOrigin, d1,d2: TPointF); 1034 begin 1035 FGradient := nil; 1036 SetGradient(BGRABlack,BGRAWhite,False); 1037 Init(AGradientType,AOrigin,d1,d2,AffineMatrixIdentity,False); 1038 end; 1039 1040 constructor TBGRAGradientScanner.Create(AOrigin, 1041 d1, d2, AFocal: TPointF; ARadiusRatio: single; AFocalRadiusRatio: single); 1042 var 1043 m, mInv: TAffineMatrix; 1044 focalInv: TPointF; 1045 begin 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); 1059 end; 1060 1061 constructor TBGRAGradientScanner.Create(AOrigin: TPointF; ARadius: single; 1062 AFocal: TPointF; AFocalRadius: single); 1063 begin 1064 FGradient := nil; 1065 SetGradient(BGRABlack,BGRAWhite,False); 1066 1067 Init(AOrigin, ARadius, AFocal, AFocalRadius, AffineMatrixIdentity, AffineMatrixIdentity); 1068 end; 1069 1070 procedure TBGRAGradientScanner.SetFlipGradient(AValue: boolean); 1071 begin 1072 if FFlipGradient=AValue then Exit; 1073 FFlipGradient:=AValue; 1074 end; 1075 1076 function TBGRAGradientScanner.GetGradientColor(a: single): TBGRAPixel; 1077 begin 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; 1093 end; 1094 1095 function TBGRAGradientScanner.GetGradientExpandedColor(a: single): TExpandedPixel; 1096 begin 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; 1112 end; 1113 1114 procedure TBGRAGradientScanner.Init(AGradientType: TGradientType; AOrigin, d1: TPointF; 1115 ATransform: TAffineMatrix; Sinus: Boolean); 1116 var d2: TPointF; 1117 begin 1118 with (d1-AOrigin) do 1119 d2 := PointF(AOrigin.x+y,AOrigin.y-x); 1120 Init(AGradientType,AOrigin,d1,d2,ATransform,Sinus); 1121 end; 1122 1123 procedure TBGRAGradientScanner.Init(AGradientType: TGradientType; AOrigin, d1, d2: TPointF; 1124 ATransform: TAffineMatrix; Sinus: Boolean); 1125 begin 1126 FGradientType:= AGradientType; 1127 FFlipGradient:= false; 1128 FOrigin := AOrigin; 1129 FDir1 := d1; 1130 FDir2 := d2; 954 1131 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; 1141 end; 1142 1143 procedure TBGRAGradientScanner.Init(AOrigin: TPointF; ARadius: single; 1144 AFocal: TPointF; AFocalRadius: single; ATransform: TAffineMatrix; AHiddenTransform: TAffineMatrix); 1145 var maxRadius: single; 1146 begin 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; 1165 end; 1166 1167 procedure TBGRAGradientScanner.InitGradientType; 1168 begin 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 995 1179 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; 999 1189 end else 1000 1190 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; 1006 1221 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; 1030 1225 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; 1054 1230 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; 1232 end; 1233 1234 procedure TBGRAGradientScanner.SetGradient(c1, c2: TBGRAPixel; 1235 AGammaCorrection: boolean); 1236 begin 1237 if Assigned(FGradient) and FGradientOwner then FreeAndNil(FGradient); 1238 1087 1239 //transparent pixels have no color so 1088 1240 //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; 1250 end; 1251 1252 procedure TBGRAGradientScanner.SetGradient(AGradient: TBGRACustomGradient; 1253 AOwner: boolean); 1254 begin 1255 if Assigned(FGradient) and FGradientOwner then FreeAndNil(FGradient); 1256 FGradient := AGradient; 1257 FGradientOwner := AOwner; 1258 InitGradient; 1259 end; 1260 1261 procedure TBGRAGradientScanner.InitTransform; 1262 var u,v: TPointF; 1263 begin 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; 1107 1276 end else 1108 1277 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); 1300 end; 1301 1302 procedure TBGRAGradientScanner.InitGradient; 1303 begin 1304 FAverageColor := FGradient.GetAverageColor; 1305 FAverageExpandedColor := FGradient.GetAverageExpandedColor; 1306 end; 1307 1308 function TBGRAGradientScanner.ComputeRadialFocal(const p: TPointF): single; 1309 var 1310 w1,w2,h,d1,d2,delta,num: single; 1311 begin 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; 1331 end; 1332 1333 function TBGRAGradientScanner.ScanNextLinear: single; 1334 begin 1335 result := FPosition.x; 1336 end; 1337 1338 function TBGRAGradientScanner.ScanNextReflected: single; 1339 begin 1340 result := abs(FPosition.x); 1341 end; 1342 1343 function TBGRAGradientScanner.ScanNextDiamond: single; 1344 begin 1345 result := max(abs(FPosition.x), abs(FPosition.y)); 1346 end; 1347 1348 function TBGRAGradientScanner.ScanNextRadial: single; 1349 begin 1350 result := sqrt(sqr(FPosition.x) + sqr(FPosition.y)); 1351 end; 1352 1353 function TBGRAGradientScanner.ScanNextRadial2: single; 1354 begin 1355 result := (sqrt(sqr(FPosition.x) + sqr(FPosition.y))-FFocalRadius)/(FRadius-FFocalRadius); 1356 end; 1357 1358 function TBGRAGradientScanner.ScanNextRadialFocal: single; 1359 begin 1360 result := ComputeRadialFocal(FPosition); 1361 end; 1362 1363 function TBGRAGradientScanner.ScanNextAngular: single; 1364 begin 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) 1369 end; 1370 1371 function TBGRAGradientScanner.ScanAtLinear(const p: TPointF): single; 1372 begin 1373 with (FMatrix*p) do 1374 result := x; 1375 end; 1376 1377 function TBGRAGradientScanner.ScanAtReflected(const p: TPointF): single; 1378 begin 1379 with (FMatrix*p) do 1380 result := abs(x); 1381 end; 1382 1383 function TBGRAGradientScanner.ScanAtDiamond(const p: TPointF): single; 1384 begin 1385 with (FMatrix*p) do 1386 result := max(abs(x), abs(y)); 1387 end; 1388 1389 function TBGRAGradientScanner.ScanAtRadial(const p: TPointF): single; 1390 begin 1391 with (FMatrix*p) do 1392 result := sqrt(sqr(x) + sqr(y)); 1393 end; 1394 1395 function TBGRAGradientScanner.ScanAtRadial2(const p: TPointF): single; 1396 begin 1397 with (FMatrix*p) do 1398 result := (sqrt(sqr(x) + sqr(y))-FFocalRadius)/(FRadius-FFocalRadius); 1399 end; 1400 1401 function TBGRAGradientScanner.ScanAtRadialFocal(const p: TPointF): single; 1402 begin 1403 result := ComputeRadialFocal(FMatrix*p); 1404 end; 1405 1406 function TBGRAGradientScanner.ScanAtAngular(const p: TPointF): single; 1407 begin 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; 1415 end; 1416 1417 function TBGRAGradientScanner.ScanNextInline: TBGRAPixel; 1418 begin 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; 1426 end; 1427 1428 function TBGRAGradientScanner.ScanNextExpandedInline: TExpandedPixel; 1429 begin 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; 1437 end; 1438 1439 constructor TBGRAGradientScanner.Create(c1, c2: TBGRAPixel; 1440 AGradientType: TGradientType; AOrigin, d1: TPointF; gammaColorCorrection: boolean; 1441 Sinus: Boolean); 1442 begin 1443 FGradient := nil; 1444 SetGradient(c1,c2,gammaColorCorrection); 1445 Init(AGradientType,AOrigin,d1,AffineMatrixIdentity,Sinus); 1446 end; 1447 1448 constructor TBGRAGradientScanner.Create(c1, c2: TBGRAPixel; 1449 AGradientType: TGradientType; AOrigin, d1, d2: TPointF; gammaColorCorrection: boolean; 1450 Sinus: Boolean); 1451 begin 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); 1113 1456 end; 1114 1457 1115 1458 constructor 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); 1117 1460 begin 1118 1461 FGradient := gradient; 1119 1462 FGradientOwner := AGradientOwner; 1120 Init(gtype,o1,o2,Sinus); 1463 Init(AGradientType,AOrigin,d1,AffineMatrixIdentity,Sinus); 1464 end; 1465 1466 constructor TBGRAGradientScanner.Create(gradient: TBGRACustomGradient; 1467 AGradientType: TGradientType; AOrigin, d1, d2: TPointF; Sinus: Boolean; 1468 AGradientOwner: Boolean); 1469 begin 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); 1474 end; 1475 1476 constructor TBGRAGradientScanner.Create(gradient: TBGRACustomGradient; 1477 AOrigin: TPointF; ARadius: single; AFocal: TPointF; AFocalRadius: single; 1478 AGradientOwner: Boolean); 1479 begin 1480 FGradient := gradient; 1481 FGradientOwner := AGradientOwner; 1482 Init(AOrigin, ARadius, AFocal, AFocalRadius, AffineMatrixIdentity, AffineMatrixIdentity); 1121 1483 end; 1122 1484 … … 1130 1492 procedure TBGRAGradientScanner.ScanMoveTo(X, Y: Integer); 1131 1493 begin 1132 InitScanInline(X,Y);1133 if F Verticalthen1494 FPosition := FMatrix*PointF(x,y); 1495 if FRepeatHoriz then 1134 1496 begin 1135 1497 FHorizColor := ScanNextInline; … … 1140 1502 function TBGRAGradientScanner.ScanNextPixel: TBGRAPixel; 1141 1503 begin 1142 if F Verticalthen1504 if FRepeatHoriz then 1143 1505 result := FHorizColor 1144 1506 else … … 1148 1510 function TBGRAGradientScanner.ScanNextExpandedPixel: TExpandedPixel; 1149 1511 begin 1150 if F Verticalthen1512 if FRepeatHoriz then 1151 1513 result := FHorizExpandedColor 1152 1514 else … … 1155 1517 1156 1518 function 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); 1519 begin 1520 if FIsAverage then 1521 result := FAverageColor 1522 else 1523 result := GetGradientColor(FScanAtFunc(PointF(X,Y))); 1193 1524 end; 1194 1525 1195 1526 function 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); 1527 begin 1528 if FIsAverage then 1529 result := FAverageExpandedColor 1530 else 1531 result := GetGradientExpandedColor(FScanAtFunc(PointF(X,Y))); 1232 1532 end; 1233 1533 … … 1236 1536 var c: TBGRAPixel; 1237 1537 begin 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; 1242 1541 case mode of 1243 1542 dmDrawWithTransparency: DrawPixelsInline(pdest,c,count); … … 1573 1872 FScanAt := @FTexture.ScanAt; 1574 1873 FGlobalOpacity:= AGlobalOpacity; 1874 FOwnedScanner := nil; 1875 end; 1876 1877 constructor TBGRAOpacityScanner.Create(ATexture: TBGRACustomScanner; 1878 AGlobalOpacity: Byte; AOwned: boolean); 1879 begin 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; 1575 1888 end; 1576 1889 … … 1578 1891 begin 1579 1892 fillchar(FTexture,sizeof(FTexture),0); 1893 FOwnedScanner.Free; 1580 1894 inherited Destroy; 1581 1895 end; -
GraphicTest/Packages/bgrabitmap/bgragrayscalemask.pas
r494 r521 36 36 end; 37 37 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); 38 procedure DownSamplePutImageGrayscale(sourceData: PByte; sourcePixelSize: NativeInt; sourceRowDelta: NativeInt; sourceWidth, sourceHeight: NativeInt; dest: TGrayscaleMask; ADestRect: TRect); overload; 39 procedure DownSamplePutImageGrayscale(source: TBGRACustomBitmap; dest: TGrayscaleMask; ADestRect: TRect); overload; 40 40 41 41 procedure BGRAFillClearTypeGrayscaleMask(dest: TBGRACustomBitmap; x, -
GraphicTest/Packages/bgrabitmap/bgragtkbitmap.pas
r494 r521 38 38 FPixBuf: Pointer; 39 39 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); 41 42 protected 42 43 procedure ReallocData; override; … … 46 47 AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); 47 48 override; 49 procedure DrawPart(ARect: TRect; ACanvas: TCanvas; x, y: integer; Opaque: boolean); override; 48 50 procedure Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean = True); override; 49 51 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; 52 56 procedure GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer); override; 53 57 end; … … 55 59 implementation 56 60 57 uses BGRABitmapTypes, BGRADefaultBitmap, LCLType,61 uses BGRABitmapTypes, BGRADefaultBitmap, BGRAFilterScanner, LCLType, 58 62 LCLIntf, IntfGraphics, 59 63 {$IFDEF LCLgtk2} … … 64 68 {$ENDIF} 65 69 FPImage, Dialogs; 66 67 {$IFDEF LCLgtk2}68 type TGtkDeviceContext = TGtk2DeviceContext;69 {$ENDIF}70 70 71 71 procedure TBGRAGtkBitmap.ReallocData; … … 116 116 end; 117 117 118 LoadFromBitmapIfNeeded; 119 118 120 If not TBGRAPixel_RGBAOrder then SwapRedBlue; 119 121 … … 130 132 end; 131 133 132 procedure TBGRAGtkBitmap.DrawOpaque(ACanvas: TCanvas; Rect: TRect); 133 begin 134 DataDrawOpaque(ACanvas,Rect,Data,LineOrder,Width,Height); 134 procedure TBGRAGtkBitmap.DrawOpaque(ACanvas: TCanvas; ARect: TRect; 135 ASourceRect: TRect); 136 begin 137 DataDrawOpaque(ACanvas,ARect,Data,LineOrder,Width,Height); 138 end; 139 140 procedure TBGRAGtkBitmap.DrawOpaque(ACanvas: TCanvas; ARect: TRect); 141 begin 142 DrawOpaque(ACanvas, ARect, rect(0,0,Width,Height)); 135 143 end; 136 144 … … 166 174 end; 167 175 176 procedure TBGRAGtkBitmap.DrawPart(ARect: TRect; ACanvas: TCanvas; x, 177 y: integer; Opaque: boolean); 178 var 179 rowStride,w,h: Integer; 180 begin 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); 193 end; 194 168 195 procedure TBGRAGtkBitmap.Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean); 169 196 begin … … 186 213 end; 187 214 188 procedure TBGRAGtkBitmap.DataDrawOpaque(ACanvas: TCanvas; Rect: TRect;215 procedure TBGRAGtkBitmap.DataDrawOpaque(ACanvas: TCanvas; ARect: TRect; 189 216 AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); 190 var ptr: TBGRAPtrBitmap; 217 var 218 rowStride: Integer; 219 firstRow: Pointer; 220 begin 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); 233 end; 234 235 procedure 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; 191 255 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); 219 271 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); 221 273 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 276 var 277 temp: integer; 278 pos: TPoint; 279 dest: HDC; 280 281 begin 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; 236 314 end; 237 315 -
GraphicTest/Packages/bgrabitmap/bgralayers.pas
r494 r521 2 2 3 3 {$mode objfpc}{$H+} 4 {$MODESWITCH ADVANCEDRECORDS} 4 5 5 6 interface 6 7 7 8 uses 8 BGRAGraphics, Classes, SysUtils, Types, BGRABitmapTypes, BGRABitmap; 9 BGRAGraphics, Classes, SysUtils, Types, BGRABitmapTypes, BGRABitmap, 10 BGRAMemDirectory, BGRATransform, fgl, BGRALayerOriginal; 9 11 10 12 type … … 12 14 TBGRACustomLayeredBitmapClass = class of TBGRACustomLayeredBitmap; 13 15 16 { TBGRALayerOriginalEntry } 17 18 TBGRALayerOriginalEntry = record 19 Guid: TGuid; 20 Instance: TBGRALayerCustomOriginal; 21 class operator = (const AEntry1,AEntry2: TBGRALayerOriginalEntry): boolean; 22 end; 23 24 function BGRALayerOriginalEntry(AGuid: TGuid): TBGRALayerOriginalEntry; 25 function BGRALayerOriginalEntry(AInstance: TBGRALayerCustomOriginal): TBGRALayerOriginalEntry; 26 27 type 28 TBGRALayerOriginalList = specialize TFPGList<TBGRALayerOriginalEntry>; 29 14 30 TBGRALayeredBitmap = class; 15 31 TBGRALayeredBitmapClass = class of TBGRALayeredBitmap; 16 32 17 33 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); 19 37 20 38 { TBGRACustomLayeredBitmap } … … 28 46 end; 29 47 FLinearBlend: boolean; 48 FMemDirectory: TMemDirectory; 49 FMemDirectoryOwned: boolean; 30 50 function GetDefaultBlendingOperation: TBlendOperation; 51 function GetHasMemFiles: boolean; 31 52 function GetLinearBlend: boolean; 32 53 procedure SetLinearBlend(AValue: boolean); … … 34 55 protected 35 56 function GetNbLayers: integer; virtual; abstract; 57 function GetMemDirectory: TMemDirectory; 36 58 function GetBlendOperation(Layer: integer): TBlendOperation; virtual; abstract; 37 59 function GetLayerVisible(layer: integer): boolean; virtual; abstract; … … 42 64 function GetLayerFrozen(layer: integer): boolean; virtual; 43 65 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 44 85 procedure SetLayerFrozen(layer: integer; AValue: boolean); virtual; 45 86 function RangeIntersect(first1,last1,first2,last2: integer): boolean; 46 87 procedure RemoveFrozenRange(index: integer); 47 88 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;53 89 54 90 public 55 91 procedure SaveToFile(const filenameUTF8: string); override; 56 92 procedure SaveToStream(Stream: TStream); override; 93 procedure SaveToStreamAs(Stream: TStream; AExtension: string); 57 94 constructor Create; override; 58 95 destructor Destroy; override; … … 60 97 function GetLayerBitmapDirectly(layer: integer): TBGRABitmap; virtual; 61 98 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; 66 103 procedure Draw(ACanvas: TCanvas; const Rect: TRect); override; overload; 67 104 procedure Draw(Canvas: TCanvas; x,y: integer); overload; 68 105 procedure Draw(Canvas: TCanvas; x,y: integer; firstLayer, lastLayer: integer); overload; 69 106 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; 71 109 72 110 procedure FreezeExceptOneLayer(layer: integer); overload; … … 76 114 procedure Unfreeze(layer: integer); overload; 77 115 procedure Unfreeze(firstLayer, lastLayer: integer); overload; 116 117 procedure NotifyLoaded; virtual; 118 procedure NotifySaving; virtual; 78 119 79 120 property NbLayers: integer read GetNbLayers; … … 85 126 property LayerFrozen[layer: integer]: boolean read GetLayerFrozen; 86 127 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; 87 133 property LinearBlend: boolean read GetLinearBlend write SetLinearBlend; //use linear blending unless specified 88 134 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; 90 142 91 143 TBGRALayerInfo = record … … 99 151 Owner: boolean; 100 152 Frozen: boolean; 153 OriginalMatrix: TAffineMatrix; 154 OriginalRenderStatus: TOriginalRenderStatus; 155 OriginalGuid: TGuid; 156 OriginalInvalidatedBounds: TRectF; 101 157 end; 102 158 … … 107 163 FNbLayers: integer; 108 164 FLayers: array of TBGRALayerInfo; 165 FOriginalChange: TEmbeddedOriginalChangeEvent; 166 FOriginalEditingChange: TEmbeddedOriginalEditingChangeEvent; 109 167 FWidth,FHeight: integer; 168 FOriginals: TBGRALayerOriginalList; 169 FOriginalEditor: TBGRAOriginalEditor; 170 FOriginalEditorOriginal: TBGRALayerCustomOriginal; 171 FOriginalEditorViewMatrix: TAffineMatrix; 172 function GetOriginalGuid(AIndex: integer): TGUID; 110 173 111 174 protected … … 119 182 function GetLayerName(layer: integer): string; override; 120 183 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; 121 193 procedure SetBlendOperation(Layer: integer; op: TBlendOperation); 122 194 procedure SetLayerVisible(layer: integer; AValue: boolean); … … 125 197 procedure SetLayerName(layer: integer; AValue: string); 126 198 procedure SetLayerFrozen(layer: integer; AValue: boolean); override; 127 function GetLayerUniqueId(layer: integer): integer; override;128 199 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); 129 210 130 211 public 131 212 procedure LoadFromFile(const filenameUTF8: string); override; 132 213 procedure LoadFromStream(stream: TStream); override; 214 procedure LoadFromResource(AFilename: string); 133 215 procedure SetSize(AWidth, AHeight: integer); virtual; 134 216 procedure Clear; override; 217 procedure ClearOriginals; 135 218 procedure RemoveLayer(index: integer); 136 219 procedure InsertLayer(index: integer; fromIndex: integer); … … 138 221 function MoveLayerUp(index: integer): integer; 139 222 function MoveLayerDown(index: integer): integer; 223 140 224 function AddLayer(Source: TBGRABitmap; Opacity: byte = 255): integer; overload; 141 225 function AddLayer(Source: TBGRABitmap; Position: TPoint; BlendOp: TBlendOperation; Opacity: byte = 255; Shared: boolean = false): integer; overload; … … 158 242 function AddOwnedLayer(ABitmap: TBGRABitmap; Position: TPoint; Opacity: byte = 255): integer; overload; 159 243 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 160 268 destructor Destroy; override; 161 constructor Create; over ride; overload;162 constructor Create(AWidth, AHeight: integer); virtual; overload;269 constructor Create; overload; override; 270 constructor Create(AWidth, AHeight: integer); overload; virtual; 163 271 function GetLayerBitmapDirectly(layer: integer): TBGRABitmap; override; 164 272 function GetLayerBitmapCopy(layer: integer): TBGRABitmap; override; … … 169 277 procedure RotateCW; 170 278 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; 173 283 procedure Resample(AWidth, AHeight: integer; AResampleMode: TResampleMode; AFineResampleFilter: TResampleFilter = rfLinear); 174 284 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); 175 302 176 303 property Width : integer read GetWidth; … … 184 311 property LayerOffset[layer: integer]: TPoint read GetLayerOffset write SetLayerOffset; 185 312 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; 187 331 188 332 procedure RegisterLayeredBitmapWriter(AExtensionUTF8: string; AWriter: TBGRALayeredBitmapClass); 189 333 procedure RegisterLayeredBitmapReader(AExtensionUTF8: string; AReader: TBGRACustomLayeredBitmapClass); 334 function TryCreateLayeredBitmapWriter(AExtensionUTF8: string): TBGRALayeredBitmap; 335 function TryCreateLayeredBitmapReader(AExtensionUTF8: string): TBGRACustomLayeredBitmap; 190 336 191 337 var 192 338 LayeredBitmapSaveToStreamProc : TBGRALayeredBitmapSaveToStreamProc; 193 339 LayeredBitmapLoadFromStreamProc : TBGRALayeredBitmapLoadFromStreamProc; 340 LayeredBitmapCheckStreamProc: TBGRALayeredBitmapCheckStreamProc; 194 341 195 342 type … … 209 356 implementation 210 357 211 uses BGRAUTF8; 358 uses BGRAUTF8, BGRABlend, BGRAMultiFileType, math; 359 360 const 361 OriginalsDirectory = 'originals'; 212 362 213 363 var … … 227 377 end; 228 378 379 { TBGRALayerOriginalEntry } 380 381 class operator TBGRALayerOriginalEntry.=(const AEntry1, 382 AEntry2: TBGRALayerOriginalEntry): boolean; 383 begin 384 result := AEntry1.Guid = AEntry2.Guid; 385 end; 386 387 function BGRALayerOriginalEntry(AGuid: TGuid): TBGRALayerOriginalEntry; 388 begin 389 result.Guid := AGuid; 390 result.Instance := nil; 391 end; 392 393 function BGRALayerOriginalEntry(AInstance: TBGRALayerCustomOriginal): TBGRALayerOriginalEntry; 394 begin 395 result.Guid := AInstance.Guid; 396 result.Instance := AInstance; 397 end; 398 229 399 { TBGRALayeredBitmap } 230 400 … … 237 407 end; 238 408 409 function TBGRALayeredBitmap.GetLayerOriginal(layer: integer): TBGRALayerCustomOriginal; 410 var 411 idxOrig: Integer; 412 begin 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; 422 end; 423 424 function TBGRALayeredBitmap.GetLayerOriginalMatrix(layer: integer 425 ): TAffineMatrix; 426 begin 427 if (layer < 0) or (layer >= NbLayers) then 428 raise Exception.Create('Index out of bounds') 429 else 430 result := FLayers[layer].OriginalMatrix; 431 end; 432 433 function TBGRALayeredBitmap.GetLayerOriginalGuid(layer: integer): TGuid; 434 begin 435 if (layer < 0) or (layer >= NbLayers) then 436 raise Exception.Create('Index out of bounds') 437 else 438 result := FLayers[layer].OriginalGuid; 439 end; 440 441 function TBGRALayeredBitmap.GetLayerOriginalRenderStatus(layer: integer 442 ): TOriginalRenderStatus; 443 begin 444 if (layer < 0) or (layer >= NbLayers) then 445 raise Exception.Create('Index out of bounds') 446 else 447 result := FLayers[layer].OriginalRenderStatus; 448 end; 449 239 450 procedure TBGRALayeredBitmap.SetLayerUniqueId(layer: integer; AValue: integer); 240 451 var i: integer; … … 245 456 begin 246 457 for i := 0 to NbLayers-1 do 247 if (i <> layer) and (FLayers[ layer].UniqueId = AValue) then458 if (i <> layer) and (FLayers[i].UniqueId = AValue) then 248 459 raise Exception.Create('Another layer has the same identifier'); 249 460 FLayers[layer].UniqueId := AValue; 250 461 end; 462 end; 463 464 procedure TBGRALayeredBitmap.SetLayerOriginalMatrix(layer: integer; 465 AValue: TAffineMatrix); 466 begin 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; 479 end; 480 481 procedure TBGRALayeredBitmap.SetLayerOriginalGuid(layer: integer; 482 const AValue: TGuid); 483 begin 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; 497 end; 498 499 procedure TBGRALayeredBitmap.SetLayerOriginalRenderStatus(layer: integer; 500 AValue: TOriginalRenderStatus); 501 begin 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; 510 end; 511 512 procedure TBGRALayeredBitmap.FindOriginal(AGuid: TGuid; out 513 ADir: TMemDirectory; out AClass: TBGRALayerOriginalAny); 514 var 515 c: String; 516 begin 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; 529 end; 530 531 procedure TBGRALayeredBitmap.StoreOriginal(AOriginal: TBGRALayerCustomOriginal); 532 var 533 dir, subdir: TMemDirectory; 534 storage: TBGRAMemOriginalStorage; 535 begin 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; 546 end; 547 548 procedure TBGRALayeredBitmap.OriginalChange(ASender: TObject; ABounds: PRectF); 549 var 550 i: Integer; 551 orig: TBGRALayerCustomOriginal; 552 transfBounds: TRectF; 553 begin 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); 584 end; 585 586 procedure TBGRALayeredBitmap.OriginalEditingChange(ASender: TObject); 587 var 588 orig: TBGRALayerCustomOriginal; 589 begin 590 orig := TBGRALayerCustomOriginal(ASender); 591 if Assigned(FOriginalEditingChange) then 592 FOriginalEditingChange(self, orig); 593 end; 594 595 function TBGRALayeredBitmap.GetOriginalCount: integer; 596 begin 597 if Assigned(FOriginals) then 598 result := FOriginals.Count 599 else 600 result := 0; 601 end; 602 603 function TBGRALayeredBitmap.GetOriginalByIndex(AIndex: integer 604 ): TBGRALayerCustomOriginal; 605 var 606 dir: TMemDirectory; 607 c: TBGRALayerOriginalAny; 608 guid: TGuid; 609 storage: TBGRAMemOriginalStorage; 610 begin 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; 638 end; 639 640 function TBGRALayeredBitmap.GetLayerOriginalKnown(layer: integer): boolean; 641 var 642 idxOrig: Integer; 643 begin 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; 653 end; 654 655 function TBGRALayeredBitmap.GetOriginalByIndexKnown(AIndex: integer): boolean; 656 var 657 dir: TMemDirectory; 658 c: TBGRALayerOriginalAny; 659 guid: TGuid; 660 begin 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); 670 end; 671 672 function TBGRALayeredBitmap.GetOriginalGuid(AIndex: integer): TGUID; 673 begin 674 if (AIndex < 0) or (AIndex >= OriginalCount) then 675 raise ERangeError.Create('Index out of bounds'); 676 677 result := FOriginals[AIndex].Guid; 251 678 end; 252 679 … … 374 801 (FLayers[layer].y <> AValue.y) then 375 802 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 376 806 FLayers[layer].x := AValue.x; 377 807 FLayers[layer].y := AValue.y; … … 402 832 end; 403 833 404 function TBGRALayeredBitmap.GetLayerBitmapDirectly(layer: integer 405 ): TBGRABitmap; 834 function TBGRALayeredBitmap.GetLayerBitmapDirectly(layer: integer): TBGRABitmap; 406 835 begin 407 836 if (layer < 0) or (layer >= NbLayers) then 408 837 result := nil 409 838 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); 410 844 Result:= FLayers[layer].Source; 845 end; 411 846 end; 412 847 413 848 procedure TBGRALayeredBitmap.LoadFromFile(const filenameUTF8: string); 414 849 var bmp: TBGRABitmap; 415 index: integer;416 850 ext: string; 417 851 temp: TBGRACustomLayeredBitmap; 418 852 i: integer; 853 stream: TFileStreamUTF8; 419 854 begin 420 855 ext := UTF8LowerCase(ExtractFileExt(filenameUTF8)); … … 432 867 end; 433 868 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; 439 889 end; 440 890 441 891 procedure TBGRALayeredBitmap.LoadFromStream(stream: TStream); 442 892 var bmp: TBGRABitmap; 443 index: integer;444 temp: TBGRALayeredBitmap;445 893 begin 446 894 if Assigned(LayeredBitmapLoadFromStreamProc) then 447 895 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); 453 900 exit; 454 901 end; 455 902 end; 903 456 904 bmp := TBGRABitmap.Create(stream); 457 905 Clear; 458 906 SetSize(bmp.Width,bmp.Height); 459 index := AddSharedLayer(bmp); 460 FLayers[index].Owner:= true; 907 AddOwnedLayer(bmp); 908 end; 909 910 procedure TBGRALayeredBitmap.LoadFromResource(AFilename: string); 911 var 912 stream: TStream; 913 begin 914 stream := BGRAResource.GetResourceStream(AFilename); 915 try 916 LoadFromStream(stream); 917 finally 918 stream.Free; 919 end; 461 920 end; 462 921 … … 474 933 for i := NbLayers-1 downto 0 do 475 934 RemoveLayer(i); 935 MemDirectory := nil; 936 ClearOriginals; 937 end; 938 939 procedure TBGRALayeredBitmap.ClearOriginals; 940 var 941 i: Integer; 942 begin 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; 476 949 end; 477 950 … … 503 976 504 977 procedure TBGRALayeredBitmap.Assign(ASource: TBGRACustomLayeredBitmap; ASharedLayerIds: boolean); 505 var i,idx: integer; 506 begin 978 var 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 986 begin 987 if ASource = nil then 988 raise exception.Create('Unexpected nil reference'); 507 989 Clear; 508 990 SetSize(ASource.Width,ASource.Height); 509 991 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; 510 1024 for i := 0 to ASource.NbLayers-1 do 511 1025 begin … … 514 1028 LayerVisible[idx] := ASource.LayerVisible[i]; 515 1029 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; 517 1038 end; 518 1039 end; … … 581 1102 FLayers[FNbLayers].Frozen := false; 582 1103 FLayers[FNbLayers].UniqueId := ProduceLayerUniqueId; 1104 FLayers[FNbLayers].OriginalMatrix := AffineMatrixIdentity; 1105 FLayers[FNbLayers].OriginalRenderStatus := orsNone; 1106 FLayers[FNbLayers].OriginalGuid := GUID_NULL; 583 1107 if Shared then 584 1108 begin … … 688 1212 end; 689 1213 1214 function TBGRALayeredBitmap.AddLayerFromOriginal(AGuid: TGuid; 1215 Opacity: byte): integer; 1216 begin 1217 result := AddLayerFromOriginal(AGuid, DefaultBlendingOperation, Opacity); 1218 end; 1219 1220 function TBGRALayeredBitmap.AddLayerFromOriginal(AGuid: TGuid; 1221 BlendOp: TBlendOperation; Opacity: byte): integer; 1222 begin 1223 result := AddLayerFromOriginal(AGuid, AffineMatrixIdentity, BlendOp, Opacity); 1224 end; 1225 1226 function TBGRALayeredBitmap.AddLayerFromOriginal(AGuid: TGuid; 1227 Matrix: TAffineMatrix; Opacity: byte): integer; 1228 begin 1229 result := AddLayerFromOriginal(AGuid, Matrix, DefaultBlendingOperation, Opacity); 1230 end; 1231 1232 function TBGRALayeredBitmap.AddLayerFromOriginal(AGuid: TGuid; 1233 Matrix: TAffineMatrix; BlendOp: TBlendOperation; Opacity: byte): integer; 1234 begin 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'); 1240 end; 1241 1242 function TBGRALayeredBitmap.AddLayerFromOwnedOriginal( 1243 AOriginal: TBGRALayerCustomOriginal; Opacity: byte): integer; 1244 begin 1245 if IndexOfOriginal(AOriginal) = -1 then AddOriginal(AOriginal); 1246 result := AddLayerFromOriginal(AOriginal.Guid, Opacity); 1247 end; 1248 1249 function TBGRALayeredBitmap.AddLayerFromOwnedOriginal( 1250 AOriginal: TBGRALayerCustomOriginal; BlendOp: TBlendOperation; Opacity: byte): integer; 1251 begin 1252 if IndexOfOriginal(AOriginal) = -1 then AddOriginal(AOriginal); 1253 result := AddLayerFromOriginal(AOriginal.Guid, BlendOp, Opacity); 1254 end; 1255 1256 function TBGRALayeredBitmap.AddLayerFromOwnedOriginal( 1257 AOriginal: TBGRALayerCustomOriginal; Matrix: TAffineMatrix; Opacity: byte): integer; 1258 begin 1259 if IndexOfOriginal(AOriginal) = -1 then AddOriginal(AOriginal); 1260 result := AddLayerFromOriginal(AOriginal.Guid, Matrix, Opacity); 1261 end; 1262 1263 function TBGRALayeredBitmap.AddLayerFromOwnedOriginal( 1264 AOriginal: TBGRALayerCustomOriginal; Matrix: TAffineMatrix; 1265 BlendOp: TBlendOperation; Opacity: byte): integer; 1266 begin 1267 if IndexOfOriginal(AOriginal) = -1 then AddOriginal(AOriginal); 1268 result := AddLayerFromOriginal(AOriginal.Guid, Matrix, BlendOp, Opacity); 1269 end; 1270 1271 function TBGRALayeredBitmap.AddOriginal(AOriginal: TBGRALayerCustomOriginal; AOwned: boolean): integer; 1272 var 1273 newGuid: TGuid; 1274 begin 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)); 1308 end; 1309 1310 function TBGRALayeredBitmap.AddOriginalFromStream(AStream: TStream; 1311 ALateLoad: boolean): integer; 1312 var 1313 storage: TBGRAMemOriginalStorage; 1314 begin 1315 storage:= TBGRAMemOriginalStorage.Create; 1316 storage.LoadFromStream(AStream); 1317 try 1318 result := AddOriginalFromStorage(storage, ALateLoad); 1319 finally 1320 storage.Free; 1321 end; 1322 end; 1323 1324 function TBGRALayeredBitmap.AddOriginalFromStorage(AStorage: TBGRAMemOriginalStorage; ALateLoad: boolean): integer; 1325 var 1326 origClassName: String; 1327 origClass: TBGRALayerOriginalAny; 1328 orig: TBGRALayerCustomOriginal; 1329 newGuid: TGuid; 1330 dir, subdir: TMemDirectory; 1331 begin 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; 1363 end; 1364 1365 procedure TBGRALayeredBitmap.SaveOriginalToStream(AIndex: integer; 1366 AStream: TStream); 1367 var 1368 dir: TMemDirectory; 1369 c: TBGRALayerOriginalAny; 1370 begin 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; 1383 end; 1384 1385 procedure TBGRALayeredBitmap.SaveOriginalToStream(AGuid: TGUID; AStream: TStream); 1386 var 1387 idxOrig: Integer; 1388 begin 1389 idxOrig := IndexOfOriginal(AGuid); 1390 if idxOrig = -1 then raise exception.Create('Original not found'); 1391 SaveOriginalToStream(idxOrig, AStream); 1392 end; 1393 1394 function TBGRALayeredBitmap.RemoveOriginal(AOriginal: TBGRALayerCustomOriginal): boolean; 1395 var 1396 idx: Integer; 1397 begin 1398 idx := IndexOfOriginal(AOriginal); 1399 if idx = -1 then exit(false); 1400 DeleteOriginal(idx); 1401 result := true; 1402 end; 1403 1404 procedure TBGRALayeredBitmap.DeleteOriginal(AIndex: integer); 1405 var 1406 dir: TMemDirectory; 1407 i: Integer; 1408 guid: TGuid; 1409 begin 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 1426 end; 1427 1428 procedure TBGRALayeredBitmap.NotifyLoaded; 1429 var 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 1448 var 1449 i: Integer; 1450 dir: TMemDirectory; 1451 newGuid: TGUID; 1452 1453 begin 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; 1488 end; 1489 1490 procedure TBGRALayeredBitmap.NotifySaving; 1491 var 1492 i: Integer; 1493 begin 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); 1501 end; 1502 1503 procedure TBGRALayeredBitmap.RenderLayerFromOriginal(layer: integer; 1504 ADraft: boolean; AFullSizeLayer: boolean = false); 1505 begin 1506 RenderLayerFromOriginal(layer, ADraft, rectF(0,0,Width,Height), AFullSizeLayer); 1507 end; 1508 1509 procedure TBGRALayeredBitmap.RenderLayerFromOriginal(layer: integer; 1510 ADraft: boolean; ARenderBounds: TRect; AFullSizeLayer: boolean = false); 1511 var 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 1524 begin 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; 1581 end; 1582 1583 procedure TBGRALayeredBitmap.RenderLayerFromOriginal(layer: integer; 1584 ADraft: boolean; ARenderBoundsF: TRectF; AFullSizeLayer: boolean = false); 1585 var 1586 r: TRect; 1587 begin 1588 with ARenderBoundsF do 1589 r := Rect(floor(Left),floor(Top),ceil(Right),ceil(Bottom)); 1590 RenderLayerFromOriginal(layer, ADraft, r, AFullSizeLayer); 1591 end; 1592 1593 function 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 1608 var 1609 i: Integer; 1610 r: TRect; 1611 1612 begin 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; 1649 end; 1650 1651 procedure TBGRALayeredBitmap.RemoveUnusedOriginals; 1652 var useCount: array of integer; 1653 i, idxOrig: Integer; 1654 begin 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); 1664 end; 1665 690 1666 destructor TBGRALayeredBitmap.Destroy; 691 1667 begin 1668 FOriginalEditor.Free; 692 1669 inherited Destroy; 693 1670 end; … … 699 1676 FHeight := 0; 700 1677 FNbLayers:= 0; 1678 FOriginals := nil; 701 1679 end; 702 1680 … … 745 1723 procedure TBGRALayeredBitmap.RotateCW; 746 1724 var i: integer; 1725 newBmp: TBGRABitmap; 1726 newOfs: TPointF; 1727 m: TAffineMatrix; 747 1728 begin 748 1729 SetSize(Height,Width); //unfreeze 1730 m := AffineMatrixTranslation(Width,0)*AffineMatrixRotationDeg(90); 749 1731 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; 751 1742 end; 752 1743 753 1744 procedure TBGRALayeredBitmap.RotateCCW; 754 1745 var i: integer; 1746 newBmp: TBGRABitmap; 1747 newOfs: TPointF; 1748 m: TAffineMatrix; 755 1749 begin 756 1750 SetSize(Height,Width); //unfreeze 1751 m := AffineMatrixTranslation(0,Height)*AffineMatrixRotationDeg(-90); 757 1752 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; 759 1763 end; 760 1764 … … 764 1768 Unfreeze; 765 1769 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); 1771 end; 1772 1773 procedure TBGRALayeredBitmap.HorizontalFlip(ALayerIndex: integer); 1774 begin 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; 776 1788 end; 777 1789 … … 781 1793 Unfreeze; 782 1794 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); 1796 end; 1797 1798 procedure TBGRALayeredBitmap.VerticalFlip(ALayerIndex: integer); 1799 begin 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; 793 1813 end; 794 1814 795 1815 procedure TBGRALayeredBitmap.Resample(AWidth, AHeight: integer; 796 1816 AResampleMode: TResampleMode; AFineResampleFilter: TResampleFilter); 797 var i : integer;1817 var i, prevWidth, prevHeight: integer; 798 1818 resampled: TBGRABitmap; 799 1819 oldFilter : TResampleFilter; … … 801 1821 if (AWidth < 0) or (AHeight < 0) then 802 1822 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; 803 1827 SetSize(AWidth, AHeight); //unfreeze 804 1828 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 805 1832 begin 806 1833 oldFilter := LayerBitmap[i].ResampleFilter; … … 810 1837 SetLayerBitmap(i, resampled, True); 811 1838 end; 1839 if AResampleMode = rmFineResample then RenderOriginalsIfNecessary; 812 1840 end; 813 1841 … … 824 1852 FLayers[layer].Source := ABitmap; 825 1853 FLayers[layer].Owner := AOwned; 826 end; 1854 FLayers[layer].OriginalGuid := GUID_NULL; 1855 FLayers[layer].OriginalMatrix := AffineMatrixIdentity; 1856 end; 1857 end; 1858 1859 procedure TBGRALayeredBitmap.ApplyLayerOffset(ALayerIndex: integer; 1860 APadWithTranparentPixels: boolean); 1861 var 1862 r: TRect; 1863 newBmp: TBGRABitmap; 1864 begin 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; 1892 end; 1893 1894 function TBGRALayeredBitmap.DrawEditor(ADest: TBGRABitmap; 1895 ALayerIndex: integer; X, Y: Integer; APointSize: single): TRect; 1896 begin 1897 result := DrawEditor(ADest, ALayerIndex, AffineMatrixTranslation(X,Y), APointSize); 1898 end; 1899 1900 function TBGRALayeredBitmap.DrawEditor(ADest: TBGRABitmap; ALayerIndex: integer; 1901 AMatrix: TAffineMatrix; APointSize: single): TRect; 1902 var 1903 orig: TBGRALayerCustomOriginal; 1904 begin 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; 1927 end; 1928 1929 function TBGRALayeredBitmap.GetEditorBounds(ALayerIndex: integer; X, 1930 Y: Integer; APointSize: single): TRect; 1931 begin 1932 result := GetEditorBounds(ALayerIndex, AffineMatrixTranslation(X,Y), APointSize); 1933 end; 1934 1935 function TBGRALayeredBitmap.GetEditorBounds(ADestRect: TRect; 1936 ALayerIndex: integer; X, Y: Integer; APointSize: single): TRect; 1937 begin 1938 result := GetEditorBounds(ADestRect, ALayerIndex, AffineMatrixTranslation(X,Y), APointSize); 1939 end; 1940 1941 function TBGRALayeredBitmap.GetEditorBounds(ALayerIndex: integer; 1942 AMatrix: TAffineMatrix; APointSize: single): TRect; 1943 begin 1944 result := GetEditorBounds(rect(-maxLongint,-maxLongint,maxLongint,maxLongint), ALayerIndex, AMatrix, APointSize); 1945 end; 1946 1947 function TBGRALayeredBitmap.GetEditorBounds(ADestRect: TRect; ALayerIndex: integer; 1948 AMatrix: TAffineMatrix; APointSize: single): TRect; 1949 var 1950 orig: TBGRALayerCustomOriginal; 1951 begin 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; 1976 end; 1977 1978 procedure TBGRALayeredBitmap.MouseMove(Shift: TShiftState; ImageX, ImageY: Single; out 1979 ACursor: TOriginalEditorCursor); 1980 var 1981 handled: boolean; 1982 begin 1983 MouseMove(Shift, ImageX,ImageY, ACursor, handled); 1984 end; 1985 1986 procedure TBGRALayeredBitmap.MouseDown(RightButton: boolean; 1987 Shift: TShiftState; ImageX, ImageY: Single; out ACursor: TOriginalEditorCursor); 1988 var 1989 handled: boolean; 1990 begin 1991 MouseDown(RightButton, Shift, ImageX,ImageY, ACursor, handled); 1992 end; 1993 1994 procedure TBGRALayeredBitmap.MouseUp(RightButton: boolean; Shift: TShiftState; 1995 ImageX, ImageY: Single; out ACursor: TOriginalEditorCursor); 1996 var 1997 handled: boolean; 1998 begin 1999 MouseUp(RightButton, Shift, ImageX,ImageY, ACursor, handled); 2000 end; 2001 2002 procedure TBGRALayeredBitmap.MouseMove(Shift: TShiftState; ImageX, ImageY: Single; out 2003 ACursor: TOriginalEditorCursor; out AHandled: boolean); 2004 var 2005 viewPt: TPointF; 2006 begin 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; 2017 end; 2018 2019 procedure TBGRALayeredBitmap.MouseDown(RightButton: boolean; 2020 Shift: TShiftState; ImageX, ImageY: Single; out ACursor: TOriginalEditorCursor; out 2021 AHandled: boolean); 2022 var 2023 viewPt: TPointF; 2024 begin 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; 2035 end; 2036 2037 procedure TBGRALayeredBitmap.MouseUp(RightButton: boolean; Shift: TShiftState; 2038 ImageX, ImageY: Single; out ACursor: TOriginalEditorCursor; out AHandled: boolean); 2039 var 2040 viewPt: TPointF; 2041 begin 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; 2052 end; 2053 2054 procedure TBGRALayeredBitmap.KeyDown(Shift: TShiftState; Key: TSpecialKey; out 2055 AHandled: boolean); 2056 begin 2057 if Assigned(FOriginalEditor) then 2058 FOriginalEditor.KeyDown(Shift, Key, AHandled) 2059 else 2060 AHandled := false; 2061 end; 2062 2063 procedure TBGRALayeredBitmap.KeyUp(Shift: TShiftState; Key: TSpecialKey; out 2064 AHandled: boolean); 2065 begin 2066 if Assigned(FOriginalEditor) then 2067 FOriginalEditor.KeyUp(Shift, Key, AHandled) 2068 else 2069 AHandled := false; 2070 end; 2071 2072 procedure TBGRALayeredBitmap.KeyPress(UTF8Key: string; out AHandled: boolean); 2073 begin 2074 if Assigned(FOriginalEditor) then 2075 FOriginalEditor.KeyPress(UTF8Key, AHandled) 2076 else 2077 AHandled := false; 2078 end; 2079 2080 function TBGRALayeredBitmap.IndexOfOriginal(AGuid: TGuid): integer; 2081 var 2082 i: Integer; 2083 begin 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 2091 end; 2092 2093 function TBGRALayeredBitmap.IndexOfOriginal(AOriginal: TBGRALayerCustomOriginal): integer; 2094 begin 2095 if Assigned(FOriginals) then 2096 result := FOriginals.IndexOf(BGRALayerOriginalEntry(AOriginal)) 2097 else 2098 result := -1; 827 2099 end; 828 2100 … … 834 2106 end; 835 2107 2108 function TBGRACustomLayeredBitmap.GetMemDirectory: TMemDirectory; 2109 begin 2110 if FMemDirectory = nil then 2111 begin 2112 FMemDirectory:= TMemDirectory.Create; 2113 FMemDirectoryOwned := true; 2114 end; 2115 result := FMemDirectory; 2116 end; 2117 836 2118 function TBGRACustomLayeredBitmap.GetDefaultBlendingOperation: TBlendOperation; 837 2119 begin 838 2120 result := boTransparent; 2121 end; 2122 2123 function TBGRACustomLayeredBitmap.GetHasMemFiles: boolean; 2124 begin 2125 result := assigned(FMemDirectory) and (FMemDirectory.Count > 0); 2126 end; 2127 2128 function TBGRACustomLayeredBitmap.GetLayerOriginalGuid(layer: integer): TGuid; 2129 begin 2130 result := GUID_NULL; 2131 end; 2132 2133 function TBGRACustomLayeredBitmap.GetLayerOriginalRenderStatus(layer: integer): TOriginalRenderStatus; 2134 begin 2135 result := orsProof; 2136 end; 2137 2138 function TBGRACustomLayeredBitmap.GetOriginalCount: integer; 2139 begin 2140 result := 0; 2141 end; 2142 2143 function TBGRACustomLayeredBitmap.GetOriginalByIndex(AIndex: integer): TBGRALayerCustomOriginal; 2144 begin 2145 result := nil; 2146 raise exception.Create('Not implemented'); 2147 end; 2148 2149 function TBGRACustomLayeredBitmap.GetOriginalByIndexKnown(AIndex: integer): boolean; 2150 begin 2151 result := true; 2152 end; 2153 2154 function TBGRACustomLayeredBitmap.GetLayerOriginal(layer: integer): TBGRALayerCustomOriginal; 2155 begin 2156 result := nil; 2157 end; 2158 2159 function TBGRACustomLayeredBitmap.GetLayerOriginalKnown(layer: integer): boolean; 2160 begin 2161 result := true; 2162 end; 2163 2164 function TBGRACustomLayeredBitmap.GetLayerOriginalMatrix(layer: integer): TAffineMatrix; 2165 begin 2166 result := AffineMatrixIdentity; 839 2167 end; 840 2168 … … 843 2171 Unfreeze; 844 2172 FLinearBlend := AValue; 2173 end; 2174 2175 procedure TBGRACustomLayeredBitmap.SetMemDirectory(AValue: TMemDirectory); 2176 begin 2177 if AValue = FMemDirectory then exit; 2178 if FMemDirectoryOwned then FMemDirectory.Free; 2179 FMemDirectory := AValue; 2180 FMemDirectoryOwned := false; 845 2181 end; 846 2182 … … 935 2271 end; 936 2272 2273 function TBGRACustomLayeredBitmap.IndexOfOriginal(AGuid: TGuid): integer; 2274 begin 2275 result := -1; 2276 end; 2277 2278 function TBGRACustomLayeredBitmap.IndexOfOriginal( 2279 AOriginal: TBGRALayerCustomOriginal): integer; 2280 begin 2281 result := -1; 2282 end; 2283 937 2284 procedure TBGRACustomLayeredBitmap.SetWidth(Value: Integer); 938 2285 begin … … 960 2307 temp: TBGRALayeredBitmap; 961 2308 i: integer; 2309 stream: TFileStreamUTF8; 962 2310 begin 963 2311 ext := UTF8LowerCase(ExtractFileExt(filenameUTF8)); … … 975 2323 end; 976 2324 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; 2347 end; 2348 2349 procedure TBGRACustomLayeredBitmap.SaveToStream(Stream: TStream); 2350 begin 2351 if Assigned(LayeredBitmapSaveToStreamProc) then 2352 LayeredBitmapSaveToStreamProc(Stream, self) 2353 else 2354 raise exception.Create('Call BGRAStreamLayers.RegisterStreamLayers first'); 2355 end; 2356 2357 procedure TBGRACustomLayeredBitmap.SaveToStreamAs(Stream: TStream; 2358 AExtension: string); 2359 var bmp: TBGRABitmap; 2360 ext: string; 2361 format: TBGRAImageFormat; 2362 temp: TBGRALayeredBitmap; 2363 i: integer; 2364 begin 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); 977 2382 bmp := ComputeFlatImage; 978 2383 try 979 bmp.SaveTo FileUTF8(filenameUTF8);2384 bmp.SaveToStreamAs(Stream, format); 980 2385 finally 981 2386 bmp.Free; … … 983 2388 end; 984 2389 985 procedure TBGRACustomLayeredBitmap.SaveToStream(Stream: TStream);986 begin987 if Assigned(LayeredBitmapSaveToStreamProc) then988 LayeredBitmapSaveToStreamProc(Stream, self)989 else990 raise exception.Create('Call BGRAStreamLayers.RegisterStreamLayers first');991 end;992 993 2390 constructor TBGRACustomLayeredBitmap.Create; 994 2391 begin 995 2392 FFrozenRange := nil; 996 2393 FLinearBlend:= True; 2394 FMemDirectory := nil; 2395 FMemDirectoryOwned:= false; 997 2396 end; 998 2397 … … 1010 2409 end; 1011 2410 1012 function TBGRACustomLayeredBitmap.ComputeFlatImage : TBGRABitmap;1013 begin 1014 result := ComputeFlatImage(rect(0,0,Width,Height), 0, NbLayers - 1 );2411 function TBGRACustomLayeredBitmap.ComputeFlatImage(ASeparateXorMask: boolean): TBGRABitmap; 2412 begin 2413 result := ComputeFlatImage(rect(0,0,Width,Height), 0, NbLayers - 1, ASeparateXorMask); 1015 2414 end; 1016 2415 1017 2416 function 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; 2418 begin 2419 result := ComputeFlatImage(rect(0,0,Width,Height), firstLayer,LastLayer,ASeparateXorMask); 2420 end; 2421 2422 function TBGRACustomLayeredBitmap.ComputeFlatImage(ARect: TRect; 2423 ASeparateXorMask: boolean): TBGRABitmap; 2424 begin 2425 result := ComputeFlatImage(ARect,0, NbLayers - 1, ASeparateXorMask); 1026 2426 end; 1027 2427 … … 1031 2431 end; 1032 2432 1033 function TBGRACustomLayeredBitmap.ComputeFlatImage(ARect: TRect; firstLayer, lastLayer: integer ): TBGRABitmap;2433 function TBGRACustomLayeredBitmap.ComputeFlatImage(ARect: TRect; firstLayer, lastLayer: integer; ASeparateXorMask: boolean): TBGRABitmap; 1034 2434 var 1035 2435 tempLayer: TBGRABitmap; … … 1038 2438 op: TBlendOperation; 1039 2439 begin 2440 if (firstLayer < 0) or (lastLayer > NbLayers-1) then 2441 raise ERangeError.Create('Layer index out of bounds'); 1040 2442 If (ARect.Right <= ARect.Left) or (ARect.Bottom <= ARect.Top) then 1041 2443 begin … … 1076 2478 begin 1077 2479 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 1078 2486 //first layer is simply the background 1079 2487 if i = firstLayer then … … 1093 2501 inc(i); 1094 2502 end; 2503 if result.XorMask <> nil then 2504 AlphaFillInline(result.XorMask.Data, 0, result.XorMask.NbPixels); 1095 2505 end; 1096 2506 … … 1127 2537 end; 1128 2538 1129 procedure TBGRACustomLayeredBitmap.Draw(Dest: TBGRABitmap; AX, AY: integer; firstLayer, lastLayer: integer); 2539 procedure TBGRACustomLayeredBitmap.Draw(Dest: TBGRABitmap; x, y: integer; 2540 ASeparateXorMask: boolean); 2541 begin 2542 Draw(Dest,x,y,0,NbLayers-1,ASeparateXorMask); 2543 end; 2544 2545 procedure TBGRACustomLayeredBitmap.Draw(Dest: TBGRABitmap; AX, AY: integer; firstLayer, lastLayer: integer; ASeparateXorMask: boolean); 1130 2546 var 1131 2547 temp: TBGRABitmap; … … 1143 2559 if LayerVisible[i] and not (BlendOperation[i] in[boTransparent,boLinearBlend]) then 1144 2560 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); 1146 2562 if self.LinearBlend then 1147 2563 Dest.PutImage(NewClipRect.Left,NewClipRect.Top,temp,dmLinearBlend) … … 1170 2586 end; 1171 2587 if LayerVisible[i] then 1172 with LayerOffset[i] do1173 2588 begin 1174 2589 tempLayer := GetLayerBitmapDirectly(i); … … 1181 2596 end; 1182 2597 if tempLayer <> nil then 2598 with LayerOffset[i] do 1183 2599 begin 1184 2600 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]) 1186 2602 else 1187 Dest.PutImage(AX+x,AY+y, GetLayerBitmapDirectly(i),dmLinearBlend, LayerOpacity[i]);2603 Dest.PutImage(AX+x,AY+y,tempLayer,dmLinearBlend, LayerOpacity[i]); 1188 2604 if mustFreeCopy then tempLayer.Free; 1189 2605 end; … … 1294 2710 end; 1295 2711 2712 procedure TBGRACustomLayeredBitmap.NotifyLoaded; 2713 begin 2714 //nothing 2715 end; 2716 2717 procedure TBGRACustomLayeredBitmap.NotifySaving; 2718 begin 2719 //nothing 2720 end; 2721 1296 2722 procedure RegisterLayeredBitmapReader(AExtensionUTF8: string; AReader: TBGRACustomLayeredBitmapClass); 1297 2723 begin … … 1302 2728 theClass := AReader; 1303 2729 end; 2730 end; 2731 2732 function TryCreateLayeredBitmapWriter(AExtensionUTF8: string): TBGRALayeredBitmap; 2733 var 2734 i: Integer; 2735 begin 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; 2746 end; 2747 2748 function TryCreateLayeredBitmapReader(AExtensionUTF8: string): TBGRACustomLayeredBitmap; 2749 var 2750 i: Integer; 2751 begin 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; 1304 2762 end; 1305 2763 -
GraphicTest/Packages/bgrabitmap/bgralazresource.pas
r494 r521 25 25 constructor Create(AContainer: TMultiFileContainer; AName: utf8string; AValueType: utf8string; AContent: TStream); 26 26 destructor Destroy; override; 27 function CopyTo(ADestination: TStream): int eger; override;27 function CopyTo(ADestination: TStream): int64; override; 28 28 end; 29 29 … … 39 39 constructor Create(AContainer: TMultiFileContainer; AName: utf8string; ABinaryContent: TStream); 40 40 destructor Destroy; override; 41 function CopyTo(ADestination: TStream): int eger; override;41 function CopyTo(ADestination: TStream): int64; override; 42 42 end; 43 43 … … 91 91 end; 92 92 93 function TFormDataEntry.CopyTo(ADestination: TStream): int eger;93 function TFormDataEntry.CopyTo(ADestination: TStream): int64; 94 94 begin 95 95 RequireTextContent; … … 149 149 end; 150 150 151 function TLazResourceEntry.CopyTo(ADestination: TStream): int eger;151 function TLazResourceEntry.CopyTo(ADestination: TStream): int64; 152 152 begin 153 153 if FContent.Size = 0 then -
GraphicTest/Packages/bgrabitmap/bgralclbitmap.pas
r494 r521 21 21 ): TBGRAPtrBitmap; override; 22 22 procedure AssignRasterImage(ARaster: TRasterImage); virtual; 23 procedure ExtractXorMask; 23 24 public 24 25 procedure Assign(Source: TPersistent); override; 26 procedure LoadFromResource(AFilename: string; AOptions: TBGRALoadingOptions); overload; override; 25 27 procedure DataDrawTransparent(ACanvas: TCanvas; Rect: TRect; 26 28 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; 28 30 ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); override; 29 31 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; 32 34 procedure TakeScreenshotOfPrimaryMonitor; override; 33 35 procedure TakeScreenshot({%H-}ARect: TRect); override; … … 54 56 implementation 55 57 56 uses BGRAText, LCLType, LCLIntf, FPimage;58 uses Types, BGRAText, LCLType, LCLIntf, FPimage; 57 59 58 60 type 59 61 TCopyPixelProc = procedure (psrc: PByte; pdest: PBGRAPixel; count: NativeInt; sourcePixelSize: PtrInt; defaultOpacity: byte); 62 63 procedure ApplyMask1bit(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; {%H-}sourcePixelSize: PtrInt; {%H-}defaultOpacity: byte); 64 var currentBit: byte; 65 begin 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; 79 end; 80 81 procedure ApplyMask1bitRev(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; {%H-}sourcePixelSize: PtrInt; {%H-}defaultOpacity: byte); 82 var currentBit: byte; 83 begin 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; 97 end; 98 99 procedure CopyFromBW_SetAlpha(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; {%H-}sourcePixelSize: PtrInt; defaultOpacity: byte); 100 var currentBit: byte; 101 begin 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; 119 end; 120 121 procedure CopyFromBW_SetAlphaBitRev(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; {%H-}sourcePixelSize: PtrInt; defaultOpacity: byte); 122 var currentBit: byte; 123 begin 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; 141 end; 60 142 61 143 procedure CopyFrom24Bit(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; sourcePixelSize: PtrInt; defaultOpacity: byte); … … 255 337 end; 256 338 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 339 procedure DoCopyProc(ADestination: TBGRACustomBitmap; ACopyProc: TCopyPixelProc; AData: PByte; ABytesPerLine, ABitsPerPixel: integer; ALineOrder: TRawImageLineOrder; ADefaultOpacity: byte); 340 var 341 n: integer; 261 342 psource_byte, pdest_byte, 262 343 psource_first, pdest_first: PByte; 263 344 psource_delta, pdest_delta: integer; 264 265 n: integer; 345 begin 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; 380 end; 381 382 procedure ApplyRawImageMask(ADestination: TBGRACustomBitmap; const ARawImage: TRawImage); 383 var 384 copyProc: TCopyPixelProc; 385 begin 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; 395 end; 396 397 { Load raw image data. It must be 32bit, 24 bits or 1bit per pixel} 398 function LoadFromRawImageImplementation(ADestination: TBGRADefaultBitmap; const ARawImage: TRawImage; 399 DefaultOpacity: byte; AlwaysReplaceAlpha: boolean; RaiseErrorOnInvalidPixelFormat: boolean): boolean; 400 var 266 401 mustSwapRedBlue: boolean; 267 402 copyProc: TCopyPixelProc; … … 287 422 end; 288 423 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 330 507 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 391 521 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); 447 558 ADestination.InvalidateBitmap; 559 560 ApplyRawImageMask(ADestination, ARawImage); 448 561 result := true; 449 562 end; … … 635 748 begin 636 749 if FBitmap <> nil then 750 begin 637 751 LoadFromRawImage(FBitmap.RawImage, FCanvasOpacity); 752 if FAlphaCorrectionNeeded then DoAlphaCorrection; 753 end; 638 754 end; 639 755 … … 666 782 FBitmap.Canvas.AntialiasingMode := amOff; 667 783 FBitmapModified := False; 784 FAlphaCorrectionNeeded:= false; 668 785 end; 669 786 … … 681 798 end else 682 799 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; 811 end; 812 813 procedure TBGRALCLBitmap.LoadFromResource(AFilename: string; 814 AOptions: TBGRALoadingOptions); 815 var 816 icon: TCustomIcon; 817 ext: String; 818 begin 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); 683 838 end; 684 839 … … 688 843 DiscardBitmapChange; 689 844 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 692 855 begin //try to convert 693 856 TempBmp := TBitmap.Create; … … 696 859 TempBmp.Canvas.Draw(0,0,ARaster); 697 860 try 698 LoadFromRawImage(TempBmp.RawImage,0,False,true); 861 LoadFromRawImage(TempBmp.RawImage,255,False,true); 862 ApplyRawImageMask(self, ARaster.RawImage); 699 863 finally 700 864 TempBmp.Free; … … 702 866 end else 703 867 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 868 end; 869 870 procedure TBGRALCLBitmap.ExtractXorMask; 871 var 872 y, x: Integer; 873 p: PBGRAPixel; 874 begin 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; 706 889 end; 707 890 … … 712 895 end; 713 896 714 procedure TBGRALCLBitmap.DataDrawOpaque(ACanvas: TCanvas; Rect: TRect;897 procedure TBGRALCLBitmap.DataDrawOpaque(ACanvas: TCanvas; ARect: TRect; 715 898 AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); 716 899 begin 717 DataDrawOpaqueImplementation(ACanvas, Rect, AData, ALineOrder, AWidth, AHeight);900 DataDrawOpaqueImplementation(ACanvas, ARect, AData, ALineOrder, AWidth, AHeight); 718 901 end; 719 902 … … 725 908 end; 726 909 727 procedure TBGRALCLBitmap.LoadFromDevice(DC: System.THandle);910 procedure TBGRALCLBitmap.LoadFromDevice(DC: HDC); 728 911 var 729 912 rawImage: TRawImage; … … 747 930 end; 748 931 749 procedure TBGRALCLBitmap.LoadFromDevice(DC: System.THandle; ARect: TRect);932 procedure TBGRALCLBitmap.LoadFromDevice(DC: HDC; ARect: TRect); 750 933 var 751 934 rawImage: TRawImage; -
GraphicTest/Packages/bgrabitmap/bgramatrix3d.pas
r494 r521 434 434 435 435 operator*(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} 437 437 begin 438 438 {$IFDEF BGRASSE_AVAILABLE} … … 441 441 oldMt := M.t; 442 442 M.t := SingleConst1; 443 resultAddr := @result; 444 {$IFDEF cpux86_64} 443 445 if UseSSE3 then 444 446 asm 445 mov eax, A446 movups xmm5, [ eax]447 movups xmm6, [ eax+16]448 movups xmm7, [ eax+32]449 450 mov eax, M451 movups xmm0, [ eax]452 453 mov eax, result447 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 454 456 455 457 movaps xmm4,xmm0 … … 457 459 haddps xmm4,xmm4 458 460 haddps xmm4,xmm4 459 movss [ eax], xmm4461 movss [rax], xmm4 460 462 461 463 movaps xmm4,xmm0 … … 463 465 haddps xmm4,xmm4 464 466 haddps xmm4,xmm4 465 movss [ eax+4], xmm4467 movss [rax+4], xmm4 466 468 467 469 mulps xmm0,xmm7 468 470 haddps xmm0,xmm0 469 471 haddps xmm0,xmm0 470 movss [ eax+8], xmm0472 movss [rax+8], xmm0 471 473 end else 472 474 asm 473 mov eax, A474 movups xmm5, [ eax]475 movups xmm6, [ eax+16]476 movups xmm7, [ eax+32]477 478 mov eax, M479 movups xmm0, [ eax]480 481 mov eax, result475 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 482 484 483 485 movaps xmm4,xmm0 … … 492 494 addps xmm4, xmm3 493 495 494 movss [ eax], xmm4496 movss [rax], xmm4 495 497 496 498 movaps xmm4,xmm0 … … 505 507 addps xmm4, xmm3 506 508 507 movss [ eax+4], xmm4509 movss [rax+4], xmm4 508 510 509 511 mulps xmm0,xmm7 … … 517 519 addps xmm0, xmm3 518 520 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 519 600 movss [eax+8], xmm0 520 601 end; 602 {$ENDIF} 521 603 M.t := oldMt; 522 604 result.t := 0; -
GraphicTest/Packages/bgrabitmap/bgramultifiletype.pas
r494 r521 2 2 3 3 {$mode objfpc}{$H+} 4 {$MODESWITCH ADVANCEDRECORDS} 4 5 5 6 interface … … 7 8 uses 8 9 Classes, SysUtils, fgl; 10 11 type 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 32 function EntryFilename(AName,AExtension: string): TEntryFilename; overload; 33 function EntryFilename(AFilename: string): TEntryFilename; overload; 9 34 10 35 type … … 22 47 public 23 48 constructor Create(AContainer: TMultiFileContainer); 24 function CopyTo({%H-}ADestination: TStream): int eger; virtual;49 function CopyTo({%H-}ADestination: TStream): int64; virtual; 25 50 property Name: utf8string read GetName write SetName; 26 51 property Extension: utf8string read GetExtension; … … 38 63 protected 39 64 procedure Init; virtual; 40 function AddEntry(AEntry: TMultiFileEntry ): integer;65 function AddEntry(AEntry: TMultiFileEntry; AIndex: integer = -1): integer; 41 66 function GetCount: integer; 42 67 function GetEntry(AIndex: integer): TMultiFileEntry; 43 68 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); 44 73 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; 51 82 procedure Clear; virtual; 52 83 destructor Destroy; override; 53 84 procedure LoadFromFile(AFilename: utf8string); 54 85 procedure LoadFromStream(AStream: TStream); virtual; abstract; 86 procedure LoadFromResource(AFilename: string); virtual; 55 87 procedure SaveToFile(AFilename: utf8string); 56 88 procedure SaveToStream(ADestination: TStream); virtual; abstract; 57 89 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; 62 96 property Count: integer read GetCount; 63 97 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; 64 100 end; 65 101 66 102 implementation 67 103 68 uses BGRAUTF8; 104 uses BGRAUTF8, strutils, BGRABitmapTypes; 105 106 { TEntryFilename } 107 108 function TEntryFilename.GetFilename: utf8string; 109 begin 110 if Extension = '' then 111 result := Name 112 else 113 result := Name+'.'+Extension; 114 end; 115 116 function TEntryFilename.GetIsEmpty: boolean; 117 begin 118 result := (FName='') and (FExtension = ''); 119 end; 120 121 procedure TEntryFilename.SetExtension(AValue: utf8string); 122 var 123 i: Integer; 124 begin 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; 130 end; 131 132 procedure TEntryFilename.SetFilename(AValue: utf8string); 133 var 134 idxDot: SizeInt; 135 begin 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; 147 end; 148 149 procedure TEntryFilename.SetName(AValue: utf8string); 150 var 151 i: Integer; 152 begin 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; 158 end; 159 160 function EntryFilename(AName, AExtension: string): TEntryFilename; 161 begin 162 result.Name := AName; 163 result.Extension:= AExtension; 164 end; 165 166 function EntryFilename(AFilename: string): TEntryFilename; 167 begin 168 result.Filename:= AFilename; 169 end; 170 171 class operator TEntryFilename.=(const AValue1, AValue2: TEntryFilename): boolean; 172 begin 173 result := (AValue1.Name = AValue2.Name) and (AValue1.Extension = AValue2.Extension); 174 end; 69 175 70 176 { TMultiFileEntry } … … 85 191 end; 86 192 87 function TMultiFileEntry.CopyTo(ADestination: TStream): int eger;193 function TMultiFileEntry.CopyTo(ADestination: TStream): int64; 88 194 begin 89 195 result := 0; … … 94 200 function TMultiFileContainer.GetCount: integer; 95 201 begin 96 result := FEntries.Count; 202 if Assigned(FEntries) then 203 result := FEntries.Count 204 else 205 result := 0; 97 206 end; 98 207 … … 102 211 end; 103 212 213 function TMultiFileContainer.GetRawString(AIndex: integer): RawByteString; 214 var s: TStringStream; 215 begin 216 s := TStringStream.Create(''); 217 try 218 Entry[AIndex].CopyTo(s); 219 result := s.DataString; 220 finally 221 s.Free; 222 end; 223 end; 224 225 function TMultiFileContainer.GetRawStringByFilename(AFilename: string 226 ): RawByteString; 227 var 228 idx: Integer; 229 begin 230 idx := IndexOf(EntryFilename(AFilename)); 231 if idx = -1 then 232 result := '' 233 else 234 result := GetRawString(idx); 235 end; 236 237 procedure TMultiFileContainer.SetRawString(AIndex: integer; 238 AValue: RawByteString); 239 begin 240 with Entry[AIndex] do 241 Add(Name, Extension, AValue, true); 242 end; 243 244 procedure TMultiFileContainer.SetRawStringByFilename(AFilename: string; 245 AValue: RawByteString); 246 var 247 f: TEntryFilename; 248 begin 249 f := EntryFilename(AFilename); 250 Add(f.Name,f.Extension,AValue,true); 251 end; 252 104 253 procedure TMultiFileContainer.Init; 105 254 begin … … 107 256 end; 108 257 109 function TMultiFileContainer.AddEntry(AEntry: TMultiFileEntry): integer; 110 begin 111 result := FEntries.Add(AEntry); 258 function TMultiFileContainer.AddEntry(AEntry: TMultiFileEntry; AIndex: integer): integer; 259 begin 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); 112 269 end; 113 270 … … 160 317 newEntry := CreateEntry(AName, AExtension, AContent); 161 318 if Assigned(newEntry) then 162 result := AddEntry(newEntry )319 result := AddEntry(newEntry, index) 163 320 else 164 321 raise exception.Create('Unable to create entry'); … … 166 323 167 324 function TMultiFileContainer.Add(AName: utf8string; AExtension: utf8string; 168 AContent: utf8String; AOverwrite: boolean): integer;325 AContent: RawByteString; AOverwrite: boolean): integer; 169 326 var stream: TMemoryStream; 170 327 begin 171 328 stream := TMemoryStream.Create; 172 stream.Write(AContent[1],length(AContent));329 if length(AContent) > 0 then stream.Write(AContent[1],length(AContent)); 173 330 result := Add(AName,AExtension,stream,AOverwrite); 331 end; 332 333 function TMultiFileContainer.Add(AFilename: TEntryFilename; AContent: TStream; 334 AOverwrite: boolean; AOwnStream: boolean): integer; 335 begin 336 result := Add(AFilename.Name,AFilename.Extension, AContent, AOverwrite, AOwnStream); 337 end; 338 339 function TMultiFileContainer.Add(AFilename: TEntryFilename; 340 AContent: RawByteString; AOverwrite: boolean): integer; 341 begin 342 result := Add(AFilename.Name,AFilename.Extension, AContent, AOverwrite); 174 343 end; 175 344 … … 187 356 LoadFromStream(stream); 188 357 stream.Free; 358 end; 359 360 procedure TMultiFileContainer.LoadFromResource(AFilename: string); 361 var 362 stream: TStream; 363 begin 364 stream := BGRAResource.GetResourceStream(AFilename); 365 try 366 LoadFromStream(stream); 367 finally 368 stream.Free; 369 end; 189 370 end; 190 371 … … 230 411 result := true; 231 412 end; 413 end; 414 415 function TMultiFileContainer.Delete(AFilename: TEntryFilename; 416 ACaseSensitive: boolean): boolean; 417 begin 418 result := Delete(AFilename.Name,AFilename.Extension,ACaseSensitive); 232 419 end; 233 420 … … 259 446 end; 260 447 448 function TMultiFileContainer.IndexOf(AFilename: TEntryFilename; 449 ACaseSensitive: boolean): integer; 450 begin 451 result := IndexOf(AFilename.Name,AFilename.Extension,ACaseSensitive); 452 end; 453 261 454 procedure TMultiFileContainer.Clear; 262 455 var -
GraphicTest/Packages/bgrabitmap/bgranoguibitmap.pas
r494 r521 40 40 procedure TakeScreenshot({%H-}ARect: TRect); override; //not available 41 41 procedure TakeScreenshotOfPrimaryMonitor; override; //not available 42 procedure LoadFromDevice({%H-}DC: System.THandle); override; //not available43 procedure LoadFromDevice({%H-}DC: System.THandle; {%H-}ARect: TRect); override; //not available42 procedure LoadFromDevice({%H-}DC: HDC); override; //not available 43 procedure LoadFromDevice({%H-}DC: HDC; {%H-}ARect: TRect); override; //not available 44 44 property Canvas: TBGRACanvas read GetPseudoCanvas; 45 45 end; … … 149 149 end; 150 150 151 procedure TBGRANoGUIBitmap.LoadFromDevice(DC: System.THandle);151 procedure TBGRANoGUIBitmap.LoadFromDevice(DC: HDC); 152 152 begin 153 153 NotAvailable; 154 154 end; 155 155 156 procedure TBGRANoGUIBitmap.LoadFromDevice(DC: System.THandle; ARect: TRect);156 procedure TBGRANoGUIBitmap.LoadFromDevice(DC: HDC; ARect: TRect); 157 157 begin 158 158 NotAvailable; -
GraphicTest/Packages/bgrabitmap/bgraopengl.pas
r494 r521 9 9 Classes, SysUtils, FPimage, BGRAGraphics, 10 10 BGRAOpenGLType, BGRASpriteGL, BGRACanvasGL, GL, GLext, GLU, BGRABitmapTypes, 11 BGRAFontGL, BGRASSE ;11 BGRAFontGL, BGRASSE, BGRAMatrix3D; 12 12 13 13 type … … 43 43 property Width: integer read GetWidth; 44 44 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; 45 70 end; 46 71 … … 120 145 implementation 121 146 122 uses BGRATransform{$IFDEF BGRABITMAP_USE_LCL}, BGRAText, BGRATextFX{$ENDIF} 123 ,BGRAMatrix3D; 147 uses BGRABlurGL, BGRATransform{$IFDEF BGRABITMAP_USE_LCL}, BGRAText, BGRATextFX{$ENDIF}; 124 148 125 149 type … … 210 234 procedure ToggleFlipY; override; 211 235 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; 212 238 213 239 end; … … 247 273 procedure InternalStartPolygon(const pt: TPointF); override; 248 274 procedure InternalStartTriangleFan(const pt: TPointF); override; 249 procedure InternalContinueShape(const pt: TPointF); over ride;250 251 procedure InternalContinueShape(const pt: TPoint3D); over ride;252 procedure InternalContinueShape(const pt: TPoint3D_128); over ride;253 procedure InternalContinueShape(const pt, normal: TPoint3D_128); over ride;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; 254 280 255 281 procedure InternalEndShape; override; … … 268 294 function GetBlendMode: TOpenGLBlendMode; override; 269 295 procedure SetBlendMode(AValue: TOpenGLBlendMode); override; 296 297 procedure SetActiveFrameBuffer(AValue: TBGLCustomFrameBuffer); override; 270 298 public 271 299 destructor Destroy; override; … … 274 302 procedure EndZBuffer; override; 275 303 procedure WaitForGPU(AOption: TWaitForGPUOption); override; 304 function GetImage(x, y, w, h: integer): TBGRACustomBitmap; override; 305 function CreateFrameBuffer(AWidth, AHeight: integer): TBGLCustomFrameBuffer; override; 276 306 end; 277 307 … … 307 337 function GetUniformVariable(AProgram: DWord; AName: string): DWord; override; 308 338 function GetAttribVariable(AProgram: DWord; AName: string): DWord; override; 309 procedure SetUniformSingle(AVariable: DWord; const AValue; A Count: integer); override;310 procedure SetUniformInteger(AVariable: DWord; const AValue; A Count: integer); override;339 procedure SetUniformSingle(AVariable: DWord; const AValue; AElementCount, AComponentCount: integer); override; 340 procedure SetUniformInteger(AVariable: DWord; const AValue; AElementCount, AComponentCount: integer); override; 311 341 procedure BindAttribute(AAttribute: TAttributeVariable); override; 312 342 procedure UnbindAttribute(AAttribute: TAttributeVariable); override; 313 343 end; 344 345 { TBGLFrameBuffer } 346 347 procedure TBGLFrameBuffer.SetMatrix(AValue: TAffineMatrix); 348 begin 349 if FSettingMatrices then Exit; 350 FSettingMatrices := true; 351 FMatrix:=AValue; 352 if FCanvas <> nil then 353 TBGLCustomCanvas(FCanvas).Matrix := AValue; 354 FSettingMatrices := false; 355 end; 356 357 function TBGLFrameBuffer.GetMatrix: TAffineMatrix; 358 begin 359 result := FMatrix; 360 end; 361 362 function TBGLFrameBuffer.GetTexture: IBGLTexture; 363 begin 364 result := FTexture.FlipY; 365 end; 366 367 function TBGLFrameBuffer.GetHandle: pointer; 368 begin 369 result := @FFrameBufferId; 370 end; 371 372 function TBGLFrameBuffer.GetHeight: integer; 373 begin 374 result := FHeight; 375 end; 376 377 function TBGLFrameBuffer.GetProjectionMatrix: TMatrix4D; 378 begin 379 result := FProjectionMatrix; 380 end; 381 382 function TBGLFrameBuffer.GetWidth: integer; 383 begin 384 result := FWidth; 385 end; 386 387 procedure TBGLFrameBuffer.SetProjectionMatrix(AValue: TMatrix4D); 388 begin 389 if FSettingMatrices then Exit; 390 FSettingMatrices := true; 391 FProjectionMatrix:= AValue; 392 if FCanvas <> nil then 393 TBGLCustomCanvas(FCanvas).ProjectionMatrix := AValue; 394 FSettingMatrices := false; 395 end; 396 397 constructor TBGLFrameBuffer.Create(AWidth, AHeight: integer); 398 var frameBufferStatus: GLenum; 399 begin 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; 433 end; 434 435 function TBGLFrameBuffer.MakeTextureAndFree: IBGLTexture; 436 begin 437 result := FTexture; 438 FTexture := nil; 439 Free; 440 end; 441 442 destructor TBGLFrameBuffer.Destroy; 443 begin 444 glDeleteFramebuffers(1, @FFrameBufferId); 445 glDeleteRenderbuffers(1, @FRenderBufferId); 446 FTexture := nil; 447 448 inherited Destroy; 449 end; 314 450 315 451 procedure ApplyBlendMode(ABlendMode: TOpenGLBlendMode); … … 776 912 777 913 procedure TBGLLighting.SetUniformSingle(AVariable: DWord; 778 const AValue; A Count: integer);914 const AValue; AElementCount, AComponentCount: integer); 779 915 begin 780 916 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; 782 927 end; 783 928 784 929 procedure TBGLLighting.SetUniformInteger(AVariable: DWord; 785 const AValue; A Count: integer);930 const AValue; AElementCount, AComponentCount: integer); 786 931 begin 787 932 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; 789 941 end; 790 942 … … 849 1001 function TBGLCanvas.GetMatrix: TAffineMatrix; 850 1002 begin 851 result := FMatrix; 1003 if ActiveFrameBuffer <> nil then 1004 result := ActiveFrameBuffer.Matrix 1005 else 1006 result := FMatrix; 852 1007 end; 853 1008 … … 858 1013 m := AffineMatrixToMatrix4D(AValue); 859 1014 glLoadMatrixf(@m); 860 FMatrix := AValue; 1015 1016 if ActiveFrameBuffer <> nil then 1017 ActiveFrameBuffer.Matrix := AValue 1018 else 1019 FMatrix := AValue; 861 1020 end; 862 1021 863 1022 function TBGLCanvas.GetProjectionMatrix: TMatrix4D; 864 1023 begin 865 result := FProjectionMatrix; 1024 if ActiveFrameBuffer <> nil then 1025 result := ActiveFrameBuffer.ProjectionMatrix 1026 else 1027 result := FProjectionMatrix; 866 1028 end; 867 1029 868 1030 procedure TBGLCanvas.SetProjectionMatrix(const AValue: TMatrix4D); 869 1031 begin 870 FProjectionMatrix := AValue;871 1032 glMatrixMode(GL_PROJECTION); 872 1033 glLoadMatrixf(@AValue); 873 1034 glMatrixMode(GL_MODELVIEW); 1035 1036 if ActiveFrameBuffer <> nil then 1037 ActiveFrameBuffer.ProjectionMatrix := AValue 1038 else 1039 FProjectionMatrix := AValue; 874 1040 end; 875 1041 … … 1015 1181 end; 1016 1182 1183 function TBGLCanvas.GetImage(x, y, w, h: integer): TBGRACustomBitmap; 1184 begin 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); 1191 end; 1192 1193 function TBGLCanvas.CreateFrameBuffer(AWidth, AHeight: integer): TBGLCustomFrameBuffer; 1194 begin 1195 Result:= TBGLFrameBuffer.Create(AWidth,AHeight); 1196 end; 1197 1017 1198 procedure TBGLCanvas.EnableScissor(AValue: TRect); 1018 1199 begin … … 1034 1215 begin 1035 1216 FBlendMode := AValue; 1217 end; 1218 1219 procedure TBGLCanvas.SetActiveFrameBuffer(AValue: TBGLCustomFrameBuffer); 1220 var 1221 m: TMatrix4D; 1222 begin 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); 1036 1239 end; 1037 1240 … … 1377 1580 procedure TBGLTexture.ToggleFlipY; 1378 1581 begin 1379 FFlip X:= not FFlipY;1582 FFlipY := not FFlipY; 1380 1583 end; 1381 1584 … … 1395 1598 end; 1396 1599 1600 function TBGLTexture.FilterBlurMotion(ARadius: single; ABlurType: TRadialBlurType; ADirection: TPointF): IBGLTexture; 1601 var shader: TBGLCustomShader; 1602 blurName: string; 1603 begin 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; 1617 end; 1618 1619 function TBGLTexture.FilterBlurRadial(ARadius: single; ABlurType: TRadialBlurType): IBGLTexture; 1620 var shader: TBGLCustomShader; 1621 blurName: String; 1622 begin 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; 1635 end; 1636 1397 1637 procedure TBGLTexture.Init(ATexture: TBGLTextureHandle; AWidth, 1398 1638 AHeight: integer; AOwned: boolean); -
GraphicTest/Packages/bgrabitmap/bgraopengl3d.pas
r494 r521 149 149 end; 150 150 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 151 162 { TAttributeVariableSingle } 152 163 … … 201 212 function GetUniformVariableInteger(AName: string): TUniformVariableInteger; 202 213 function GetUniformVariablePoint(AName: string): TUniformVariablePoint; 214 function GetUniformVariableMatrix4D(AName: string): TUniformVariableMatrix4D; 203 215 function GetAttributeVariableInteger(AName: string): TAttributeVariableInteger; 204 216 function GetAttributeVariablePoint(AName: string): TAttributeVariablePoint; … … 206 218 function GetAttributeVariablePointF(AName: string): TAttributeVariablePointF; 207 219 function GetAttributeVariablePoint3D(AName: string): TAttributeVariablePoint3D; 208 procedure SetUniformSingle(AVariable: DWord; const AValue; A Count: integer);209 procedure SetUniformInteger(AVariable: DWord; const AValue; A Count: integer);220 procedure SetUniformSingle(AVariable: DWord; const AValue; AElementCount: integer; AComponentCount: integer); 221 procedure SetUniformInteger(AVariable: DWord; const AValue; AElementCount: integer; AComponentCount: integer); 210 222 procedure CheckUsage(AUsing: boolean); 211 223 procedure StartUse; override; 212 224 procedure EndUse; override; 225 property Canvas: TBGLCustomCanvas read FCanvas; 213 226 public 214 227 constructor Create(ACanvas: TBGLCustomCanvas; AVertexShaderSource: string; 215 228 AFragmentShaderSource: string; AVaryingVariables: string = ''; 216 AVersion: string = '1 10');229 AVersion: string = '120'); 217 230 destructor Destroy; override; 218 231 property UniformSingle[AName: string]: TUniformVariableSingle read GetUniformVariableSingle; … … 221 234 property UniformInteger[AName: string]: TUniformVariableInteger read GetUniformVariableInteger; 222 235 property UniformPoint[AName: string]: TUniformVariablePoint read GetUniformVariablePoint; 236 property UniformMatrix4D[AName: string]: TUniformVariableMatrix4D read GetUniformVariableMatrix4D; 223 237 property AttributeSingle[AName: string]: TAttributeVariableSingle read GetAttributeVariableSingle; 224 238 property AttributePointF[AName: string]: TAttributeVariablePointF read GetAttributeVariablePointF; … … 260 274 end; 261 275 276 { TUniformVariableMatrix4D } 277 278 procedure TUniformVariableMatrix4D.SetValue(const AValue: TMatrix4D); 279 begin 280 if CompareMem(@AValue, @FValue, sizeof(FValue)) then Exit; 281 FValue:=AValue; 282 if FProgram.IsUsed then Update; 283 end; 284 285 procedure TUniformVariableMatrix4D.Update; 286 begin 287 FProgram.SetUniformSingle(FVariable, FValue, 1, 16); 288 end; 289 262 290 { TShaderWithTexture } 263 291 … … 351 379 procedure TUniformVariablePoint.Update; 352 380 begin 353 FProgram.SetUniformInteger(FVariable, FValue, 2);381 FProgram.SetUniformInteger(FVariable, FValue, 1, 2); 354 382 end; 355 383 … … 365 393 procedure TUniformVariableInteger.Update; 366 394 begin 367 FProgram.SetUniformInteger(FVariable, FValue, 1 );395 FProgram.SetUniformInteger(FVariable, FValue, 1, 1); 368 396 end; 369 397 … … 379 407 procedure TUniformVariablePoint3D.Update; 380 408 begin 381 FProgram.SetUniformSingle(FVariable, FValue, 3);409 FProgram.SetUniformSingle(FVariable, FValue, 1, 3); 382 410 end; 383 411 … … 393 421 procedure TUniformVariablePointF.Update; 394 422 begin 395 FProgram.SetUniformSingle(FVariable, FValue, 2);423 FProgram.SetUniformSingle(FVariable, FValue, 1, 2); 396 424 end; 397 425 … … 407 435 procedure TUniformVariableSingle.Update; 408 436 begin 409 FProgram.SetUniformSingle(FVariable, FValue, 1 );437 FProgram.SetUniformSingle(FVariable, FValue, 1, 1); 410 438 end; 411 439 … … 460 488 end; 461 489 490 function TBGLShader3D.GetUniformVariableMatrix4D(AName: string): TUniformVariableMatrix4D; 491 begin 492 {$push}{$hints off} 493 fillchar(result,sizeof(result),0); 494 result.Init(self, FCanvas.Lighting.GetUniformVariable(FProgram, AName)); 495 {$pop} 496 end; 497 462 498 procedure TBGLShader3D.CheckUsage(AUsing: boolean); 463 499 begin … … 509 545 end; 510 546 511 procedure TBGLShader3D.SetUniformSingle(AVariable: DWord; const AValue; A Count: integer);547 procedure TBGLShader3D.SetUniformSingle(AVariable: DWord; const AValue; AElementCount: integer; AComponentCount: integer); 512 548 begin 513 549 CheckUsage(True); 514 FCanvas.Lighting.SetUniformSingle(AVariable, AValue, A Count);515 end; 516 517 procedure TBGLShader3D.SetUniformInteger(AVariable: DWord; const AValue; A Count: integer);550 FCanvas.Lighting.SetUniformSingle(AVariable, AValue, AElementCount, AComponentCount); 551 end; 552 553 procedure TBGLShader3D.SetUniformInteger(AVariable: DWord; const AValue; AElementCount: integer; AComponentCount: integer); 518 554 begin 519 555 CheckUsage(True); 520 FCanvas.Lighting.SetUniformInteger(AVariable, AValue, A Count);556 FCanvas.Lighting.SetUniformInteger(AVariable, AValue, AElementCount, AComponentCount); 521 557 end; 522 558 … … 527 563 FCanvas := ACanvas; 528 564 FLighting := FCanvas.Lighting; 529 FVertexShaderSource:= '# defineversion ' + AVersion + #10 + AVaryingVariables + #10 + AVertexShaderSource;530 FFragmentShaderSource:= '# defineversion ' + AVersion + #10 + AVaryingVariables + #10 + AFragmentShaderSource;565 FVertexShaderSource:= '#version ' + AVersion + #10 + AVaryingVariables + #10 + AVertexShaderSource; 566 FFragmentShaderSource:= '#version ' + AVersion + #10 + AVaryingVariables + #10 + AFragmentShaderSource; 531 567 FVertexShader := 0; 532 568 FFragmentShader := 0; -
GraphicTest/Packages/bgrabitmap/bgraopengltype.pas
r494 r521 142 142 procedure TextRect(ARect: TRectF; const Text : UTF8String; AHorizAlign: TAlignment; AVertAlign: TTextLayout; AColor: TBGRAPixel); overload; 143 143 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; 146 146 procedure SetGradientColors(ATopLeft, ATopRight, ABottomRight, ABottomLeft: TBGRAPixel); virtual; abstract; 147 147 … … 184 184 procedure ToggleFlipY; 185 185 procedure ToggleMask; 186 function FilterBlurMotion(ARadius: single; ABlurType: TRadialBlurType; ADirection: TPointF): IBGLTexture; 187 function FilterBlurRadial(ARadius: single; ABlurType: TRadialBlurType): IBGLTexture; 186 188 procedure SetFrame(AIndex: integer); 187 189 procedure FreeMemory; … … 212 214 procedure DrawAffine(x,y: single; const AMatrix: TAffineMatrix; AAlpha: byte = 255); overload; 213 215 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; 230 232 231 233 property Width: integer read GetWidth; … … 266 268 procedure NoClip; override; 267 269 destructor Destroy; override; 268 procedure SwapRedBlue; over ride; overload;270 procedure SwapRedBlue; overload; override; 269 271 function Resample(newWidth, newHeight: integer; mode: TResampleMode=rmFineResample): TBGRACustomBitmap; override; 270 procedure ApplyGlobalOpacity(alpha: byte); over ride; overload;271 procedure ReplaceColor(before, after: TColor); over ride; overload;272 procedure ReplaceColor(before, after: TBGRAPixel); over ride; overload;273 procedure ReplaceTransparent(after: TBGRAPixel); over ride; 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; 274 276 procedure SetClipRect(const AValue: TRect); override; 275 277 procedure SetSize(AWidth, AHeight: integer); override; … … 363 365 procedure ToggleFlipY; virtual; abstract; 364 366 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; 365 369 366 370 procedure SetFrameSize(x,y: integer); … … 395 399 procedure DrawAffine(x,y: single; const AMatrix: TAffineMatrix; AAlpha: byte = 255); overload; 396 400 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; 413 417 414 418 property Width: integer read GetWidth; … … 427 431 end; 428 432 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 429 461 type 430 462 TBGLBitmapAny = class of TBGLCustomBitmap; … … 441 473 442 474 uses BGRAFilterScanner; 475 476 procedure TBGLCustomFrameBuffer.UseOrthoProjection; 477 begin 478 ProjectionMatrix := OrthoProjectionToOpenGL(0,0,Width,Height); 479 end; 480 481 procedure TBGLCustomFrameBuffer.UseOrthoProjection(AMinX, AMinY, AMaxX, AMaxY: single); 482 begin 483 ProjectionMatrix := OrthoProjectionToOpenGL(AMinX,AMinY,AMaxX,AMaxY); 484 end; 485 486 function TBGLCustomFrameBuffer.MakeTextureAndFree: IBGLTexture; 487 begin 488 result := nil; 489 raise exception.create('Not implemented'); 490 end; 491 492 procedure TBGLCustomFrameBuffer.SetCanvas(ACanvas: Pointer); 493 begin 494 FCanvas := ACanvas; 495 end; 443 496 444 497 function OrthoProjectionToOpenGL(AMinX, AMinY, AMaxX, AMaxY: Single): TMatrix4D; … … 595 648 end; 596 649 650 function TBGLCustomTexture.FilterBlurMotion(ARadius: single; ABlurType: TRadialBlurType; 651 ADirection: TPointF): IBGLTexture; 652 begin 653 result := nil; 654 raise exception.Create('Not implemented'); 655 end; 656 657 function TBGLCustomTexture.FilterBlurRadial(ARadius: single; ABlurType: TRadialBlurType): IBGLTexture; 658 begin 659 result := nil; 660 raise exception.Create('Not implemented'); 661 end; 662 597 663 procedure TBGLCustomTexture.Update(ARGBAData: PDWord; AllocatedWidth, 598 664 AllocatedHeight, ActualWidth, ActualHeight: integer; RGBAOrder: boolean); … … 757 823 begin 758 824 if not TBGRAPixel_RGBAOrder and not SupportsBGRAOrder then SwapRedBlue; 825 if LineOrder = riloBottomToTop then VerticalFlip; 759 826 InitFromData(PDWord(Data), Width,Height, Width,Height, TBGRAPixel_RGBAOrder or not SupportsBGRAOrder); 827 if LineOrder = riloBottomToTop then VerticalFlip; 760 828 if not TBGRAPixel_RGBAOrder and not SupportsBGRAOrder then SwapRedBlue; 761 829 end; … … 1004 1072 AAlpha: byte); 1005 1073 begin 1074 {$PUSH}{$OPTIMIZATION OFF} 1006 1075 DoDrawAffine(Origin,HAxis,VAxis, BGRA(255,255,255,AAlpha)); 1076 {$POP} 1007 1077 end; 1008 1078 … … 1010 1080 AColor: TBGRAPixel); 1011 1081 begin 1082 {$PUSH}{$OPTIMIZATION OFF} 1012 1083 DoDrawAffine(Origin,HAxis,VAxis, AColor); 1084 {$POP} 1013 1085 end; 1014 1086 -
GraphicTest/Packages/bgrabitmap/bgraopenraster.pas
r494 r521 37 37 procedure SetMemoryStreamAsString(AFilename: string; AContent: string); 38 38 function GetMemoryStreamAsString(AFilename: string): string; 39 procedure UnzipFromStream(AStream: TStream );39 procedure UnzipFromStream(AStream: TStream; AFileList: TStrings = nil); 40 40 procedure UnzipFromFile(AFilenameUTF8: string); 41 41 procedure ZipToFile(AFilenameUTF8: string); 42 42 procedure ZipToStream(AStream: TStream); 43 43 procedure CopyThumbnailToMemoryStream(AMaxWidth, AMaxHeight: integer); 44 procedure AnalyzeZip; 45 procedure PrepareZipToSave; 44 procedure AnalyzeZip; virtual; 45 procedure PrepareZipToSave; virtual; 46 46 function GetMimeType: string; override; 47 47 48 48 public 49 constructor Create; over ride; overload;50 constructor Create(AWidth, AHeight: integer); over ride; overload;49 constructor Create; overload; override; 50 constructor Create(AWidth, AHeight: integer); overload; override; 51 51 procedure Clear; override; 52 52 function CheckMimeType(AStream: TStream): boolean; 53 procedure LoadFlatImageFromStream(AStream: TStream; 54 out ANbLayers: integer; 55 out ABitmap: TBGRABitmap); 53 56 procedure LoadFromStream(AStream: TStream); override; 54 57 procedure LoadFromFile(const filenameUTF8: string); override; … … 87 90 UnzipperExt; 88 91 92 const 93 MergedImageFilename = 'mergedimage.png'; 94 LayerStackFilename = 'stack.xml'; 95 89 96 function IsZipStream(stream: TStream): boolean; 90 97 var … … 140 147 oldPos := stream.Position; 141 148 {$PUSH}{$HINTS OFF} 142 BytesRead := Stream.Read( magic,sizeof(magic));149 BytesRead := Stream.Read({%H-}magic,sizeof(magic)); 143 150 {$POP} 144 151 stream.Position:= OldPos; … … 163 170 layeredImage := TBGRAOpenRasterDocument.Create; 164 171 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; 168 181 FWidth:= layeredImage.Width; 169 182 FHeight:= layeredImage.Height; 170 183 FNbLayers:= layeredImage.NbLayers; 184 end; 185 try 171 186 if Img is TBGRACustomBitmap then 172 187 TBGRACustomBitmap(img).Assign(flat) … … 181 196 flat.free; 182 197 end; 183 layeredImage.Free;198 FreeAndNil(layeredImage); 184 199 except 185 200 on ex: Exception do … … 203 218 gammastr: string; 204 219 begin 220 inherited Clear; 221 205 222 if MimeType <> OpenRasterMimeType then 206 223 raise Exception.Create('Invalid mime type'); 207 224 208 StackStream := GetMemoryStream( 'stack.xml');225 StackStream := GetMemoryStream(LayerStackFilename); 209 226 if StackStream = nil then 210 227 raise Exception.Create('Layer stack not found'); … … 225 242 attr := imagenode.Attributes[i]; 226 243 if lowercase(attr.NodeName) = 'w' then 227 w := strToInt( attr.NodeValue) else244 w := strToInt(string(attr.NodeValue)) else 228 245 if lowercase(attr.NodeName) = 'h' then 229 h := strToInt( attr.NodeValue) else246 h := strToInt(string(attr.NodeValue)) else 230 247 if lowercase(attr.NodeName) = 'gamma-correction' then 231 248 linearBlend := (attr.NodeValue = 'no') or (attr.NodeValue = '0'); … … 265 282 end else 266 283 if lowercase(attr.NodeName) = 'gamma-correction' then 267 gammastr := attr.NodeValueelse284 gammastr := string(attr.NodeValue) else 268 285 if lowercase(attr.NodeName) = 'visibility' then 269 286 LayerVisible[idx] := (attr.NodeValue = 'visible') or (attr.NodeValue = 'yes') or (attr.NodeValue = '1') else … … 283 300 if lowercase(attr.NodeName) = 'composite-op' then 284 301 begin 285 opstr := StringReplace(lowercase( attr.NodeValue),'_','-',[rfReplaceAll]);302 opstr := StringReplace(lowercase(string(attr.NodeValue)),'_','-',[rfReplaceAll]); 286 303 if (pos(':',opstr) = 0) and (opstr <> 'xor') then opstr := 'svg:'+opstr; 287 304 //parse composite op … … 373 390 imageNode := TDOMElement(StackXML.CreateElement('image')); 374 391 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))); 377 394 if LinearBlend then 378 395 imageNode.SetAttribute('gamma-correction','no') … … 395 412 layerNode.SetAttribute('name', UTF8Decode(LayerName[i])); 396 413 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)); 399 416 if LayerVisible[i] then 400 417 layerNode.SetAttribute('visibility','visible') 401 418 else 402 419 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))); 405 422 strval := ''; 406 423 case BlendOperation[i] of … … 428 445 else strval := 'svg:src-over'; 429 446 end; 430 layerNode.SetAttribute('composite-op', strval);447 layerNode.SetAttribute('composite-op',widestring(strval)); 431 448 if BlendOperation[i] <> boTransparent then //in 'transparent' case, linear blending depends on general setting 432 449 begin … … 434 451 boSubtract,boExclusion,boNegation] then 435 452 strval := 'yes' else strval := 'no'; 436 layerNode.SetAttribute('gamma-correction', strval);453 layerNode.SetAttribute('gamma-correction',widestring(strval)); 437 454 end; 438 455 end; … … 458 475 PrepareZipToSave; 459 476 ZipToFile(filenameUTF8); 477 ClearFiles; 460 478 end; 461 479 … … 464 482 PrepareZipToSave; 465 483 ZipToStream(AStream); 484 ClearFiles; 466 485 end; 467 486 … … 593 612 end; 594 613 595 procedure TBGRAOpenRasterDocument.UnzipFromStream(AStream: TStream); 614 procedure TBGRAOpenRasterDocument.UnzipFromStream(AStream: TStream; 615 AFileList: TStrings = nil); 596 616 var unzip: TUnZipper; 597 617 begin 598 Clear ;618 ClearFiles; 599 619 unzip := TUnZipper.Create; 600 620 try … … 604 624 unzip.OnCloseInputStream := @ZipOnCloseInputStream; 605 625 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; 607 632 finally 608 633 FZipInputStream := nil; … … 614 639 var unzip: TUnZipper; 615 640 begin 616 Clear ;641 ClearFiles; 617 642 unzip := TUnZipper.Create; 618 643 try … … 661 686 if (Width = 0) or (Height = 0) then exit; 662 687 thumbnail := ComputeFlatImage; 663 CopyBitmapToMemoryStream(thumbnail, 'mergedimage.png');688 CopyBitmapToMemoryStream(thumbnail,MergedImageFilename); 664 689 if (thumbnail.Width > AMaxWidth) or 665 690 (thumbnail.Height > AMaxHeight) then … … 709 734 end; 710 735 736 procedure TBGRAOpenRasterDocument.LoadFlatImageFromStream(AStream: TStream; out 737 ANbLayers: integer; out ABitmap: TBGRABitmap); 738 var fileList: TStringList; 739 imgStream, stackStream: TMemoryStream; 740 imageNode, stackNode: TDOMNode; 741 i: integer; 742 begin 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; 777 end; 778 711 779 procedure TBGRAOpenRasterDocument.LoadFromStream(AStream: TStream); 712 780 begin … … 717 785 finally 718 786 OnLayeredBitmapLoaded; 787 ClearFiles; 719 788 end; 720 789 end; -
GraphicTest/Packages/bgrabitmap/bgrapalette.pas
r494 r521 95 95 procedure ExceptionInvalidPaletteFormat; 96 96 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; 101 101 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; 104 104 function RemoveColor(AValue: TBGRAPixel): boolean; virtual; 105 105 procedure LoadFromFile(AFilenameUTF8: string); virtual; 106 106 procedure LoadFromStream(AStream: TStream; AFormat: TBGRAPaletteFormat); virtual; 107 procedure LoadFromResource(AFilename: string; AFormat: TBGRAPaletteFormat); 107 108 procedure SaveToFile(AFilenameUTF8: string); virtual; 108 109 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; 111 112 function SuggestPaletteFormat(AFilenameUTF8: string): TBGRAPaletteFormat; virtual; 112 113 end; … … 164 165 public 165 166 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; 167 168 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; 169 170 property Weight[AIndex: Integer]: UInt32 read GetWeightByIndex; 170 171 end; … … 196 197 procedure SetReductionColorCount(AValue: Integer); virtual; abstract; 197 198 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; 203 206 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; 205 208 function GetDitheredBitmap(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap): TBGRACustomBitmap; overload; 206 209 procedure SaveBitmapToFile(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; AFilenameUTF8: string); overload; … … 210 213 function GetDitheredBitmapIndexedData(ABitDepth: integer; AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap): Pointer; overload; 211 214 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; 213 216 property SourceColorCount: Integer read GetSourceColorCount; 214 217 property SourceColor[AIndex: integer]: TBGRAPixel read GetSourceColor; … … 605 608 end; 606 609 610 constructor TBGRACustomColorQuantizer.Create(AColors: array of TBGRAPixel; 611 ASeparateAlphaChannel: boolean); 612 var palette: TBGRAPalette; 613 i: Integer; 614 begin 615 palette := TBGRAPalette.Create; 616 for i := 0 to high(AColors) do 617 palette.AddColor(AColors[i]); 618 Create(palette, ASeparateAlphaChannel); 619 palette.Free; 620 end; 621 622 constructor TBGRACustomColorQuantizer.Create(AColors: array of TBGRAPixel; 623 ASeparateAlphaChannel: boolean; AReductionColorCount: integer); 624 var palette: TBGRAPalette; 625 i: Integer; 626 begin 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; 632 end; 633 607 634 procedure TBGRACustomColorQuantizer.ApplyDitheringInplace( 608 635 AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap); … … 709 736 { TBGRACustomApproxPalette } 710 737 711 function TBGRACustomApproxPalette.FindNearestColorIgnoreAlpha(AValue: TBGRAPixel 712 ): TBGRAPixel; 713 const AlphaMask : DWord = {$IFDEF ENDIAN_LITTLE}$ff000000{$ELSE}$000000ff{$endif}; 738 function TBGRACustomApproxPalette.FindNearestColorIgnoreAlpha(AValue: TBGRAPixel): TBGRAPixel; 739 var saveAlpha: byte; 714 740 begin 715 741 if AValue.alpha = 0 then … … 717 743 else 718 744 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; 721 749 end; 722 750 end; … … 724 752 function TBGRACustomApproxPalette.FindNearestColorIndexIgnoreAlpha( 725 753 AValue: TBGRAPixel): integer; 726 const AlphaMask : DWord = {$IFDEF ENDIAN_LITTLE}$ff000000{$ELSE}$000000ff{$endif};727 754 begin 728 755 if AValue.alpha = 0 then … … 730 757 else 731 758 begin 732 result := FindNearestColorIndex(TBGRAPixel(DWord(AValue) or AlphaMask)); 759 AValue.alpha := 255; 760 result := FindNearestColorIndex(AValue); 733 761 end; 734 762 end; … … 1267 1295 end; 1268 1296 1297 procedure TBGRAPalette.LoadFromResource(AFilename: string; AFormat: TBGRAPaletteFormat); 1298 var 1299 stream: TStream; 1300 begin 1301 stream := BGRAResource.GetResourceStream(AFilename); 1302 try 1303 LoadFromStream(stream, AFormat); 1304 finally 1305 stream.Free; 1306 end; 1307 end; 1308 1269 1309 procedure TBGRAPalette.SaveToFile(AFilenameUTF8: string); 1270 1310 var -
GraphicTest/Packages/bgrabitmap/bgrapath.pas
r494 r521 118 118 { TBGRAPath } 119 119 120 TBGRAPath = class( IBGRAPath)120 TBGRAPath = class(TBGRACustomPath) 121 121 protected 122 122 FData: PByte; … … 160 160 function LastCoordDefined: boolean; inline; 161 161 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; 165 166 procedure InternalDraw(ADrawProc: TBGRAPathDrawProc; const AMatrix: TAffineMatrix; AAcceptedDeviation: single; AData: pointer); 166 167 procedure BitmapDrawSubPathProc(const APoints: array of TPointF; AClosed: boolean; AData: pointer); 167 168 function CorrectAcceptedDeviation(AAcceptedDeviation: single; const AMatrix: TAffineMatrix): single; 168 169 public 169 constructor Create; overload; 170 constructor Create; overload; override; 170 171 constructor Create(ASvgString: string); overload; 171 172 constructor Create(const APoints: ArrayOfTPointF); overload; 172 173 constructor Create(APath: IBGRAPath); overload; 173 174 destructor Destroy; override; 174 procedure beginPath; 175 procedure beginPath; override; 175 176 procedure beginSubPath; 176 procedure closePath; 177 procedure closePath; override; 177 178 procedure translate(x,y: single); 178 179 procedure resetTransform; … … 184 185 procedure moveTo(x,y: single); overload; 185 186 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; 188 189 procedure polyline(const pts: array of TPointF); 189 procedure polylineTo(const pts: array of TPointF); 190 procedure polylineTo(const pts: array of TPointF); override; 190 191 procedure polygon(const pts: array of TPointF); 191 192 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; 193 194 procedure quadraticCurve(const curve: TQuadraticBezierCurve); overload; 194 195 procedure quadraticCurve(p1,cp,p2: TPointF); overload; … … 196 197 procedure smoothQuadraticCurveTo(const pt: TPointF); overload; 197 198 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; 199 200 procedure bezierCurve(const curve: TCubicBezierCurve); overload; 200 201 procedure bezierCurve(p1,cp1,cp2,p2: TPointF); overload; … … 209 210 procedure arcTo(x1, y1, x2, y2, radius: single); overload; 210 211 procedure arcTo(const p1,p2: TPointF; radius: single); overload; 211 procedure arc(const arcDef: TArcDef); overload;212 procedure arc(constref arcDef: TArcDef); overload; override; 212 213 procedure arc(cx, cy, rx,ry: single; xAngleRadCW, startAngleRadCW, endAngleRadCW: single); overload; 213 214 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; 216 217 procedure addPath(const AValue: string); overload; 217 218 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; 220 221 property SvgString: string read GetSvgString write SetSvgString; 221 222 function ComputeLength(AAcceptedDeviation: single = 0.1): single; … … 225 226 function GetBounds(AAcceptedDeviation: single = 0.1): TRectF; 226 227 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; 241 242 function CreateCursor(AAcceptedDeviation: single = 0.1): TBGRAPathCursor; 242 243 procedure Fit(ARect: TRectF; AAcceptedDeviation: single = 0.1); 243 244 procedure FitInto(ADest: TBGRAPath; ARect: TRectF; AAcceptedDeviation: single = 0.1); 244 protected245 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};248 245 end; 249 246 … … 258 255 function ComputeOpenedSpline(const points: array of TPointF; Style: TSplineStyle; EndCoeff: single = 0.25; AAcceptedDeviation: single = 0.1): ArrayOfTPointF; 259 256 function ClosedSplineStartPoint(const points: array of TPointF; Style: TSplineStyle): TPointF; 257 function ComputeEasyBezier(const curve: TEasyBezierCurve; AAcceptedDeviation: single = 0.1): ArrayOfTPointF; 260 258 261 259 { 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; 260 function ComputeEllipse(x,y,rx,ry: single; quality: single = 1): ArrayOfTPointF; overload; 261 function ComputeEllipse(AOrigin, AXAxis, AYAxis: TPointF; quality: single = 1): ArrayOfTPointF; overload; 262 function ComputeArc65536(x, y, rx, ry: single; start65536,end65536: word; quality: single = 1): ArrayOfTPointF; overload; 263 function ComputeArc65536(AOrigin, AXAxis, AYAxis: TPointF; start65536,end65536: word; quality: single = 1): ArrayOfTPointF; overload; 264 function ComputeArcRad(x, y, rx, ry: single; startRadCCW,endRadCCW: single; quality: single = 1): ArrayOfTPointF; overload; 265 function ComputeArcRad(AOrigin, AXAxis, AYAxis: TPointF; startRadCCW,endRadCCW: single; quality: single = 1): ArrayOfTPointF; overload; 265 266 function ComputeArc(const arc: TArcDef; quality: single = 1): ArrayOfTPointF; 266 267 function ComputeRoundRect(x1,y1,x2,y2,rx,ry: single; quality: single = 1): ArrayOfTPointF; overload; … … 463 464 464 465 begin 466 if Style = ssEasyBezier then 467 begin 468 result := ComputeEasyBezier(EasyBezierCurve(points, true, cmCurve)); 469 exit; 470 end; 471 465 472 if length(points) <= 2 then 466 473 begin … … 514 521 kernel: TWideKernelFilter; 515 522 begin 523 if Style = ssEasyBezier then 524 begin 525 result := ComputeEasyBezier(EasyBezierCurve(points, false, cmCurve)); 526 exit; 527 end; 528 516 529 if length(points) <= 2 then 517 530 begin … … 592 605 ptNext2: TPointF; 593 606 begin 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; 629 end; 630 631 function ComputeEasyBezier(const curve: TEasyBezierCurve; 632 AAcceptedDeviation: single): ArrayOfTPointF; 633 var 634 path: TBGRAPath; 635 begin 636 path := TBGRAPath.Create; 637 curve.CopyToPath(path); 638 result := path.ToPoints(AAcceptedDeviation); 639 path.Free; 610 640 end; 611 641 … … 654 684 end; 655 685 686 function ComputeEllipse(AOrigin, AXAxis, AYAxis: TPointF; quality: single): ArrayOfTPointF; 687 begin 688 result := ComputeArcRad(AOrigin, AXAxis, AYAxis, 0,0, quality); 689 end; 690 691 function ComputeArc65536(AOrigin, AXAxis, AYAxis: TPointF; start65536, 692 end65536: word; quality: single): ArrayOfTPointF; 693 begin 694 //go back temporarily to radians 695 result := ComputeArcRad(AOrigin,AXAxis,AYAxis, start65536*Pi/326768, end65536*Pi/326768, quality); 696 end; 697 656 698 function ComputeArcRad(x, y, rx, ry: single; startRadCCW, endRadCCW: single; 657 699 quality: single): ArrayOfTPointF; … … 660 702 result[0] := PointF(x+cos(startRadCCW)*rx,y-sin(startRadCCW)*ry); 661 703 result[high(result)] := PointF(x+cos(endRadCCW)*rx,y-sin(endRadCCW)*ry); 704 end; 705 706 function ComputeArcRad(AOrigin, AXAxis, AYAxis: TPointF; startRadCCW,endRadCCW: single; quality: single): ArrayOfTPointF; 707 var 708 u, v: TPointF; 709 lenU, lenV: Single; 710 m: TAffineMatrix; 711 i: Integer; 712 begin 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]; 662 726 end; 663 727 … … 1911 1975 end; 1912 1976 1977 function TBGRAPath.getLength: single; 1978 begin 1979 result := ComputeLength; 1980 end; 1981 1913 1982 function TBGRAPath.getCursor: TBGRACustomPathCursor; 1914 1983 begin … … 2033 2102 var numberStart: integer; 2034 2103 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 2035 2121 begin 2036 2122 while (p <= length(AValue)) and (AValue[p] in[#0..#32,',']) do inc(p); 2037 2123 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; 2040 2125 if (p <= length(AValue)) and (AValue[p] in['e','E']) then 2041 2126 begin 2042 2127 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; 2045 2129 end; 2046 2130 val(copy(AValue,numberStart,p-numberStart),result,errPos); … … 2093 2177 moveTo(p1); 2094 2178 lastCoord := p1; 2179 startCoord := p1; 2095 2180 end; 2096 2181 if relative then implicitCommand:= 'l' else … … 2301 2386 begin 2302 2387 OnModify; 2388 count += 4; //avoid memory error 2303 2389 if FDataPos + count > FDataCapacity then 2304 2390 begin … … 2621 2707 end; 2622 2708 2623 procedure TBGRAPath.moveTo(const pt: TPointF);2709 procedure TBGRAPath.moveTo(constref pt: TPointF); 2624 2710 begin 2625 2711 if FLastSubPathElementType <> peMoveTo then … … 2637 2723 end; 2638 2724 2639 procedure TBGRAPath.lineTo(const pt: TPointF);2725 procedure TBGRAPath.lineTo(constref pt: TPointF); 2640 2726 var lastTransfCoord, newTransfCoord: TPointF; 2641 2727 begin … … 2684 2770 end; 2685 2771 2686 procedure TBGRAPath.quadraticCurveTo(const cp, pt: TPointF);2772 procedure TBGRAPath.quadraticCurveTo(constref cp, pt: TPointF); 2687 2773 begin 2688 2774 if LastCoordDefined then … … 2699 2785 end; 2700 2786 2701 procedure TBGRAPath.bezierCurveTo(const cp1, cp2, pt: TPointF);2787 procedure TBGRAPath.bezierCurveTo(constref cp1, cp2, pt: TPointF); 2702 2788 begin 2703 2789 if not LastCoordDefined then moveTo(cp1); … … 2823 2909 end; 2824 2910 2825 procedure TBGRAPath.arc(const arcDef: TArcDef);2911 procedure TBGRAPath.arc(constref arcDef: TArcDef); 2826 2912 var transformedArc: TArcElement; 2827 2913 begin … … 2904 2990 end; 2905 2991 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; 2992 initialization 2993 2994 BGRAPathFactory := TBGRAPath; 2924 2995 2925 2996 end. -
GraphicTest/Packages/bgrabitmap/bgrapen.pas
r494 r521 18 18 19 19 type 20 TPenJoinStyle = BGRAGraphics.TPenJoinStyle; 21 TPenEndCap = BGRAGraphics.TPenEndCap; 20 22 21 23 { TBGRAPenStroker } … … 56 58 constructor Create; 57 59 destructor Destroy; override; 58 function ComputePolyline(const APoints: array of TPointF; AWidth: single; AClosedCap: boolean = true): ArrayOfTPointF; over ride;59 function ComputePolyline(const APoints: array of TPointF; AWidth: single; APenColor: TBGRAPixel; AClosedCap: boolean = true): ArrayOfTPointF; over ride;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; 60 62 function ComputePolylineAutocycle(const APoints: array of TPointF; AWidth: single): ArrayOfTPointF; override; 61 63 function ComputePolygon(const APoints: array of TPointF; AWidth: single): ArrayOfTPointF; override; … … 91 93 //antialiased version 92 94 procedure 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; 94 96 procedure BGRAEraseLineAntialias(dest: TBGRACustomBitmap; x1, y1, x2, y2: integer; 95 calpha: byte; DrawLastPixel: boolean); 97 calpha: byte; DrawLastPixel: boolean); overload; 96 98 97 99 //antialiased version with bicolor dashes (to draw a frame) 98 100 procedure 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; 100 102 101 103 //length added to ensure accepable alpha join (using TBGRAMultishapeFiller is still better) … … 110 112 function IsClearPenStyle(ACustomPenStyle: TBGRAPenStyle): boolean; 111 113 function DuplicatePenStyle(ACustomPenStyle: array of single): TBGRAPenStyle; 114 function PenStyleEqual(AStyle1, AStyle2: TBGRAPenStyle): boolean; 115 function BGRAToPenStyle(ACustomPenStyle: TBGRAPenStyle): TPenStyle; 112 116 113 117 implementation … … 636 640 end; 637 641 642 function BGRAToPenStyle(ACustomPenStyle: TBGRAPenStyle): TPenStyle; 643 begin 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); 651 end; 652 653 function PenStyleEqual(AStyle1, AStyle2: TBGRAPenStyle): boolean; 654 var 655 i: Integer; 656 begin 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); 661 end; 662 638 663 procedure ApplyPenStyle(const leftPts, rightPts: array of TPointF; const penstyle: TBGRAPenStyle; 639 664 width: single; var posstyle: single; out styledPts: ArrayOfTPointF); … … 658 683 begin 659 684 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; 662 694 betweenDash := false; 663 695 end; -
GraphicTest/Packages/bgrabitmap/bgraphongtypes.pas
r494 r521 15 15 indicate the global height of the map. } 16 16 procedure Draw(dest: TBGRACustomBitmap; map: TBGRACustomBitmap; mapAltitude: integer; ofsX,ofsY: integer; 17 Color : TBGRAPixel); virtual; abstract;17 Color : TBGRAPixel); overload; virtual; abstract; 18 18 19 19 { Render with a color map of the same size as the height map. Map altitude 20 20 indicate the global height of the map. } 21 21 procedure Draw(dest: TBGRACustomBitmap; map: TBGRACustomBitmap; mapAltitude: integer; ofsX,ofsY: integer; 22 ColorMap : TBGRACustomBitmap); virtual; abstract;22 ColorMap : TBGRACustomBitmap); overload; virtual; abstract; 23 23 24 24 { Render with a scanner. Map altitude -
GraphicTest/Packages/bgrabitmap/bgraphoxo.pas
r494 r521 46 46 procedure AddLayerFromPhoxoData(const ABlockHeader: TPhoxoBlockHeader; ABlockData: PByte); 47 47 public 48 constructor Create; over ride; overload;49 constructor Create(AWidth, AHeight: integer); over ride; overload;48 constructor Create; overload; override; 49 constructor Create(AWidth, AHeight: integer); overload; override; 50 50 procedure LoadFromStream(AStream: TStream); override; 51 51 procedure LoadFromFile(const filenameUTF8: string); override; -
GraphicTest/Packages/bgrabitmap/bgrapixel.inc
r494 r521 17 17 {$ENDIF} 18 18 {$IFDEF DARWIN} 19 {$DEFINE BGRABITMAP_RGBAPIXEL} 19 {$IFNDEF LCLQt} 20 {$DEFINE BGRABITMAP_RGBAPIXEL} 21 {$ENDIF} 20 22 {$ENDIF} 21 23 {$ENDIF} … … 99 101 {** Returns the lightness of a pixel. The lightness is the 100 102 perceived brightness, 0 being black and 65535 being white } 101 function GetLightness(c: TBGRAPixel): word; 103 function GetLightness(c: TBGRAPixel): word; overload; 102 104 {** Sets the lightness of a pixel } 103 function SetLightness(c: TBGRAPixel; lightness: word): TBGRAPixel; 105 function SetLightness(c: TBGRAPixel; lightness: word): TBGRAPixel; overload; 104 106 {** Sets the lightness quickly, by fading towards black if ''lightness'' is 105 107 less than 32768, and fading towards white if ''lightness'' is more … … 251 253 {$i basiccolorspace.inc} 252 254 255 {$DEFINE INCLUDE_INTERFACE} 256 {$i extendedcolorspace.inc} 257 253 258 {$ENDIF} 254 259 … … 258 263 {$DEFINE INCLUDE_IMPLEMENTATION} 259 264 {$i basiccolorspace.inc} 265 266 {$DEFINE INCLUDE_IMPLEMENTATION} 267 {$i extendedcolorspace.inc} 260 268 261 269 function StrToBlendOperation(str: string): TBlendOperation; … … 417 425 {$ELSE} 418 426 begin 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; 420 431 end; 421 432 {$ENDIF} … … 572 583 end; 573 584 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 } 577 586 {$PUSH}{$R-} 578 587 function ColorToBGRA(color: TColor): TBGRAPixel; overload; 579 588 begin 589 if (color < 0) or (color > $ffffff) then color := ColorToRGB(color); 580 590 RedGreenBlue(color, Result.red,Result.green,Result.blue); 581 591 Result.alpha := 255; … … 584 594 function ColorToBGRA(color: TColor; opacity: byte): TBGRAPixel; overload; 585 595 begin 596 if (color < 0) or (color > $ffffff) then color := ColorToRGB(color); 586 597 RedGreenBlue(color, Result.red,Result.green,Result.blue); 587 598 Result.alpha := opacity; … … 709 720 {$UNDEF INCLUDE_INIT} 710 721 BGRASetGamma(); 722 723 {$DEFINE INCLUDE_INITIALIZATION} 724 {$i extendedcolorspace.inc} 711 725 {$ENDIF} -
GraphicTest/Packages/bgrabitmap/bgrapolygon.pas
r494 r521 56 56 color: TExpandedPixel; 57 57 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; 60 62 function CheckRectangleBorderBounds(var x1, y1, x2, y2: single; w: single): boolean; 61 63 procedure InternalAddStroke(const APoints: array of TPointF; AClosed: boolean; AData: Pointer); … … 67 69 constructor Create; 68 70 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; 87 89 procedure AddQuadLinearColor(pt1, pt2, pt3, pt4: TPointF; c1, c2, c3, c4: TBGRAPixel); 88 90 procedure AddQuadLinearMapping(pt1, pt2, pt3, pt4: TPointF; texture: IBGRAScanner; tex1, tex2, {%H-}tex3, tex4: TPointF; 89 91 ACulling: TFaceCulling = fcNone); 90 92 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); 103 106 procedure Draw(dest: TBGRACustomBitmap; ADrawMode: TDrawMode = dmDrawWithTransparency); 107 property ShapeCount: integer read nbShapes; 104 108 end; 105 109 106 110 procedure 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); 108 112 procedure FillPolyAliasedWithTexture(bmp: TBGRACustomBitmap; points: array of TPointF; 109 scan: IBGRAScanner; NonZeroWinding: boolean; drawmode: TDrawMode );113 scan: IBGRAScanner; NonZeroWinding: boolean; drawmode: TDrawMode; APixelCenteredCoordinates: boolean = true); 110 114 procedure 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); 112 116 procedure 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); 114 118 115 119 procedure FillEllipseAntialias(bmp: TBGRACustomBitmap; x, y, rx, ry: single; … … 123 127 scan: IBGRAScanner; LinearBlend: boolean = false); 124 128 129 procedure BorderEllipse(bmp: TBGRACustomBitmap; x, y, rx, ry, w: single; 130 c: TBGRAPixel; EraseMode: boolean; drawmode: TDrawMode); 131 procedure BorderEllipseWithTexture(bmp: TBGRACustomBitmap; x, y, rx, ry, w: single; 132 scan: IBGRAScanner; drawmode: TDrawMode); 133 125 134 procedure 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); 127 136 procedure 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); 129 138 130 139 procedure 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); 132 141 procedure 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); 134 143 135 144 procedure 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); 137 146 138 147 implementation … … 163 172 miny, maxy, minx, maxx, 164 173 densMinX, densMaxX: integer; 174 joinDensity, nextJoinDensity: boolean; 165 175 166 176 density: PDensity; … … 312 322 if optimised then 313 323 begin 324 nextJoinDensity := false; 314 325 for i := 0 to firstScan.nbinter div 2 - 1 do 315 326 begin 327 joinDensity := nextJoinDensity; 316 328 x1 := firstScan.inter[i+i].interX; 317 329 x1b := lastScan.inter[i+i].interX; 318 330 x2 := firstScan.inter[i+i+1].interX; 319 331 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))); 320 335 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 324 337 begin 325 338 x1 := (x1+x1b)*0.5; 326 339 x2 := (x2+x2b)*0.5; 340 341 if x1 < minx then x1 := minx; 327 342 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); 330 350 if ix2 > maxx then ix2 := maxx; 351 331 352 if ix1>ix2 then continue; 332 353 if ix1=ix2 then … … 600 621 601 622 procedure 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); 603 624 var 604 625 info: TCustomFillPolyInfo; … … 607 628 exit; 608 629 609 info := TOnePassFillPolyInfo.Create(points );630 info := TOnePassFillPolyInfo.Create(points, APixelCenteredCoordinates); 610 631 FillShapeAliased(bmp, info, c, EraseMode, nil, NonZeroWinding, drawmode); 611 632 info.Free; … … 613 634 614 635 procedure 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); 616 637 var 617 638 info: TCustomFillPolyInfo; … … 620 641 exit; 621 642 622 info := TOnePassFillPolyInfo.Create(points );643 info := TOnePassFillPolyInfo.Create(points, APixelCenteredCoordinates); 623 644 FillShapeAliased(bmp, info, BGRAPixelTransparent,False,scan, NonZeroWinding, drawmode); 624 645 info.Free; … … 626 647 627 648 procedure 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); 629 650 var 630 651 info: TCustomFillPolyInfo; … … 633 654 exit; 634 655 635 info := TOnePassFillPolyInfo.Create(points );656 info := TOnePassFillPolyInfo.Create(points, APixelCenteredCoordinates); 636 657 FillShapeAntialias(bmp, info, c, EraseMode, nil, NonZeroWinding, LinearBlend); 637 658 info.Free; … … 639 660 640 661 procedure 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); 642 663 var 643 664 info: TCustomFillPolyInfo; … … 646 667 exit; 647 668 648 info := TOnePassFillPolyInfo.Create(points );669 info := TOnePassFillPolyInfo.Create(points, APixelCenteredCoordinates); 649 670 FillShapeAntialiasWithTexture(bmp, info, scan, NonZeroWinding, LinearBlend); 650 671 info.Free; … … 703 724 { TBGRAMultishapeFiller } 704 725 705 procedure TBGRAMultishapeFiller.AddShape(AInfo: TBGRACustomFillInfo; AInternalInfo: boolean; ATexture: IBGRAScanner; AInternalTexture: TObject; AColor: TBGRAPixel);726 function TBGRAMultishapeFiller.AddShape(AInfo: TBGRACustomFillInfo; AInternalInfo: boolean; ATexture: IBGRAScanner; AInternalTexture: TObject; AColor: TBGRAPixel): integer; 706 727 begin 707 728 if length(shapes) = nbShapes then 708 729 setlength(shapes, (length(shapes)+1)*2); 709 with shapes[nbShapes] do 730 result := nbShapes; 731 inc(nbShapes); 732 733 with shapes[result] do 710 734 begin 711 735 info := AInfo; … … 714 738 internalTexture:= AInternalTexture; 715 739 color := GammaExpansion(AColor); 716 end;717 inc(nbShapes);740 fillModeOverride:= false; 741 end; 718 742 end; 719 743 … … 740 764 const APoints: array of TPointF; AClosed: boolean; AData: Pointer); 741 765 var pts: ArrayOfTPointF; 766 idxShape: Integer; 742 767 begin 743 768 with TPathStrokeData(AData^) do … … 748 773 pts := Stroker.ComputePolylineAutoCycle(APoints, Width); 749 774 if Texture <> nil then 750 AddPolygon(pts, Texture)775 idxShape := AddPolygon(pts, Texture) 751 776 else 752 AddPolygon(pts, Color); 777 idxShape := AddPolygon(pts, Color); 778 OverrideFillMode(idxShape, fmWinding); 753 779 end; 754 780 end; … … 777 803 end; 778 804 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); 805 function TBGRAMultishapeFiller.AddShape(AShape: TBGRACustomFillInfo; 806 AColor: TBGRAPixel): integer; 807 begin 808 result := AddShape(AShape,False,nil,nil,AColor); 809 end; 810 811 function TBGRAMultishapeFiller.AddShape(AShape: TBGRACustomFillInfo; 812 ATexture: IBGRAScanner): integer; 813 begin 814 result := AddShape(AShape,False,ATexture,nil,BGRAPixelTransparent); 815 end; 816 817 function TBGRAMultishapeFiller.AddPolygon(const points: array of TPointF; 818 AColor: TBGRAPixel): integer; 819 begin 820 if length(points) <= 2 then exit(-1); 821 result := AddShape(TOnePassFillPolyInfo.Create(points),True,nil,nil,AColor); 822 end; 823 824 function TBGRAMultishapeFiller.AddPolygon(const points: array of TPointF; 825 ATexture: IBGRAScanner): integer; 826 begin 827 if length(points) <= 2 then exit(-1); 828 result := AddShape(TOnePassFillPolyInfo.Create(points),True,ATexture,nil,BGRAPixelTransparent); 802 829 end; 803 830 … … 838 865 end; 839 866 840 procedure TBGRAMultishapeFiller.AddPathFill(APath: TBGRAPath; AColor: TBGRAPixel);841 begin 842 AddPolygon(APath.ToPoints, AColor);843 end; 844 845 procedureTBGRAMultishapeFiller.AddPathFill(APath: TBGRAPath;846 ATexture: IBGRAScanner) ;847 begin 848 AddPolygon(APath.ToPoints, ATexture);849 end; 850 851 procedureTBGRAMultishapeFiller.AddPathFill(APath: TBGRAPath;852 AMatrix: TAffineMatrix; AColor: TBGRAPixel) ;853 begin 854 AddPolygon(APath.ToPoints(AMatrix), AColor);855 end; 856 857 procedureTBGRAMultishapeFiller.AddPathFill(APath: TBGRAPath;858 AMatrix: TAffineMatrix; ATexture: IBGRAScanner) ;859 begin 860 AddPolygon(APath.ToPoints(AMatrix), ATexture);861 end; 862 863 procedureTBGRAMultishapeFiller.AddPolylineStroke(867 function TBGRAMultishapeFiller.AddPathFill(APath: TBGRAPath; AColor: TBGRAPixel): integer; 868 begin 869 result := AddPolygon(APath.ToPoints, AColor); 870 end; 871 872 function TBGRAMultishapeFiller.AddPathFill(APath: TBGRAPath; 873 ATexture: IBGRAScanner): integer; 874 begin 875 result := AddPolygon(APath.ToPoints, ATexture); 876 end; 877 878 function TBGRAMultishapeFiller.AddPathFill(APath: TBGRAPath; 879 AMatrix: TAffineMatrix; AColor: TBGRAPixel): integer; 880 begin 881 result := AddPolygon(APath.ToPoints(AMatrix), AColor); 882 end; 883 884 function TBGRAMultishapeFiller.AddPathFill(APath: TBGRAPath; 885 AMatrix: TAffineMatrix; ATexture: IBGRAScanner): integer; 886 begin 887 result := AddPolygon(APath.ToPoints(AMatrix), ATexture); 888 end; 889 890 function TBGRAMultishapeFiller.AddPolylineStroke( 864 891 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 procedureTBGRAMultishapeFiller.AddPolylineStroke(892 AStroker: TBGRACustomPenStroker): integer; 893 begin 894 result := AddPolygon(AStroker.ComputePolyline(points,AWidth,AColor), AColor); 895 end; 896 897 function TBGRAMultishapeFiller.AddPolylineStroke( 871 898 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; 900 begin 901 result := AddPolygon(AStroker.ComputePolyline(points,AWidth), ATexture); 902 end; 903 904 function TBGRAMultishapeFiller.AddPolygonStroke(const points: array of TPointF; 905 AColor: TBGRAPixel; AWidth: single; AStroker: TBGRACustomPenStroker): integer; 906 begin 907 result := AddPolygon(AStroker.ComputePolygon(points,AWidth), AColor); 908 end; 909 910 function TBGRAMultishapeFiller.AddPolygonStroke(const points: array of TPointF; 911 ATexture: IBGRAScanner; AWidth: single; AStroker: TBGRACustomPenStroker 912 ): integer; 913 begin 914 result := AddPolygon(AStroker.ComputePolygon(points,AWidth), ATexture); 915 end; 916 917 function TBGRAMultishapeFiller.AddTriangleLinearColor(pt1, pt2, pt3: TPointF; 918 c1, c2, c3: TBGRAPixel): integer; 893 919 var grad: TBGRAGradientTriangleScanner; 894 920 begin 895 921 if (c1 = c2) and (c2 = c3) then 896 AddPolygon([pt1,pt2,pt3],c1)922 result := AddPolygon([pt1,pt2,pt3],c1) 897 923 else 898 924 begin 899 925 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; 928 end; 929 930 function TBGRAMultishapeFiller.AddTriangleLinearMapping(pt1, pt2, pt3: TPointF; 931 texture: IBGRAScanner; tex1, tex2, tex3: TPointF): integer; 906 932 var 907 933 mapping: TBGRATriangleLinearMapping; 908 934 begin 909 935 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); 911 937 end; 912 938 … … 952 978 end; 953 979 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 procedureTBGRAMultishapeFiller.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 procedureTBGRAMultishapeFiller.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 procedureTBGRAMultishapeFiller.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,980 function TBGRAMultishapeFiller.AddEllipse(x, y, rx, ry: single; 981 AColor: TBGRAPixel): integer; 982 begin 983 result := AddShape(TFillEllipseInfo.Create(x,y,rx,ry),True,nil,nil,AColor); 984 end; 985 986 function TBGRAMultishapeFiller.AddEllipse(x, y, rx, ry: single; 987 ATexture: IBGRAScanner): integer; 988 begin 989 result := AddShape(TFillEllipseInfo.Create(x,y,rx,ry),True,ATexture,nil,BGRAPixelTransparent); 990 end; 991 992 function TBGRAMultishapeFiller.AddEllipseBorder(x, y, rx, ry, w: single; 993 AColor: TBGRAPixel): integer; 994 begin 995 result := AddShape(TFillBorderEllipseInfo.Create(x,y,rx,ry,w),True,nil,nil,AColor); 996 end; 997 998 function TBGRAMultishapeFiller.AddEllipseBorder(x, y, rx, ry, w: single; 999 ATexture: IBGRAScanner): integer; 1000 begin 1001 result := AddShape(TFillBorderEllipseInfo.Create(x,y,rx,ry,w),True,ATexture,nil,BGRAPixelTransparent); 1002 end; 1003 1004 function TBGRAMultishapeFiller.AddRoundRectangle(x1, y1, x2, y2, rx, 1005 ry: single; AColor: TBGRAPixel; options: TRoundRectangleOptions): integer; 1006 begin 1007 result := AddShape(TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry,options),True,nil,nil,AColor); 1008 end; 1009 1010 function TBGRAMultishapeFiller.AddRoundRectangle(x1, y1, x2, y2, rx, 1011 ry: single; ATexture: IBGRAScanner; options: TRoundRectangleOptions): integer; 1012 begin 1013 result := AddShape(TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry,options),True, 988 1014 ATexture,nil,BGRAPixelTransparent); 989 1015 end; 990 1016 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,1017 function TBGRAMultishapeFiller.AddRoundRectangleBorder(x1, y1, x2, y2, rx, ry, 1018 w: single; AColor: TBGRAPixel; options: TRoundRectangleOptions): integer; 1019 begin 1020 result := AddShape(TFillBorderRoundRectInfo.Create(x1, y1, x2, y2, rx, ry,w,options),True, 995 1021 nil,nil,AColor); 996 1022 end; 997 1023 998 procedureTBGRAMultishapeFiller.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,1024 function TBGRAMultishapeFiller.AddRoundRectangleBorder(x1, y1, x2, y2, rx, ry, 1025 w: single; ATexture: IBGRAScanner; options: TRoundRectangleOptions): integer; 1026 begin 1027 result := AddShape(TFillBorderRoundRectInfo.Create(x1, y1, x2, y2, rx, ry,w,options),True, 1002 1028 ATexture,nil,BGRAPixelTransparent); 1003 1029 end; 1004 1030 1005 procedureTBGRAMultishapeFiller.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 procedureTBGRAMultishapeFiller.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);1031 function TBGRAMultishapeFiller.AddRectangle(x1, y1, x2, y2: single; 1032 AColor: TBGRAPixel): integer; 1033 begin 1034 result := AddPolygon([PointF(x1,y1),PointF(x2,y1),PointF(x2,y2),PointF(x1,y2)],AColor); 1035 end; 1036 1037 function TBGRAMultishapeFiller.AddRectangle(x1, y1, x2, y2: single; 1038 ATexture: IBGRAScanner): integer; 1039 begin 1040 result := AddPolygon([PointF(x1,y1),PointF(x2,y1),PointF(x2,y2),PointF(x1,y2)],ATexture); 1041 end; 1042 1043 function TBGRAMultishapeFiller.AddRectangleBorder(x1, y1, x2, y2, w: single; 1044 AColor: TBGRAPixel): integer; 1019 1045 var hw : single; 1020 1046 begin 1021 1047 hw := w/2; 1022 1048 if not CheckRectangleBorderBounds(x1,y1,x2,y2,w) then 1023 AddRectangle(x1-hw,y1-hw,x2+hw,y2+hw,AColor) else1024 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, 1025 1051 PointF(x1+hw,y2-hw),PointF(x2-hw,y2-hw),PointF(x2-hw,y1+hw),PointF(x1+hw,y1+hw)],AColor); 1026 1052 end; 1027 1053 1028 procedure TBGRAMultishapeFiller.AddRectangleBorder(x1, y1, x2, y2, 1029 w: single; ATexture: IBGRAScanner);1054 function TBGRAMultishapeFiller.AddRectangleBorder(x1, y1, x2, y2, w: single; 1055 ATexture: IBGRAScanner): integer; 1030 1056 var hw : single; 1031 1057 begin 1032 1058 hw := w/2; 1033 1059 if not CheckRectangleBorderBounds(x1,y1,x2,y2,w) then 1034 AddRectangle(x1-hw,y1-hw,x2+hw,y2+hw,ATexture) else1035 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, 1036 1062 PointF(x1+hw,y2-hw),PointF(x2-hw,y2-hw),PointF(x2-hw,y1+hw),PointF(x1+hw,y1+hw)],ATexture); 1063 end; 1064 1065 procedure TBGRAMultishapeFiller.OverrideFillMode(AShapeIndex: integer; 1066 AFillMode: TFillMode); 1067 begin 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; 1037 1072 end; 1038 1073 … … 1116 1151 begin 1117 1152 //find intersections 1118 info.ComputeAndSort(cury, inter, nbInter, FillMode=fmWinding);1153 info.ComputeAndSort(cury, inter, nbInter, fillMode=fmWinding); 1119 1154 nbInter := nbInter and not 1; //even 1120 1155 end; … … 1150 1185 if ix2 > densMaxx then densMaxx := ix2; 1151 1186 1152 FillWord(density[ix1-minx],ix2-ix1+1,256); 1187 if ix2 >= ix1 then 1188 FillWord(density[ix1-minx],ix2-ix1+1,256); 1153 1189 end; 1154 1190 end else 1155 1191 {$DEFINE INCLUDE_FILLDENSITY} 1156 1192 {$i density256.inc} 1157 1193 end; … … 1174 1210 bounds: TRect; 1175 1211 1176 xb, yb, yc, j,k: integer;1212 xb, yb, yc, k: integer; 1177 1213 pdest: PBGRAPixel; 1178 1214 1179 1215 curSum,nextSum: ^TCardinalSum; 1180 1216 sums: array of TCardinalSum; 1217 curAlpha: byte; 1181 1218 1182 1219 pdens: PDensity; 1183 w: cardinal;1220 w: UInt32or64; 1184 1221 ec: TExpandedPixel; 1185 1222 count: integer; … … 1188 1225 begin 1189 1226 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 1190 1230 useAA := Antialiasing and (ADrawMode in [dmDrawWithTransparency,dmLinearBlend]); 1191 1231 if nbShapes = 1 then 1192 1232 begin 1193 1233 if useAA then 1194 FillShapeAntialias(dest,shapes[0].info,GammaCompression(shapes[0].color),False,shapes[0].texture, FillMode = fmWinding, ADrawMode=dmLinearBlend) else1195 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, 1196 1236 AliasingIncludeBottomRight); 1197 1237 exit; … … 1235 1275 AliasingOfs := PointF(-0.0001,-0.0001); 1236 1276 1237 setlength(sums,maxx-minx+ 2); //more for safety1277 setlength(sums,maxx-minx+1); 1238 1278 setlength(shapeRowsList, nbShapes); 1239 1279 … … 1267 1307 end; 1268 1308 1269 rowminx := minx; 1270 rowmaxx := maxx; 1309 if rowminx < minx then rowminx := minx; 1310 if rowmaxx > maxx then rowmaxx := maxx; 1311 1271 1312 if rowminx <= rowmaxx then 1272 1313 begin 1273 if rowminx < minx then rowminx := minx;1274 if rowmaxx > maxx then rowmaxx := maxx;1275 1276 1314 FillChar(sums[rowminx-minx],(rowmaxx-rowminx+1)*sizeof(sums[0]),0); 1277 1315 … … 1298 1336 ec.green := (sumG+sumA shr 1) div sumA; 1299 1337 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; 1302 1340 count := 1; 1303 1341 while (xb < rowmaxx) and (nextSum^.sumA = sumA) and (nextSum^.sumB = sumB) … … 1309 1347 end; 1310 1348 if count = 1 then 1311 DrawExpandedPixelInlineNoAlphaCheck(pdest,ec, sumA) else1349 DrawExpandedPixelInlineNoAlphaCheck(pdest,ec,curAlpha) else 1312 1350 DrawExpandedPixelsInline(pdest, ec, count ); 1313 1351 inc(pdest,count-1); … … 1330 1368 ec.green := (sumG+sumA shr 1) div sumA; 1331 1369 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; 1334 1372 count := 1; 1335 1373 while (xb < rowmaxx) and (nextSum^.sumA = sumA) and (nextSum^.sumB = sumB) … … 1342 1380 if count = 1 then 1343 1381 DrawPixelInlineNoAlphaCheck(pdest,GammaCompression(ec)) else 1382 begin 1344 1383 DrawPixelsInline(pdest, GammaCompression(ec), count ); 1345 inc(pdest,count-1); 1384 inc(pdest,count-1); 1385 end; 1346 1386 end; 1347 1387 end; … … 1362 1402 ec.green := (sumG+sumA shr 1) div sumA; 1363 1403 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; 1366 1406 count := 1; 1367 1407 while (xb < rowmaxx) and (nextSum^.sumA = sumA) and (nextSum^.sumB = sumB) … … 1392 1432 ec.green := (sumG+sumA shr 1) div sumA; 1393 1433 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; 1396 1436 count := 1; 1397 1437 while (xb < rowmaxx) and (nextSum^.sumA = sumA) and (nextSum^.sumB = sumB) … … 1422 1462 ec.green := (sumG+sumA shr 1) div sumA; 1423 1463 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; 1426 1466 count := 1; 1427 1467 while (xb < rowmaxx) and (nextSum^.sumA = sumA) and (nextSum^.sumB = sumB) … … 1454 1494 end; 1455 1495 1496 procedure BorderEllipse(bmp: TBGRACustomBitmap; x, y, rx, ry, w: single; 1497 c: TBGRAPixel; EraseMode: boolean; drawmode: TDrawMode); 1498 var 1499 info: TFillBorderEllipseInfo; 1500 begin 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; 1506 end; 1507 1508 procedure BorderEllipseWithTexture(bmp: TBGRACustomBitmap; x, y, rx, ry, 1509 w: single; scan: IBGRAScanner; drawmode: TDrawMode); 1510 var 1511 info: TFillBorderEllipseInfo; 1512 begin 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; 1518 end; 1519 1456 1520 procedure 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); 1458 1522 var 1459 1523 info: TFillRoundRectangleInfo; 1460 1524 begin 1461 1525 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); 1463 1527 FillShapeAntialias(bmp, info, c, EraseMode,nil, False, LinearBlend); 1464 1528 info.Free; … … 1467 1531 procedure FillRoundRectangleAntialiasWithTexture(bmp: TBGRACustomBitmap; x1, 1468 1532 y1, x2, y2, rx, ry: single; options: TRoundRectangleOptions; 1469 scan: IBGRAScanner; LinearBlend: boolean );1533 scan: IBGRAScanner; LinearBlend: boolean; APixelCenteredCoordinates: boolean); 1470 1534 var 1471 1535 info: TFillRoundRectangleInfo; 1472 1536 begin 1473 1537 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); 1475 1539 FillShapeAntialiasWithTexture(bmp, info, scan, False, LinearBlend); 1476 1540 info.Free; … … 1479 1543 procedure BorderRoundRectangleAntialias(bmp: TBGRACustomBitmap; x1, y1, x2, 1480 1544 y2, rx, ry, w: single; options: TRoundRectangleOptions; c: TBGRAPixel; 1481 EraseMode: boolean; LinearBlend: boolean );1545 EraseMode: boolean; LinearBlend: boolean; APixelCenteredCoordinates: boolean); 1482 1546 var 1483 1547 info: TFillShapeInfo; … … 1493 1557 exit; 1494 1558 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); 1496 1560 FillShapeAntialias(bmp, info, c, EraseMode, nil, False, LinearBlend); 1497 1561 info.Free; … … 1500 1564 procedure BorderRoundRectangleAntialiasWithTexture(bmp: TBGRACustomBitmap; x1, 1501 1565 y1, x2, y2, rx, ry, w: single; options: TRoundRectangleOptions; 1502 scan: IBGRAScanner; LinearBlend: boolean );1566 scan: IBGRAScanner; LinearBlend: boolean; APixelCenteredCoordinates: boolean); 1503 1567 var 1504 1568 info: TFillBorderRoundRectInfo; … … 1514 1578 exit; 1515 1579 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); 1517 1581 FillShapeAntialiasWithTexture(bmp, info, scan, False, LinearBlend); 1518 1582 info.Free; … … 1521 1585 procedure BorderAndFillRoundRectangleAntialias(bmp: TBGRACustomBitmap; x1, y1, 1522 1586 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); 1524 1588 var 1525 1589 info: TFillBorderRoundRectInfo; … … 1527 1591 begin 1528 1592 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); 1530 1594 if not EraseMode then 1531 1595 begin -
GraphicTest/Packages/bgrabitmap/bgrapolygonaliased.pas
r494 r521 105 105 ANumSegment: integer; dy: single; AData: pointer); override; 106 106 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; 109 109 function CreateSegmentData(numPt,nextPt: integer; x,y: single): pointer; override; 110 110 function CreateIntersectionInfo: TIntersectionInfo; override; … … 150 150 ANumSegment: integer; dy: single; AData: pointer); override; 151 151 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; 154 154 function CreateSegmentData(numPt,nextPt: integer; x,y: single): pointer; override; 155 155 function CreateIntersectionInfo: TIntersectionInfo; override; … … 165 165 ANumSegment: integer; dy: single; AData: pointer); override; 166 166 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; 169 169 function CreateSegmentData(numPt,nextPt: integer; x,y: single): pointer; override; 170 170 function CreateIntersectionInfo: TIntersectionInfo; override; … … 196 196 DX, DY: integer; BorderColor, FillColor: TBGRAPixel; FillTexture: IBGRAScanner = nil; ADrawMode: TDrawMode = dmDrawWithTransparency; 197 197 skipFill: boolean = false); 198 procedure BGRAFillRoundRectAliased(dest: TBGRACustomBitmap; X1, Y1, X2, Y2: integer; 199 DX, DY: integer; FillColor: TBGRAPixel; FillTexture: IBGRAScanner = nil; ADrawMode: TDrawMode = dmDrawWithTransparency); 198 200 199 201 implementation 200 202 201 uses Math, BGRABlend ;203 uses Math, BGRABlend, BGRAPolygon; 202 204 203 205 { TPolygonPerspectiveColorGradientInfo } … … 1018 1020 end; 1019 1021 1022 procedure BGRAFillRoundRectAliased(dest: TBGRACustomBitmap; X1, Y1, X2, 1023 Y2: integer; DX, DY: integer; FillColor: TBGRAPixel; 1024 FillTexture: IBGRAScanner; ADrawMode: TDrawMode); 1025 var 1026 fi: TFillRoundRectangleInfo; 1027 begin 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; 1031 end; 1032 1020 1033 end. 1021 1034 -
GraphicTest/Packages/bgrabitmap/bgraqtbitmap.pas
r494 r521 40 40 public 41 41 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; 44 45 procedure Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean = True); override; 45 46 procedure Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean = True); override; … … 69 70 SlowDrawTransparent(Temp, ACanvas, Rect); 70 71 Temp.Free; 72 end; 73 74 procedure TBGRAQtBitmap.DataDrawOpaque(ACanvas: TCanvas; ARect: TRect; 75 AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); 76 var psrc,pdest: PBGRAPixel; 77 bmp: TBGRAQtBitmap; 78 begin 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} 71 103 end; 72 104 -
GraphicTest/Packages/bgrabitmap/bgrareadbmp.pas
r494 r521 24 24 - direct access to pixels with TBGRABitmap 25 25 - 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 26 29 } 27 30 … … 37 40 type 38 41 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 39 63 40 64 { TBGRAReaderBMP } 41 65 42 TBGRAReaderBMP = class (T FPCustomImageReader)66 TBGRAReaderBMP = class (TBGRAImageReader) 43 67 Private 44 68 DeltaX, DeltaY : integer; // Used for the never-used delta option in RLE 45 69 TopDown : boolean; // If set, bitmap is stored top down instead of bottom up 46 continue : boolean; // needed for onprogress event47 Rect : TRect;48 70 Procedure FreeBufs; // Free (and nil) buffers. 49 71 protected 50 72 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 52 76 FPalette : PFPcolor; // Buffer with Palette entries. (useless now) 53 77 FBGRAPalette : PBGRAPixel; … … 62 86 FBufferStream: TStream; 63 87 FHasAlphaValues: boolean; 88 FMaskData: PByte; 89 FMaskDataSize: integer; 64 90 // SetupRead will allocate the needed buffers, and read the colormap if needed. 65 91 procedure SetupRead(nPalette, nRowBits: Integer; Stream : TStream); virtual; … … 74 100 procedure WriteScanLine(Row : Integer; Img : TFPCustomImage); virtual; 75 101 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; 76 105 // required by TFPCustomImageReader 77 106 procedure InternalRead (Stream:TStream; Img:TFPCustomImage); override; … … 81 110 function GetNextBufferByte: byte; 82 111 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); 83 117 public 84 118 MinifyHeight,WantedHeight: integer; 119 Hotspot: TPoint; 120 Subformat: TBitmapSubFormat; 85 121 constructor Create; override; 86 122 destructor Destroy; override; … … 88 124 property OutputHeight: integer read FOutputHeight; 89 125 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 130 function MakeBitmapFileHeader(AData: TStream): TBitMapFileHeader; 91 131 92 132 implementation 93 133 94 type 95 TWriteScanlineProc = procedure (Row : Integer; Img : TFPCustomImage) of object; 96 134 uses math; 135 136 function MakeBitmapFileHeader(AData: TStream): TBitMapFileHeader; 137 var header: PBitMapInfoHeader; 138 headerSize: integer; 139 extraSize: integer; 140 os2header: TOS2BitmapHeader; 141 begin 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; 183 end; 97 184 98 185 function RGBAToFPColor(Const RGBA: TColorRGBA) : TFPcolor; 99 100 186 begin 101 187 with Result, RGBA do … … 125 211 inherited create; 126 212 FTransparencyOption := toTransparent; 213 Subformat:= bsfWithFileHeader; 127 214 end; 128 215 … … 134 221 end; 135 222 223 function TBGRAReaderBMP.GetQuickInfo(AStream: TStream): TQuickImageInfo; 224 var headerSize: dword; 225 os2header: TOS2BitmapHeader; 226 minHeader: TMinimumBitmapHeader; 227 totalDepth: integer; 228 headerPos: int64; 229 begin 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; 277 end; 278 279 function TBGRAReaderBMP.GetBitmapDraft(AStream: TStream; AMaxWidth, 280 AMaxHeight: integer; out AOriginalWidth, AOriginalHeight: integer): TBGRACustomBitmap; 281 var 282 bmpFormat: TBGRAReaderBMP; 283 prevStreamPos: Int64; 284 begin 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; 298 end; 299 136 300 procedure TBGRAReaderBMP.FreeBufs; 137 138 301 begin 139 302 If (LineBuf<>Nil) then … … 233 396 var 234 397 ColInfo: ARRAY OF TColorRGBA; 235 i: Integer; 398 ColInfo3: packed array of TColorRGB; 399 i,colorPresent: Integer; 236 400 237 401 begin … … 262 426 SetLength(ColInfo, nPalette); 263 427 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; 267 442 for i := 0 to High(ColInfo) do 268 443 begin … … 282 457 283 458 Var 284 PrevSourceRow,SourceRow, i, pallen, SourceRowDelta, SourceLastRow: Integer;459 i, pallen : Integer; 285 460 BadCompression : boolean; 286 461 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 466 begin 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; 305 492 { This will move past any junk after the BFI header } 306 493 Stream.Position:=Stream.Position-SizeOf(BFI)+BFI.Size; … … 339 526 32: 340 527 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; 343 532 Try 344 533 { Note: it would be better to Fill the image palette in setupread instead of creating FPalette. … … 350 539 if pallen>0 then 351 540 begin 541 if FPalette = nil then raise exception.Create('Internal error: palette object not initialized'); 352 542 Img.Palette.Count:=pallen; 353 543 for i:=0 to pallen-1 do 354 544 Img.Palette.Color[i]:=FPalette[i]; 355 545 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 406 555 if Img is TBGRACustomBitmap then 407 556 WriteScanlineProc := @WriteScanLineBGRA else 408 557 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 444 573 finally 445 if (BFI.Compression=BI_RLE8) or(BFI.Compression=BI_RLE4) then CloseReadBuffer;446 574 FreeBufs; 447 575 end; … … 729 857 for Column:=0 to img.Width-1 do 730 858 begin 731 PDest^:= BGRA((PSrc )^,(PSrc+1)^,(PSrc+2)^,(PSrc+3)^);859 PDest^:= BGRA((PSrc+2)^,(PSrc+1)^,(PSrc)^,(PSrc+3)^); 732 860 if PDest^.alpha <> 0 then FHasAlphaValues:= true; 733 861 inc(PDest); … … 750 878 end; 751 879 880 procedure TBGRAReaderBMP.ReadMaskLine(Row: Integer; Stream: TStream); 881 begin 882 FillChar(FMaskData^, FMaskDataSize, 0); 883 Stream.Read(FMaskData^, FMaskDataSize); 884 end; 885 886 procedure TBGRAReaderBMP.SkipMaskLine(Row: Integer; Stream: TStream); 887 begin 888 Stream.Position := Stream.Position+FMaskDataSize; 889 end; 890 891 procedure TBGRAReaderBMP.WriteMaskLine(Row: Integer; Img: TFPCustomImage); 892 var x, maskPos: integer; 893 bit: byte; 894 bmp: TBGRACustomBitmap; 895 pimg: PBGRAPixel; 896 begin 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; 927 end; 928 752 929 function 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 930 begin 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; 763 950 end; 764 951 … … 814 1001 end; 815 1002 1003 procedure TBGRAReaderBMP.LoadMask(Stream: TStream; Img: TFPCustomImage; var ShouldContinue: boolean); 1004 begin 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; 1015 end; 1016 1017 procedure TBGRAReaderBMP.MainProgressProc(Percent: integer; 1018 var ShouldContinue: boolean); 1019 begin 1020 Progress(psRunning,Percent,false,EmptyRect,'',ShouldContinue); 1021 end; 1022 1023 procedure TBGRAReaderBMP.ImageVerticalLoop(Stream: TStream; 1024 Img: TFPCustomImage; ReadProc, SkipProc: TReadScanlineProc; 1025 WriteProc: TWriteScanlineProc; ProgressProc: TProgressProc; 1026 var ShouldContinue: boolean); 1027 var 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; 1036 begin 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; 1104 end; 816 1105 817 1106 initialization -
GraphicTest/Packages/bgrabitmap/bgrareadico.pas
r494 r521 7 7 8 8 uses 9 Classes, SysUtils, FPimage ;9 Classes, SysUtils, FPimage{$IFDEF BGRABITMAP_USE_LCL}, Graphics{$ENDIF}; 10 10 11 11 type 12 {$IFDEF BGRABITMAP_USE_LCL}TCustomIconClass = class of TCustomIcon;{$ENDIF} 13 TByteSet = set of byte; 12 14 13 { TBGRAReaderIco }15 { TBGRAReaderIcoOrCur } 14 16 15 TBGRAReaderIco = class(TFPCustomImageReader)17 TBGRAReaderIcoOrCur = class(TFPCustomImageReader) 16 18 protected 17 19 procedure InternalRead({%H-}Str: TStream; {%H-}Img: TFPCustomImage); override; 18 20 function InternalCheck(Str: TStream): boolean; override; 21 function ExpectedMagic: TByteSet; virtual; abstract; 22 {$IFDEF BGRABITMAP_USE_LCL}function LazClass: TCustomIconClass; virtual; abstract;{$ENDIF} 19 23 public 20 24 WantedWidth, WantedHeight : integer; 21 25 end; 22 26 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 23 41 implementation 24 42 25 uses BGRABitmapTypes{$IFDEF BGRABITMAP_USE_LCL}, Graphics{$ENDIF}; 43 uses BGRABitmapTypes{$IFNDEF BGRABITMAP_USE_LCL}, BGRAIconCursor{$ENDIF}; 44 45 { TBGRAReaderCur } 46 47 function TBGRAReaderCur.ExpectedMagic: TByteSet; 48 begin 49 result := [2]; 50 end; 51 52 {$IFDEF BGRABITMAP_USE_LCL}function TBGRAReaderCur.LazClass: TCustomIconClass; 53 begin 54 result := TCursorImage; 55 end;{$ENDIF} 26 56 27 57 { TBGRAReaderIco } 28 58 29 procedure TBGRAReaderIco.InternalRead(Str: TStream; Img: TFPCustomImage); 59 function TBGRAReaderIco.ExpectedMagic: TByteSet; 60 begin 61 result := [1,2]; 62 end; 63 64 {$IFDEF BGRABITMAP_USE_LCL}function TBGRAReaderIco.LazClass: TCustomIconClass; 65 begin 66 result := TIcon; 67 end;{$ENDIF} 68 69 { TBGRAReaderIcoOrCur } 70 71 procedure TBGRAReaderIcoOrCur.InternalRead(Str: TStream; Img: TFPCustomImage); 30 72 {$IFDEF BGRABITMAP_USE_LCL} 31 var ico: T Icon; i,bestIdx: integer;73 var ico: TCustomIcon; i,bestIdx: integer; 32 74 height,width: word; format:TPixelFormat; 33 75 bestHeight,bestWidth: integer; maxFormat: TPixelFormat; … … 36 78 if WantedWidth > 0 then compWidth:= WantedWidth else compWidth:= 65536; 37 79 if WantedHeight > 0 then compHeight:= WantedHeight else compHeight:= 65536; 38 ico := TIcon.Create;80 ico := LazClass.Create; 39 81 try 40 82 ico.LoadFromStream(Str); … … 47 89 ico.GetDescription(i,format,height,width); 48 90 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)) then91 ((height = bestHeight) and (width = bestWidth) and (format > maxFormat)) then 50 92 begin 51 93 bestIdx := i; … … 59 101 begin 60 102 ico.Current := bestIdx; 61 (Img as TBGRACustomBitmap).Assign(ico);103 Img.Assign(ico); 62 104 end; 63 105 finally … … 66 108 end; 67 109 {$ELSE} 110 var icoCur: TBGRAIconCursor; 111 compWidth,compHeight: integer; 112 bmp: TBGRACustomBitmap; 68 113 begin 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; 70 127 end; 71 128 {$ENDIF} 72 129 73 function TBGRAReaderIco .InternalCheck(Str: TStream): boolean;130 function TBGRAReaderIcoOrCur.InternalCheck(Str: TStream): boolean; 74 131 var {%H-}magic: packed array[0..5] of byte; 75 132 oldPos: int64; … … 79 136 str.Position:= oldPos; 80 137 if result then 81 result := (magic[0] = $00) and (magic[1] = $00) and (magic[2] in [$01,$02]) and (magic[3] = $00) and138 result := (magic[0] = $00) and (magic[1] = $00) and (magic[2] in ExpectedMagic) and (magic[3] = $00) and 82 139 (magic[4] + (magic[5] shl 8) > 0); 83 140 end; … … 86 143 87 144 DefaultBGRAImageReader[ifIco] := TBGRAReaderIco; 145 DefaultBGRAImageReader[ifCur] := TBGRAReaderCur; 88 146 89 147 end. -
GraphicTest/Packages/bgrabitmap/bgrareadlzp.pas
r494 r521 96 96 str.Position:= oldPos; 97 97 InternalReadCompressableBitmap(str,Img); 98 if Str.Position < Str.Sizethen InternalReadLayers(Str,Img);98 if (Str.Position < Str.Size) and (FCaption = 'Preview') then InternalReadLayers(Str,Img); 99 99 end; 100 100 end; … … 169 169 nameLen := LEtoN(str.ReadDWord); 170 170 setlength(ACaption, nameLen); 171 {$PUSH}{$RANGECHECKS OFF} 171 172 str.ReadBuffer(ACaption[1], nameLen); 173 {$POP} 172 174 channelFlags := str.ReadByte; 173 175 NbPixels := w*h; -
GraphicTest/Packages/bgrabitmap/bgrareadpng.pas
r494 r521 40 40 { TBGRAReaderPNG } 41 41 42 TBGRAReaderPNG = class (T FPCustomImageReader)42 TBGRAReaderPNG = class (TBGRAImageReader) 43 43 private 44 44 … … 133 133 property OriginalWidth: integer read GetOriginalWidth; 134 134 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; 135 137 end; 136 138 137 139 implementation 138 140 139 141 uses math; 140 142 141 143 const StartPoints : array[0..7, 0..1] of word = … … 163 165 end; 164 166 167 function TBGRAReaderPNG.GetQuickInfo(AStream: TStream): TQuickImageInfo; 168 const headerChunkSize = 13; 169 var 170 {%H-}FileHeader : packed array[0..7] of byte; 171 {%H-}ChunkHeader : TChunkHeader; 172 {%H-}HeaderChunk : THeaderChunk; 173 begin 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; 196 end; 197 198 function TBGRAReaderPNG.GetBitmapDraft(AStream: TStream; AMaxWidth, 199 AMaxHeight: integer; out AOriginalWidth, AOriginalHeight: integer): TBGRACustomBitmap; 200 var 201 png: TBGRAReaderPNG; 202 begin 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; 213 end; 214 165 215 procedure TBGRAReaderPNG.ReadChunk; 166 167 216 var {%H-}ChunkHeader : TChunkHeader; 168 217 readCRC : longword; … … 520 569 UsingBitGroup := 0; 521 570 DataIndex := 0; 571 {$PUSH}{$RANGECHECKS OFF} //because PByteArray is limited to 32767 522 572 if (UsingBitGroup = 0) and (Header.BitDepth <> 16) then 523 573 case ByteWidth of … … 583 633 end; 584 634 end; 635 {$POP} 585 636 586 637 X := StartX; … … 694 745 end; 695 746 696 function TBGRAReaderPNG.ColorGray1 (const CD:TColorDAta): TFPColor;747 function TBGRAReaderPNG.ColorGray1(const CD: TColorData): TFPColor; 697 748 begin 698 749 if CD = 0 then … … 702 753 end; 703 754 704 function TBGRAReaderPNG.ColorGray2 (const CD:TColorDAta): TFPColor;755 function TBGRAReaderPNG.ColorGray2(const CD: TColorData): TFPColor; 705 756 var c : NativeUint; 706 757 begin … … 718 769 end; 719 770 720 function TBGRAReaderPNG.ColorGray4 (const CD:TColorDAta): TFPColor;771 function TBGRAReaderPNG.ColorGray4(const CD: TColorData): TFPColor; 721 772 var c : NativeUint; 722 773 begin … … 733 784 end; 734 785 735 function TBGRAReaderPNG.ColorGray8 (const CD:TColorDAta): TFPColor;786 function TBGRAReaderPNG.ColorGray8(const CD: TColorData): TFPColor; 736 787 var c : NativeUint; 737 788 begin … … 747 798 end; 748 799 749 function TBGRAReaderPNG.ColorGray16 (const CD:TColorDAta): TFPColor;800 function TBGRAReaderPNG.ColorGray16(const CD: TColorData): TFPColor; 750 801 var c : NativeUint; 751 802 begin … … 1065 1116 while Count4 > 0 do 1066 1117 begin 1067 {$push}{$r-} 1118 {$push}{$r-}{$q-} 1068 1119 PDWord(p)^ := (((PDWord(pPrev)^ and $00FF00FF) + (PDWord(p)^ and $00FF00FF)) and $00FF00FF) 1069 1120 or (((PDWord(pPrev)^ and $FF00FF00) + (PDWord(p)^ and $FF00FF00)) and $FF00FF00); … … 1307 1358 // Check IHDR 1308 1359 ReadChunk; 1309 move (chunk.data^, FHeader, sizeof(Header)); 1360 fillchar(FHeader, sizeof(FHeader), 0); 1361 move (chunk.data^, FHeader, min(sizeof(Header), chunk.alength)); 1310 1362 with header do 1311 1363 begin -
GraphicTest/Packages/bgrabitmap/bgraresample.pas
r494 r521 26 26 NewWidth, NewHeight: integer): TBGRACustomBitmap; 27 27 procedure 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); 29 29 procedure DownSamplePutImage(source: TBGRACustomBitmap; factorX,factorY: integer; dest: TBGRACustomBitmap; OffsetX,OffsetY: Integer; ADrawMode: TDrawMode); 30 30 function DownSample(source: TBGRACustomBitmap; factorX,factorY: integer): TBGRACustomBitmap; … … 53 53 public 54 54 Coeff: single; 55 constructor Create; 56 constructor Create(ACoeff: single); 55 constructor Create; overload; 56 constructor Create(ACoeff: single); overload; 57 57 function Interpolation(t: single): single; override; 58 58 function ShouldCheckRange: boolean; override; … … 112 112 113 113 procedure 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); 115 115 type 116 116 TTransitionState = (tsNone, tsPlain, tsLeft, tsMiddle, tsRight); … … 136 136 newTransition: TTransitionState; 137 137 begin 138 if DeltaSrc=0then138 if (DeltaSrc=0) or ANoTransition then 139 139 begin 140 140 PDest^ := PSrc^; … … 154 154 begin 155 155 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; 162 159 pdest^.red := (psrc^.red + (psrc+DeltaSrc)^.red + 1) shr 1; 163 160 pdest^.green := (psrc^.green + (psrc+DeltaSrc)^.green + 1) shr 1; … … 165 162 end else 166 163 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; 173 182 end; 174 183 end else … … 176 185 begin 177 186 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; 184 190 pdest^.red := (psrc^.red + (psrc+DeltaSrc)^.red*3 + 2) shr 2; 185 191 pdest^.green := (psrc^.green + (psrc+DeltaSrc)^.green*3 + 2) shr 2; … … 187 193 end else 188 194 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; 195 213 end; 196 214 end else 197 215 begin 198 216 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; 205 220 pdest^.red := (psrc^.red*3 + (psrc+DeltaSrc)^.red + 2) shr 2; 206 221 pdest^.green := (psrc^.green*3 + (psrc+DeltaSrc)^.green + 2) shr 2; … … 208 223 end else 209 224 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; 216 243 end; 217 244 end; … … 1176 1203 ssRoundOutside: result := TSplineKernel.Create(0.75); 1177 1204 ssVertexToSide: result := TSplineKernel.Create(1); 1205 ssEasyBezier: raise Exception.Create('EasyBezier does not have an interpolator'); 1178 1206 else 1179 1207 raise Exception.Create('Unknown spline style'); -
GraphicTest/Packages/bgrabitmap/bgrascene3d.pas
r494 r521 152 152 FetchThrowsException: boolean; 153 153 154 constructor Create; 155 constructor Create(ASurface: TBGRACustomBitmap); 154 constructor Create; overload; 155 constructor Create(ASurface: TBGRACustomBitmap); overload; 156 156 destructor Destroy; override; 157 157 procedure Clear; virtual; … … 169 169 procedure LookUp(angleDeg: single); 170 170 procedure LookDown(angleDeg: single); 171 procedure Render; virtual;172 procedure Render(ARenderer: TCustomRenderer3D); 171 procedure Render; overload; virtual; 172 procedure Render(ARenderer: TCustomRenderer3D); overload; 173 173 function CreateObject: IBGRAObject3D; overload; 174 174 function CreateObject(ATexture: IBGRAScanner): IBGRAObject3D; overload; … … 179 179 function CreateHalfSphere(ARadius: Single; AColor: TBGRAPixel; AHorizPrecision: integer = 6; AVerticalPrecision : integer = 6): IBGRAObject3D; overload; 180 180 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; 185 185 procedure RemoveLight(ALight: IBGRALight3D); 186 186 procedure SetZoom(value: Single); overload; 187 187 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; 190 190 function GetMaterialByName(AName: string): IBGRAMaterial3D; 191 191 procedure UpdateMaterials; virtual; … … 949 949 950 950 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); 954 954 end; 955 955 956 956 function GetColorF: TColorF; 957 957 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); 963 963 result := ColorF(r,g,b,1); 964 964 end; -
GraphicTest/Packages/bgrabitmap/bgrascenetypes.pas
r494 r521 253 253 IBGRAPart3D = interface 254 254 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; 268 268 function GetTotalNormalCount: integer; 269 269 function IndexOf(AVertex: IBGRAVertex3D): integer; … … 282 282 function GetContainer: IBGRAPart3D; 283 283 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; 287 287 procedure SetMatrix(const AValue: TMatrix3D); 288 288 procedure SetNormal(AIndex: Integer; AValue: IBGRANormal3D); 289 289 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; 292 292 procedure RotateXDeg(angle: single; Before: boolean = true); 293 293 procedure RotateYDeg(angle: single; Before: boolean = true); … … 418 418 procedure ForEachFace(ACallback: TFace3DCallback); 419 419 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; 425 425 procedure Update; 426 426 procedure SetBiface(AValue : boolean); -
GraphicTest/Packages/bgrabitmap/bgraslicescaling.pas
r494 r521 66 66 // or as a local owned copy in other cases 67 67 constructor Create(ABitmap: TBGRABitmap; 68 AMarginTop, AMarginRight, AMarginBottom, AMarginLeft: integer; ABitmapOwner: boolean = false); 68 AMarginTop, AMarginRight, AMarginBottom, AMarginLeft: integer; ABitmapOwner: boolean = false); overload; 69 69 constructor Create(ABitmap: TBitmap; 70 AMarginTop, AMarginRight, AMarginBottom, AMarginLeft: integer); 70 AMarginTop, AMarginRight, AMarginBottom, AMarginLeft: integer); overload; 71 71 constructor Create(AFilename: string; 72 AMarginTop, AMarginRight, AMarginBottom, AMarginLeft: integer); 72 AMarginTop, AMarginRight, AMarginBottom, AMarginLeft: integer); overload; 73 73 constructor Create(AFilename: string; AIsUtf8: boolean; 74 AMarginTop, AMarginRight, AMarginBottom, AMarginLeft: integer); 74 AMarginTop, AMarginRight, AMarginBottom, AMarginLeft: integer); overload; 75 75 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; 85 85 destructor Destroy; override; 86 86 public … … 88 88 //so new bitmaps should be used 89 89 // Draw 90 procedure Draw(ABitmap: TBGRABitmap; ARect: TRect; DrawGrid: boolean = False); 90 procedure Draw(ABitmap: TBGRABitmap; ARect: TRect; DrawGrid: boolean = False); overload; 91 91 procedure Draw(ABitmap: TBGRABitmap; ALeft, ATop, AWidth, AHeight: integer; 92 DrawGrid: boolean = False); 92 DrawGrid: boolean = False); overload; 93 93 procedure AutodetectRepeat; 94 94 public … … 124 124 constructor Create(ABitmap: TBGRABitmap; 125 125 AMarginTop, AMarginRight, AMarginBottom, AMarginLeft, NumberOfItems: integer; 126 Direction: TSliceScalingDirection; ABitmapOwner: boolean = false); 126 Direction: TSliceScalingDirection; ABitmapOwner: boolean = false); overload; 127 127 constructor Create(ABitmap: TBitmap; 128 128 AMarginTop, AMarginRight, AMarginBottom, AMarginLeft, NumberOfItems: integer; 129 Direction: TSliceScalingDirection); 129 Direction: TSliceScalingDirection); overload; 130 130 constructor Create(ABitmapFilename: string; 131 131 AMarginTop, AMarginRight, AMarginBottom, AMarginLeft, NumberOfItems: integer; 132 Direction: TSliceScalingDirection); 132 Direction: TSliceScalingDirection); overload; 133 133 constructor Create(ABitmapFilename: string; AIsUtf8: boolean; 134 134 AMarginTop, AMarginRight, AMarginBottom, AMarginLeft, NumberOfItems: integer; 135 Direction: TSliceScalingDirection); 135 Direction: TSliceScalingDirection); overload; 136 136 constructor Create(AStream: TStream; 137 137 AMarginTop, AMarginRight, AMarginBottom, AMarginLeft, NumberOfItems: integer; 138 Direction: TSliceScalingDirection); 138 Direction: TSliceScalingDirection); overload; 139 139 destructor Destroy; override; 140 constructor Create(AIniFilename, ASection: string; AIsUtf8Filename: boolean= false); 140 constructor Create(AIniFilename, ASection: string; AIsUtf8Filename: boolean= false); overload; 141 141 public 142 142 procedure Draw(ItemNumber: integer; ABitmap: TBGRABitmap; 143 ARect: TRect; DrawGrid: boolean = False); 143 ARect: TRect; DrawGrid: boolean = False); overload; 144 144 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; 146 146 public 147 147 property SliceScalingArray: TSliceScalingArray -
GraphicTest/Packages/bgrabitmap/bgraspritegl.pas
r494 r521 32 32 function GetLayer: Integer; virtual; abstract; 33 33 function GetLocation: TPointF; virtual; 34 function GetVisible: Boolean; virtual; 34 35 function GetW: Single; virtual; abstract; 35 36 function GetX: Single; virtual; abstract; … … 46 47 procedure SetLocation(AValue: TPointF); virtual; 47 48 procedure SetW(AValue: Single); virtual; abstract; 49 procedure SetVisible({%H-}AValue: boolean); virtual; 48 50 procedure SetX(AValue: Single); virtual; abstract; 49 51 procedure SetY(AValue: Single); virtual; abstract; … … 54 56 destructor Destroy; override; 55 57 procedure OnDraw; virtual; 56 procedure OnElapse( AElapsedMs: integer); virtual;58 procedure OnElapse({%H-}AElapsedMs: integer); virtual; 57 59 procedure OnTimer; virtual; 58 60 procedure QueryDestroy; virtual; abstract; … … 71 73 property HorizontalAlign: TAlignment read GetHorizontalAlign write SetHorizontalAlign; 72 74 property VerticalAlign: TTextLayout read GetVerticalAlign write SetVerticalAlign; 75 property Visible : Boolean read GetVisible write SetVisible; 73 76 property Texture : IBGLTexture read GetTexture; 74 77 property Handle : Pointer read GetHandle; … … 86 89 FQueryDestroy: boolean; 87 90 FLayer: integer; 91 FHidden: boolean; 88 92 function GetHorizontalAlign: TAlignment; override; 89 93 function GetVerticalAlign: TTextLayout; override; … … 97 101 function GetH: Single; override; 98 102 function GetLayer: Integer; override; 103 function GetVisible: Boolean; override; 99 104 function GetW: Single; override; 100 105 function GetX: Single; override; … … 107 112 procedure SetH(AValue: Single); override; 108 113 procedure SetLayer(AValue: Integer); override; 114 procedure SetVisible(AValue: boolean); override; 109 115 procedure SetW(AValue: Single); override; 110 116 procedure SetX(AValue: Single); override; … … 342 348 end; 343 349 350 function TBGLDefaultSprite.GetVisible: Boolean; 351 begin 352 Result:= not FHidden; 353 end; 354 344 355 function TBGLDefaultSprite.GetW: Single; 345 356 begin … … 390 401 begin 391 402 FLayer:= AValue; 403 end; 404 405 procedure TBGLDefaultSprite.SetVisible(AValue: boolean); 406 begin 407 FHidden := not AValue; 392 408 end; 393 409 … … 487 503 end; 488 504 505 function TBGLCustomSprite.GetVisible: Boolean; 506 begin 507 result := true; 508 end; 509 489 510 procedure TBGLCustomSprite.SetLocation(AValue: TPointF); 490 511 begin 491 512 X := AValue.X; 492 513 Y := AValue.Y; 514 end; 515 516 procedure TBGLCustomSprite.SetVisible(AValue: boolean); 517 begin 518 raise ENotImplemented.Create('Not implemented in base class'); 493 519 end; 494 520 … … 536 562 var NumFrame: integer; 537 563 begin 538 if Texture <> nilthen564 if Visible and (Texture <> nil) then 539 565 begin 540 566 NumFrame := Trunc(Frame+0.5); -
GraphicTest/Packages/bgrabitmap/bgrastreamlayers.pas
r494 r521 2 2 3 3 {$mode objfpc}{$H+} 4 {$MODESWITCH ADVANCEDRECORDS} 4 5 5 6 interface … … 9 10 10 11 function CheckStreamForLayers(AStream: TStream): boolean; 11 function LoadLayersFromStream(AStream: TStream; out ASelectedLayerIndex: integer; ALoadLayerUniqueIds: boolean = false) : TBGRALayeredBitmap; 12 function LoadLayersFromStream(AStream: TStream; out ASelectedLayerIndex: integer; ALoadLayerUniqueIds: boolean = false; 13 ADestination: TBGRALayeredBitmap = nil): TBGRALayeredBitmap; 12 14 procedure SaveLayersToStream(AStream: TStream; ALayers: TBGRACustomLayeredBitmap; ASelectedLayerIndex: integer; ACompression: TLzpCompression = lzpZStream); 13 15 procedure SaveLayerBitmapToStream(AStream: TStream; ABitmap: TBGRABitmap; ACaption: string; ACompression: TLzpCompression = lzpZStream); … … 18 20 19 21 uses BGRABitmapTypes, BGRACompressableBitmap, zstream, BGRAReadLzp, BGRAWriteLzp, 20 BGRAUTF8; 22 BGRAUTF8, Math; 23 24 type 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 41 procedure TLayerHeader.FixEndian; 42 begin 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])); 59 end; 21 60 22 61 procedure SaveLayeredBitmapToStream(AStream: TStream; ALayers: TBGRACustomLayeredBitmap); … … 25 64 end; 26 65 27 function LoadLayeredBitmapFromStream(AStream: TStream) : TBGRALayeredBitmap;66 procedure LoadLayeredBitmapFromStream(AStream: TStream; ALayers: TBGRACustomLayeredBitmap); 28 67 var selectedIndex: integer; 29 68 begin 30 69 if not CheckStreamForLayers(AStream) then 31 result := nil 70 begin 71 if Assigned(ALayers) then ALayers.Clear; 72 end 32 73 else 33 result := LoadLayersFromStream(AStream,selectedIndex);74 LoadLayersFromStream(AStream,selectedIndex,false,ALayers as TBGRALayeredBitmap); 34 75 end; 35 76 … … 60 101 end; 61 102 62 function LoadLayersFromStream(AStream: TStream; out ASelectedLayerIndex: integer; ALoadLayerUniqueIds: boolean = false): TBGRALayeredBitmap; 103 function LoadLayersFromStream(AStream: TStream; out ASelectedLayerIndex: integer; ALoadLayerUniqueIds: boolean = false; 104 ADestination: TBGRALayeredBitmap = nil): TBGRALayeredBitmap; 63 105 var 64 106 OldPosition: Int64; 65 107 HeaderFound: string; 66 NbLayers : LongInt;108 NbLayers, canvasWidth, canvasHeight: LongInt; 67 109 HeaderSize, LayerHeaderSize: LongInt; 68 LayerStackStartPosition, LayerHeaderPosition, LayerBitmapPosition, LayerEndPosition: Int64; 69 LayerOption,StackOption: LongInt; 110 LayerStackStartPosition, LayerHeaderPosition, 111 LayerBitmapPosition, LayerEndPosition, MemDirPos: Int64; 112 StackOption: LongInt; 70 113 Layer: TBGRABitmap; 71 114 i,LayerIndex: integer; 72 115 LayerName: string; 73 LayerId: LongInt;74 116 Compression: TLzpCompression; 75 LayerVisible: boolean;76 117 LayerBlendOp: TBlendOperation; 77 LayerOffset: TPoint;78 LayerOpacity: integer;79 118 LayerIdFound: boolean; 80 LayerBitmapSize: integer; 81 begin 82 result := TBGRALayeredBitmap.Create; 119 h: TLayerHeader; 120 begin 121 if Assigned(ADestination) then 122 begin 123 result := ADestination; 124 result.Clear; 125 end else 126 result := TBGRALayeredBitmap.Create; 83 127 OldPosition:= AStream.Position; 84 128 SetLength(HeaderFound, length(StreamHeader)); … … 106 150 result.LinearBlend := (StackOption and 1) = 1; 107 151 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; 108 164 //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; 109 172 110 173 AStream.Position:= LayerStackStartPosition; … … 112 175 begin 113 176 LayerHeaderSize:= LEReadLongint(AStream); 177 114 178 LayerHeaderPosition := AStream.Position; 115 179 LayerBitmapPosition := LayerHeaderPosition + LayerHeaderSize; 116 180 LayerEndPosition := -1; 117 181 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; 149 201 150 202 AStream.Position:= LayerBitmapPosition; … … 155 207 156 208 result.LayerName[LayerIndex] := LayerName; 157 result.LayerVisible[LayerIndex] := LayerVisible;209 result.LayerVisible[LayerIndex] := (h.LayerOption and 1) = 1; 158 210 result.BlendOperation[LayerIndex]:= LayerBlendOp; 159 result.LayerOffset[LayerIndex] := LayerOffset;211 result.LayerOffset[LayerIndex] := Point(h.LayerOfsX,h.LayerOfsY); 160 212 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; 163 218 164 219 if LayerEndPosition <> -1 then AStream.Position := LayerEndPosition; 165 220 end; 221 result.NotifyLoaded; 166 222 except 167 223 on ex: Exception do 168 224 begin 169 225 AStream.Position := OldPosition; 226 if not Assigned(ADestination) then result.Free; 170 227 raise ex; 171 228 end; … … 175 232 procedure SaveLayersToStream(AStream: TStream; ALayers: TBGRACustomLayeredBitmap; ASelectedLayerIndex: integer; ACompression: TLzpCompression); 176 233 var 177 LayerOption,StackOption: longint;234 StackOption: longint; 178 235 i: integer; 179 LayerHeaderSizePosition,LayerHeaderPosition: int64;180 Layer BitmapPosition,LayerBitmapSizePosition,BitmapSize: int64;181 Layer HeaderSize: integer;236 DirectoryOffsetPos, EndPos: int64; 237 LayerHeaderPosition: int64; 238 LayerBitmapPosition,BitmapSize, startPos: int64; 182 239 bitmap: TBGRABitmap; 240 h: TLayerHeader; 183 241 begin 184 242 if (ASelectedLayerIndex < -1) or (ASelectedLayerIndex >= ALayers.NbLayers) then 185 243 raise exception.Create('Selected layer out of bounds'); 244 245 ALayers.NotifySaving; 246 247 startPos := AStream.Position; 186 248 AStream.Write(StreamHeader[1], length(StreamHeader)); 187 LEWriteLongint(AStream, 12); //header size249 LEWriteLongint(AStream, 28); //header size 188 250 LEWriteLongint(AStream, ALayers.NbLayers); 189 251 LEWriteLongint(AStream, ASelectedLayerIndex); … … 192 254 if ACompression = lzpRLE then StackOption:= StackOption or 2; 193 255 LEWriteLongint(AStream, StackOption); 256 LEWriteLongint(AStream, ALayers.Width); 257 LEWriteLongint(AStream, ALayers.Height); 258 DirectoryOffsetPos := AStream.Position; 259 LEWriteInt64(AStream, 0); 194 260 //end of header 195 261 196 262 for i := 0 to ALayers.NbLayers-1 do 197 263 begin 198 LayerHeaderSizePosition:= AStream.Position; 199 LEWriteLongint(AStream, 0); //header size not computed yet 264 LEWriteLongint(AStream, sizeof(h)); 200 265 LayerHeaderPosition := AStream.Position; 201 266 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 212 283 LayerBitmapPosition:=AStream.Position; 213 LayerHeaderSize := LayerBitmapPosition - LayerHeaderPosition;214 AStream.Position:= LayerHeaderSizePosition;215 LEWriteLongint(AStream, LayerHeaderSize);216 //end of layer header217 218 AStream.Position:= LayerBitmapPosition;219 bitmap := ALayers.GetLayerBitmapDirectly(i);220 284 if bitmap <> nil then 221 285 SaveLayerBitmapToStream(AStream, bitmap, ALayers.LayerName[i], ACompression) … … 226 290 bitmap.free; 227 291 end; 292 228 293 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 233 299 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); 234 309 end; 235 310 end; … … 271 346 LayeredBitmapSaveToStreamProc := @SaveLayeredBitmapToStream; 272 347 LayeredBitmapLoadFromStreamProc := @LoadLayeredBitmapFromStream; 273 end; 348 LayeredBitmapCheckStreamProc := @CheckStreamForLayers; 349 end; 350 351 initialization 352 353 RegisterStreamLayers; 274 354 275 355 end. -
GraphicTest/Packages/bgrabitmap/bgrasvg.pas
r494 r521 7 7 uses 8 8 Classes, SysUtils, BGRABitmapTypes, laz2_DOM, BGRAUnits, BGRASVGShapes, 9 BGRACanvas2D; 9 BGRACanvas2D, BGRASVGType, FPimage; 10 11 type 12 TCSSUnit = BGRAUnits.TCSSUnit; 13 14 const 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; 10 25 11 26 type … … 21 36 TSVGUnits = class(TCSSUnitConverter) 22 37 private 38 FOnRecompute: TSVGRecomputeEvent; 39 FViewOffset: TPointF; 23 40 function GetCustomDpi: TPointF; 24 41 procedure Recompute; 42 procedure SetOnRecompute(AValue: TSVGRecomputeEvent); 25 43 protected 26 44 FSvg: TDOMElement; 27 45 FViewBox: TSVGViewBox; 28 FViewSize: TSVGSize; 46 FOriginalViewSize, FProportionalViewSize: TSVGSize; 47 29 48 FDefaultUnitHeight, FDefaultUnitWidth: TFloatWithCSSUnit; 30 49 FDefaultDpi: PSingle; 31 50 FUseDefaultDPI: boolean; 32 51 FDpiScaleX,FDpiScaleY: single; 52 FContainerHeight: TFloatWithCSSUnit; 53 FContainerWidth: TFloatWithCSSUnit; 54 procedure SetContainerHeight(AValue: TFloatWithCSSUnit); 55 procedure SetContainerWidth(AValue: TFloatWithCSSUnit); 33 56 function GetDefaultUnitHeight: TFloatWithCSSUnit; override; 34 57 function GetDefaultUnitWidth: TFloatWithCSSUnit; override; … … 47 70 procedure SetDefaultDpiAndOrigin; 48 71 constructor Create(ASvg: TDOMElement; ADefaultDpi: PSingle); 72 function GetStretchRectF(AViewSize: TRectF; par: TSVGPreserveAspectRatio): TRectF; 49 73 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; 50 77 property CustomOrigin: TPointF read GetCustomOrigin write SetCustomOrigin; 51 78 property CustomDpiX: single read GetCustomDpiX; 52 79 property CustomDpiY: single read GetCustomDpiY; 53 80 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; 54 84 end; 55 85 … … 58 88 TBGRASVG = class 59 89 private 60 function GetAttribute(AName: string): string; 90 function GetAttribute(AName: string): string; overload; 91 function GetAttribute(AName: string; ADefault: string): string; overload; 61 92 function GetCustomDpi: TPointF; 62 93 function GetHeight: TFloatWithCSSUnit; 63 94 function GetHeightAsCm: single; 64 95 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; 68 100 procedure GetViewBoxIndirect(AUnit: TCSSUnit; out AViewBox: TSVGViewBox); 101 function GetViewMin(AUnit: TCSSUnit): TPointF; 102 function GetViewSize(AUnit: TCSSUnit): TPointF; 69 103 function GetWidth: TFloatWithCSSUnit; 70 104 function GetWidthAsCm: single; … … 77 111 procedure SetHeightAsCm(AValue: single); 78 112 procedure SetHeightAsInch(AValue: single); 79 procedure SetPreserveAspectRatio(AValue: string); 113 procedure SetPreserveAspectRatio(AValue: TSVGPreserveAspectRatio); 114 procedure SetUTF8String(AValue: utf8string); 80 115 procedure SetViewBox(AValue: TSVGViewBox); 81 116 procedure SetWidth(AValue: TFloatWithCSSUnit); … … 89 124 FDefaultDpi: single; 90 125 FContent: TSVGContent; 126 FDataLink: TSVGDataLink; 91 127 procedure Init(ACreateEmpty: boolean); 92 128 function GetViewBoxAlignment(AHorizAlign: TAlignment; AVertAlign: TTextLayout): TPointF; 129 procedure UnitsRecompute(Sender: TObject); 93 130 public 94 131 constructor Create; overload; … … 97 134 constructor Create(AFilenameUTF8: string); overload; 98 135 constructor Create(AStream: TStream); overload; 136 constructor CreateFromString(AUTF8String: string); 99 137 destructor Destroy; override; 100 138 procedure LoadFromFile(AFilenameUTF8: string); 101 139 procedure LoadFromStream(AStream: TStream); 140 procedure LoadFromResource(AFilename: string); 102 141 procedure SaveToFile(AFilenameUTF8: string); 103 142 procedure SaveToStream(AStream: TStream); … … 108 147 procedure Draw(ACanvas2d: TBGRACanvas2D; x,y: single; destDpi: single); overload; 109 148 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; 111 151 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; 112 154 property Units: TSVGUnits read FUnits; 113 155 property Width: TFloatWithCSSUnit read GetWidth write SetWidth; … … 120 162 property ViewBox: TSVGViewBox read GetViewBox write SetViewBox; 121 163 property ViewBoxInUnit[AUnit: TCSSUnit]: TSVGViewBox read GetViewBox; 164 property ViewMinInUnit[AUnit: TCSSUnit]: TPointF read GetViewMin; 165 property ViewSizeInUnit[AUnit: TCSSUnit]: TPointF read GetViewSize; 122 166 property Attribute[AName: string]: string read GetAttribute write SetAttribute; 167 property AttributeDef[AName: string; ADefault: string]: string read GetAttribute; 123 168 property DefaultDpi: single read FDefaultDpi write SetDefaultDpi; //this is not saved in the SVG file 124 169 property CustomDpi: TPointF read GetCustomDpi write SetCustomDpi; 125 170 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 195 procedure RegisterSvgFormat; 128 196 129 197 implementation 130 198 131 uses laz2_XMLRead, laz2_XMLWrite, BGRAUTF8 ;199 uses laz2_XMLRead, laz2_XMLWrite, BGRAUTF8, math; 132 200 133 201 const SvgNamespace = 'http://www.w3.org/2000/svg'; 202 203 { TFPReaderSVG } 204 205 function TFPReaderSVG.InternalCheck(Stream: TStream): boolean; 206 var 207 magic: array[1..6] of char; 208 prevPos: int64; 209 count: LongInt; 210 begin 211 prevPos := Stream.Position; 212 count := Stream.Read({%H-}magic, sizeof(magic)); 213 Stream.Position:= prevPos; 214 result:= (count = sizeof(magic)) and (magic = '<?xml '); 215 end; 216 217 procedure TFPReaderSVG.InternalRead(Stream: TStream; Img: TFPCustomImage); 218 var 219 svg: TBGRASVG; 220 vmin,vsize: TPointF; 221 bgra: TBGRACustomBitmap; 222 c2d: TBGRACanvas2D; 223 y, x: Integer; 224 p: PBGRAPixel; 225 begin 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; 262 end; 263 264 constructor TFPReaderSVG.Create; 265 begin 266 inherited Create; 267 FRenderDpi:= 96; 268 FScale := 1; 269 end; 270 271 function TFPReaderSVG.GetQuickInfo(AStream: TStream): TQuickImageInfo; 272 var 273 svg: TBGRASVG; 274 vsize: TPointF; 275 begin 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; 284 end; 285 286 function TFPReaderSVG.GetBitmapDraft(AStream: TStream; AMaxWidth, 287 AMaxHeight: integer; out AOriginalWidth, AOriginalHeight: integer): TBGRACustomBitmap; 288 var 289 svg: TBGRASVG; 290 vmin,vsize: TPointF; 291 c2d: TBGRACanvas2D; 292 ratio: Single; 293 begin 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; 316 end; 317 318 var AlreadyRegistered: boolean; 319 320 procedure RegisterSvgFormat; 321 begin 322 if AlreadyRegistered then exit; 323 ImageHandlers.RegisterImageReader ('Scalable Vector Graphic', 'svg', TFPReaderSVG); 324 AlreadyRegistered:= True; 325 end; 134 326 135 327 function TSVGUnits.GetCustomDpiX: single; 136 328 var pixSize: single; 137 329 begin 138 pixSize := Convert(FDefaultUnitWidth.value,FDefaultUnitWidth.CSSUnit,cuInch,FDefaultDpi^); 330 with GetDefaultUnitWidth do 331 pixSize := Convert(value,CSSUnit,cuInch,FDefaultDpi^); 139 332 if pixSize = 0 then 140 333 result := 0 … … 146 339 var pixSize: single; 147 340 begin 148 pixSize := Convert(FDefaultUnitHeight.value,FDefaultUnitHeight.CSSUnit,cuInch,FDefaultDpi^); 341 with GetDefaultUnitHeight do 342 pixSize := Convert(value,CSSUnit,cuInch,FDefaultDpi^); 149 343 if pixSize = 0 then 150 344 result := 0 … … 194 388 FViewBox.size.y := parseNextFloat; 195 389 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; 200 413 201 414 if (FViewBox.size.x <= 0) and (FViewBox.size.y <= 0) then … … 209 422 FDpiScaleY := 1; 210 423 FViewBox.min := PointF(0,0); 211 FViewBox.size.x := ConvertWidth(F ViewSize.width,cuCustom).value;212 FViewBox.size.y := ConvertHeight(F ViewSize.height,cuCustom).value;424 FViewBox.size.x := ConvertWidth(FProportionalViewSize.width,cuCustom).value; 425 FViewBox.size.y := ConvertHeight(FProportionalViewSize.height,cuCustom).value; 213 426 end else 214 427 begin 215 FDefaultUnitWidth.value := F ViewSize.width.value/FViewBox.size.x;216 FDefaultUnitWidth.CSSUnit := F ViewSize.width.CSSUnit;428 FDefaultUnitWidth.value := FProportionalViewSize.width.value/FViewBox.size.x; 429 FDefaultUnitWidth.CSSUnit := FProportionalViewSize.width.CSSUnit; 217 430 if FDefaultUnitWidth.CSSUnit = cuCustom then 218 431 begin … … 220 433 FDefaultUnitWidth.CSSUnit := cuInch; 221 434 end; 222 FDefaultUnitHeight.value := F ViewSize.height.value/FViewBox.size.y;223 FDefaultUnitHeight.CSSUnit := F ViewSize.height.CSSUnit;435 FDefaultUnitHeight.value := FProportionalViewSize.height.value/FViewBox.size.y; 436 FDefaultUnitHeight.CSSUnit := FProportionalViewSize.height.CSSUnit; 224 437 if FDefaultUnitHeight.CSSUnit = cuCustom then 225 438 begin … … 231 444 FDpiScaleY := CustomDpiY/DpiY; 232 445 end; 446 447 if Assigned(FOnRecompute) then FOnRecompute(self); 448 end; 449 450 procedure TSVGUnits.SetOnRecompute(AValue: TSVGRecomputeEvent); 451 begin 452 if FOnRecompute=AValue then Exit; 453 FOnRecompute:=AValue; 454 end; 455 456 procedure TSVGUnits.SetContainerHeight(AValue: TFloatWithCSSUnit); 457 begin 458 if CompareMem(@FContainerHeight,@AValue,sizeof(TFloatWithCSSUnit)) then Exit; 459 FContainerHeight:=AValue; 460 Recompute; 461 end; 462 463 procedure TSVGUnits.SetContainerWidth(AValue: TFloatWithCSSUnit); 464 begin 465 if CompareMem(@FContainerWidth,@AValue,sizeof(TFloatWithCSSUnit)) then Exit; 466 FContainerWidth:=AValue; 467 Recompute; 233 468 end; 234 469 … … 238 473 begin 239 474 vb := ViewBox; 240 vs := F ViewSize;475 vs := FProportionalViewSize; 241 476 if (vs.width.value > 0) and (vs.height.value > 0) then 242 477 begin … … 303 538 FSvg := ASvg; 304 539 FDefaultDpi := ADefaultDpi; 540 FContainerWidth := FloatWithCSSUnit(640,cuPixel); 541 FContainerHeight := FloatWithCSSUnit(480,cuPixel); 305 542 Recompute; 306 543 end; 307 544 545 function TSVGUnits.GetStretchRectF(AViewSize: TRectF; par: TSVGPreserveAspectRatio): TRectF; 546 var w0,h0,w,h: single; 547 begin 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; 574 end; 575 308 576 { TBGRASVG } 309 577 310 578 function TBGRASVG.GetAttribute(AName: string): string; 311 579 begin 312 result := FRoot.GetAttribute(AName); 580 result := Trim(FRoot.GetAttribute(AName)); 581 end; 582 583 function TBGRASVG.GetAttribute(AName: string; ADefault: string): string; 584 begin 585 result := GetAttribute(AName); 586 if result = '' then result := ADefault; 313 587 end; 314 588 … … 320 594 function TBGRASVG.GetHeight: TFloatWithCSSUnit; 321 595 begin 322 result := TCSSUnitConverter.parseValue(Attribute['height'],FloatWithCSSUnit( 0,cuCustom));596 result := TCSSUnitConverter.parseValue(Attribute['height'],FloatWithCSSUnit(FUnits.ViewBox.size.y,cuCustom)); 323 597 end; 324 598 … … 333 607 end; 334 608 335 function TBGRASVG.GetPreserveAspectRatio: string; 336 begin 337 result := Attribute['preserveAspectRatio']; 609 function TBGRASVG.GetPreserveAspectRatio: TSVGPreserveAspectRatio; 610 begin 611 result := TSVGPreserveAspectRatio.Parse(Attribute['preserveAspectRatio','xMidYMid']); 612 end; 613 614 function TBGRASVG.GetUTF8String: utf8string; 615 var str: TMemoryStream; 616 begin 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; 338 623 end; 339 624 … … 357 642 end; 358 643 644 function TBGRASVG.GetViewMin(AUnit: TCSSUnit): TPointF; 645 var 646 vb: TSVGViewBox; 647 begin 648 GetViewBoxIndirect(AUnit,vb); 649 result:= vb.min; 650 end; 651 652 function TBGRASVG.GetViewSize(AUnit: TCSSUnit): TPointF; 653 var 654 vb: TSVGViewBox; 655 begin 656 GetViewBoxIndirect(AUnit,vb); 657 result:= vb.size; 658 end; 659 359 660 function TBGRASVG.GetWidth: TFloatWithCSSUnit; 360 661 begin 361 result := TCSSUnitConverter.parseValue(Attribute['width'],FloatWithCSSUnit( 0,cuCustom));662 result := TCSSUnitConverter.parseValue(Attribute['width'],FloatWithCSSUnit(FUnits.ViewBox.size.x,cuCustom)); 362 663 end; 363 664 … … 374 675 function TBGRASVG.GetZoomable: boolean; 375 676 begin 376 result := trim(Attribute['zoomAndPan'])<>'disable';677 result := AttributeDef['zoomAndPan','magnify']<>'disable'; 377 678 end; 378 679 … … 392 693 FUnits.CustomDpi := AValue; 393 694 if AValue.x <> AValue.y then 394 preserveAspectRatio := 'none';695 preserveAspectRatio := TSVGPreserveAspectRatio.Parse('none'); 395 696 end; 396 697 … … 417 718 end; 418 719 419 procedure TBGRASVG.SetPreserveAspectRatio(AValue: string); 420 begin 421 Attribute['preserveAspectRatio'] := AValue; 720 procedure TBGRASVG.SetPreserveAspectRatio(AValue: TSVGPreserveAspectRatio); 721 begin 722 Attribute['preserveAspectRatio'] := AValue.ToString; 723 Units.Recompute; 724 end; 725 726 procedure TBGRASVG.SetUTF8String(AValue: utf8string); 727 var str: TMemoryStream; 728 begin 729 str:= TMemoryStream.Create; 730 str.Write(AValue[1],length(AValue)); 731 str.Position:= 0; 732 LoadFromStream(str); 733 str.Free; 422 734 end; 423 735 … … 460 772 FRoot := FXml.CreateElement('svg'); 461 773 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); 463 777 FXml.AppendChild(FRoot); 464 778 end; … … 487 801 end; 488 802 803 procedure TBGRASVG.UnitsRecompute(Sender: TObject); 804 begin 805 FContent.Recompute; 806 end; 807 489 808 constructor TBGRASVG.Create; 490 809 begin … … 523 842 end; 524 843 844 constructor TBGRASVG.CreateFromString(AUTF8String: string); 845 begin 846 Init(False); 847 AsUTF8String:= AUTF8String; 848 end; 849 525 850 destructor TBGRASVG.Destroy; 526 851 begin 852 FreeAndNil(FDataLink); 527 853 FreeAndNil(FContent); 528 854 FreeAndNil(FUnits); … … 565 891 raise exception.Create('Root node not found'); 566 892 end; 893 FreeAndNil(FDataLink); 567 894 FreeAndNil(FContent); 568 895 FreeAndNil(FUnits); … … 571 898 FRoot := root as TDOMElement; 572 899 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); 903 end; 904 905 procedure TBGRASVG.LoadFromResource(AFilename: string); 906 var 907 stream: TStream; 908 begin 909 stream := BGRAResource.GetResourceStream(AFilename); 910 try 911 LoadFromStream(stream); 912 finally 913 stream.Free; 914 end; 574 915 end; 575 916 … … 614 955 ACanvas2d.translate(x,y); 615 956 ACanvas2d.scale(destDpi.x/Units.DpiX,destDpi.y/Units.DpiY); 616 ACanvas2d.strokeResetTransform;617 ACanvas2d.strokeScale(destDpi.x/Units.DpiX,destDpi.y/Units.DpiY);618 957 with GetViewBoxAlignment(AHorizAlign,AVertAlign) do ACanvas2d.translate(x,y); 619 958 Draw(ACanvas2d, 0,0, cuPixel); … … 628 967 ACanvas2d.save; 629 968 ACanvas2d.translate(x,y); 969 ACanvas2d.strokeMatrix := ACanvas2d.matrix; 630 970 Content.Draw(ACanvas2d,AUnit); 631 971 ACanvas2d.restore; … … 643 983 ACanvas2d.translate(x,y); 644 984 ACanvas2d.scale(destDpi.x/Units.DpiX,destDpi.y/Units.DpiY); 645 ACanvas2d.strokeResetTransform;646 ACanvas2d.strokeScale(destDpi.x/Units.DpiX,destDpi.y/Units.DpiY);647 985 Draw(ACanvas2d, 0,0, cuPixel); 648 986 ACanvas2d.restore; 649 987 end; 650 988 651 procedure TBGRASVG.StretchDraw(ACanvas2d: TBGRACanvas2D; x, y, w, h: single );989 procedure TBGRASVG.StretchDraw(ACanvas2d: TBGRACanvas2D; x, y, w, h: single; useSvgAspectRatio: boolean); 652 990 var vb: TSVGViewBox; 653 991 begin 992 if useSvgAspectRatio then 993 begin 994 with preserveAspectRatio do 995 StretchDraw(ACanvas2d, HorizAlign, VertAlign, x,y,w,h); 996 exit; 997 end; 654 998 ACanvas2d.save; 655 999 ACanvas2d.translate(x,y); … … 660 1004 ACanvas2d.translate(-min.x,-min.y); 661 1005 if size.x <> 0 then 662 begin663 1006 ACanvas2d.scale(w/size.x,1); 664 ACanvas2d.strokeScale(w/size.x,1);665 end;666 1007 if size.y <> 0 then 667 begin668 1008 ACanvas2d.scale(1,h/size.y); 669 ACanvas2d.strokeScale(1,h/size.y);670 end;671 1009 end; 672 1010 Draw(ACanvas2d, 0,0); … … 674 1012 end; 675 1013 1014 procedure TBGRASVG.StretchDraw(ACanvas2d: TBGRACanvas2D; r: TRectF; useSvgAspectRatio: boolean); 1015 begin 1016 StretchDraw(ACanvas2d, r.Left,r.Top,r.Right-r.Left,r.Bottom-r.Top, useSvgAspectRatio); 1017 end; 1018 676 1019 procedure TBGRASVG.StretchDraw(ACanvas2d: TBGRACanvas2D; 677 1020 AHorizAlign: TAlignment; AVertAlign: TTextLayout; x, y, w, h: single); 1021 var r: TRectF; 1022 begin 1023 r := GetStretchRectF(AHorizAlign,AVertAlign, x, y, w, h); 1024 StretchDraw(ACanvas2d, r.Left,r.Top,r.Right-r.Left,r.Bottom-r.Top); 1025 end; 1026 1027 function TBGRASVG.GetStretchRectF(AHorizAlign: TAlignment; 1028 AVertAlign: TTextLayout; x, y, w, h: single): TRectF; 678 1029 var ratio,stretchRatio,zoom: single; 679 vb: TSVGViewBox;680 1030 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; 1032 begin 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; 685 1043 stretchRatio := w/h; 686 1044 if ratio > stretchRatio then 687 zoom := w / vb.size.x1045 zoom := w / size.width.value 688 1046 else 689 zoom := h / vb.size.y;1047 zoom := h / size.height.value; 690 1048 691 1049 sx := x; 692 1050 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; 695 1053 696 1054 case AHorizAlign of … … 702 1060 tlBottom: sy += h - sh; 703 1061 end; 704 StretchDraw(ACanvas2d, sx,sy,sw,sh); 705 end; 1062 1063 result := Units.GetStretchRectF(RectF(sx,sy,sx+sw,sy+sh), preserveAspectRatio); 1064 end; 1065 1066 initialization 1067 1068 DefaultBGRAImageReader[ifSvg] := TFPReaderSVG; 706 1069 707 1070 end. -
GraphicTest/Packages/bgrabitmap/bgrasvgshapes.pas
r494 r521 10 10 11 11 type 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 12 39 { TSVGLine } 13 40 … … 25 52 procedure InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); override; 26 53 public 27 constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter ); override;54 constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); override; 28 55 property x1: TFloatWithCSSUnit read GetX1 write SetX1; 29 56 property y1: TFloatWithCSSUnit read GetY1 write SetY1; … … 34 61 { TSVGRectangle } 35 62 36 TSVGRectangle = class(TSVGElement )63 TSVGRectangle = class(TSVGElementWithGradient) 37 64 private 38 65 function GetX: TFloatWithCSSUnit; … … 51 78 procedure InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); override; 52 79 public 53 constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter ); override;80 constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); override; 54 81 property x: TFloatWithCSSUnit read GetX write SetX; 55 82 property y: TFloatWithCSSUnit read GetY write SetY; … … 62 89 { TSVGCircle } 63 90 64 TSVGCircle = class(TSVGElement )91 TSVGCircle = class(TSVGElementWithGradient) 65 92 private 66 93 function GetCX: TFloatWithCSSUnit; … … 73 100 procedure InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); override; 74 101 public 75 constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter ); override;102 constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); override; 76 103 property cx: TFloatWithCSSUnit read GetCX write SetCX; 77 104 property cy: TFloatWithCSSUnit read GetCY write SetCY; … … 81 108 { TSVGEllipse } 82 109 83 TSVGEllipse = class(TSVGElement )110 TSVGEllipse = class(TSVGElementWithGradient) 84 111 private 85 112 function GetCX: TFloatWithCSSUnit; … … 94 121 procedure InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); override; 95 122 public 96 constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter ); override;123 constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); override; 97 124 property cx: TFloatWithCSSUnit read GetCX write SetCX; 98 125 property cy: TFloatWithCSSUnit read GetCY write SetCY; … … 103 130 { TSVGPath } 104 131 105 TSVGPath = class(TSVGElement )132 TSVGPath = class(TSVGElementWithGradient) 106 133 private 107 134 FPath: TBGRAPath; 135 FBoundingBox: TRectF; 136 FBoundingBoxComputed: boolean; 137 function GetBoundingBoxF: TRectF; 108 138 function GetPath: TBGRAPath; 109 139 function GetPathLength: TFloatWithCSSUnit; … … 115 145 procedure InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); override; 116 146 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; 119 149 destructor Destroy; override; 120 150 property d: string read GetData write SetData; 121 151 property path: TBGRAPath read GetPath; 122 152 property pathLength: TFloatWithCSSUnit read GetPathLength write SetPathLength; 153 property boundingBoxF: TRectF read GetBoundingBoxF; 123 154 end; 124 155 125 156 { TSVGPolypoints } 126 157 127 TSVGPolypoints = class(TSVGElement )158 TSVGPolypoints = class(TSVGElementWithGradient) 128 159 private 160 FBoundingBox: TRectF; 161 FBoundingBoxComputed: boolean; 162 function GetBoundingBoxF: TRectF; 129 163 function GetClosed: boolean; 130 164 function GetPoints: string; … … 132 166 procedure SetPoints(AValue: string); 133 167 procedure SetPointsF(AValue: ArrayOfTPointF); 168 procedure ComputeBoundingBox(APoints: ArrayOfTPointF); 134 169 protected 135 170 procedure InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); override; 136 171 public 137 constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; AClosed: boolean ); overload;172 constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; AClosed: boolean; ADataLink: TSVGDataLink); overload; 138 173 destructor Destroy; override; 139 174 property points: string read GetPoints write SetPoints; 140 175 property pointsF: ArrayOfTPointF read GetPointsF write SetPointsF; 141 176 property closed: boolean read GetClosed; 177 property boundingBoxF: TRectF read GetBoundingBoxF; 142 178 end; 143 179 144 180 { TSVGText } 145 181 146 TSVGText = class(TSVGElement )182 TSVGText = class(TSVGElementWithGradient) 147 183 private 148 184 function GetFontBold: boolean; … … 169 205 procedure InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); override; 170 206 public 171 constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter ); override;207 constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); override; 172 208 property x: TFloatWithCSSUnit read GetX write SetX; 173 209 property y: TFloatWithCSSUnit read GetY write SetY; … … 183 219 184 220 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; 185 334 186 335 { TSVGGroup } … … 191 340 procedure InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); override; 192 341 public 193 constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter ); override;342 constructor Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); override; 194 343 constructor Create(ADocument: TXMLDocument; AElement: TDOMElement; 195 AUnits: TCSSUnitConverter ); override;344 AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); override; 196 345 destructor Destroy; override; 346 procedure Recompute; override; 197 347 property Content: TSVGContent read FContent; 198 348 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; 199 381 200 382 { TSVGContent } … … 202 384 TSVGContent = class 203 385 protected 386 FDataLink: TSVGDataLink; 204 387 FDomElem: TDOMElement; 205 388 FDoc: TXMLDocument; 206 FElements: T List;389 FElements: TFPList; 207 390 FUnits: TCSSUnitConverter; 208 391 procedure AppendElement(AElement: TSVGElement); … … 212 395 function GetUnits: TCSSUnitConverter; 213 396 public 214 constructor Create(ADocument: TXMLDocument; AElement: TDOMElement; AUnits: TCSSUnitConverter); 397 constructor Create(ADocument: TXMLDocument; AElement: TDOMElement; AUnits: TCSSUnitConverter; 398 ADataLink: TSVGDataLink; ADataParent: TSVGElement); 215 399 destructor Destroy; override; 400 procedure Recompute; 216 401 procedure Draw(ACanvas2d: TBGRACanvas2D; x,y: single; AUnit: TCSSUnit); overload; 217 402 procedure Draw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); overload; … … 239 424 function GetSVGFactory(ATagName: string): TSVGFactory; 240 425 function CreateSVGElementFromNode(ADocument: TXMLDocument; 241 AElement: TDOMElement; AUnits: TCSSUnitConverter ): TSVGElement;426 AElement: TDOMElement; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink; ADataParent: TSVGElement): TSVGElement; 242 427 243 428 implementation … … 263 448 if tag='text' then 264 449 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 265 458 if tag='g' then 266 459 result := TSVGGroup else 460 if tag='style' then 461 result := TSVGStyle else 267 462 result := TSVGElement; 268 463 end; 269 464 270 465 function CreateSVGElementFromNode(ADocument: TXMLDocument; 271 AElement: TDOMElement; AUnits: TCSSUnitConverter ): TSVGElement;466 AElement: TDOMElement; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink; ADataParent: TSVGElement): TSVGElement; 272 467 var 273 468 factory: TSVGFactory; 274 469 begin 275 470 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); 474 end; 475 476 { TSVGElementWithGradient } 477 478 procedure TSVGElementWithGradient.Initialize; 479 begin 480 inherited Initialize; 481 ResetGradient; 482 end; 483 484 procedure TSVGElementWithGradient.ResetGradient; 485 begin 486 FGradientElementDefined := false; 487 FGradientElement := nil; 488 FCanvasGradient := nil; 489 end; 490 491 function TSVGElementWithGradient.FindGradientElement: boolean; 492 var 493 i: integer; 494 s: string; 495 begin 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; 511 end; 512 513 function TSVGElementWithGradient.EvaluatePercentage(fu: TFloatWithCSSUnit): single; 514 begin 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; 524 end; 525 526 function TSVGElementWithGradient.GetGradientElement: TSVGGradient; 527 begin 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; 536 end; 537 538 procedure 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 558 var 559 i: integer; 560 begin 561 if not Assigned(GradientElement) then exit; 562 with GradientElement.InheritedGradients do 563 for i:= 0 to Count-1 do 564 AddStopElementFrom(Items[i]); 565 end; 566 567 procedure TSVGElementWithGradient.CreateCanvasLinearGradient( 568 ACanvas2d: TBGRACanvas2D; ASVGGradient: TSVGGradient; 569 const origin: TPointF; const w,h: single; AUnit: TCSSUnit); 570 var p1,p2: TPointF; 571 g: TSVGLinearGradient; 572 m: TAffineMatrix; 573 begin 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); 600 end; 601 602 procedure TSVGElementWithGradient.CreateCanvasRadialGradient( 603 ACanvas2d: TBGRACanvas2D; ASVGGradient: TSVGGradient; const origin: TPointF; 604 const w, h: single; AUnit: TCSSUnit); 605 var 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 625 begin 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; 656 end; 657 658 procedure TSVGElementWithGradient.InitializeGradient(ACanvas2d: TBGRACanvas2D; 659 const origin: TPointF; const w,h: single; AUnit: TCSSUnit); 660 begin 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; 669 end; 670 671 procedure TSVGElementWithGradient.ApplyFillStyle(ACanvas2D: TBGRACanvas2D; AUnit: TCSSUnit); 672 begin 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; 680 end; 278 681 279 682 { TSVGText } … … 290 693 function TSVGText.GetFontFamily: string; 291 694 begin 292 result := AttributeOrStyle['font-family']; 293 if result = '' then result := 'Arial'; 695 result := AttributeOrStyleDef['font-family','Arial']; 294 696 end; 295 697 … … 303 705 function TSVGText.GetFontSize: TFloatWithCSSUnit; 304 706 begin 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)]; 309 708 end; 310 709 311 710 function TSVGText.GetFontStyle: string; 312 711 begin 313 result := AttributeOrStyle['font-style']; 314 if result = '' then result := 'normal'; 712 result := AttributeOrStyleDef['font-style','normal']; 315 713 end; 316 714 317 715 function TSVGText.GetFontWeight: string; 318 716 begin 319 result := AttributeOrStyle['font-weight']; 320 if result = '' then result := 'normal'; 717 result := AttributeOrStyleDef['font-weight','normal']; 321 718 end; 322 719 … … 328 725 function TSVGText.GetTextDecoration: string; 329 726 begin 330 result := AttributeOrStyle['text-decoration']; 331 if result='' then result := 'none'; 727 result := AttributeOrStyleDef['text-decoration','none']; 332 728 end; 333 729 … … 397 793 398 794 procedure TSVGText.InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); 399 var fs:TFontStyles; 795 var 796 fs:TFontStyles; 797 vx,vy: single; 400 798 begin 401 799 ACanvas2d.beginPath; 402 ACanvas2d.fontEmHeight := Units.Convert Width(fontSize,AUnit).value;800 ACanvas2d.fontEmHeight := Units.ConvertHeight(fontSize,AUnit).value; 403 801 ACanvas2d.fontName := fontFamily; 404 802 fs := []; … … 406 804 if fontItalic then fs += [fsItalic]; 407 805 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 409 814 if not isFillNone then 410 815 begin 411 A Canvas2d.fillStyle(fillColor);816 ApplyFillStyle(ACanvas2D,AUnit); 412 817 ACanvas2d.fill; 413 818 end; … … 419 824 end; 420 825 421 constructor TSVGText.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter); 422 begin 826 constructor TSVGText.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); 827 begin 828 inherited Create(ADocument, AUnits, ADataLink); 423 829 Init(ADocument,'text',AUnits); 424 830 end; … … 426 832 { TSVGGroup } 427 833 428 constructor TSVGGroup.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter );429 begin 430 inherited Create(ADocument, AUnits );431 FContent := TSVGContent.Create(ADocument,FDomElem,AUnits );834 constructor TSVGGroup.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); 835 begin 836 inherited Create(ADocument, AUnits, ADataLink); 837 FContent := TSVGContent.Create(ADocument,FDomElem,AUnits,ADataLink,Self); 432 838 end; 433 839 434 840 constructor 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); 842 begin 843 inherited Create(ADocument, AElement, AUnits, ADataLink); 844 FContent := TSVGContent.Create(ADocument,AElement,AUnits,ADataLink,Self); 439 845 end; 440 846 … … 450 856 end; 451 857 858 procedure TSVGGroup.Recompute; 859 begin 860 inherited Recompute; 861 FContent.Recompute; 862 end; 863 864 { TSVGStyle } 865 866 constructor TSVGStyle.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); 867 begin 868 inherited Create(ADocument, AUnits, ADataLink); 869 Init(ADocument,'style',AUnits); 870 end; 871 872 constructor TSVGStyle.Create(ADocument: TXMLDocument; AElement: TDOMElement; 873 AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); 874 begin 875 inherited Create(ADocument, AElement, AUnits, ADataLink); 876 Parse(AElement.TextContent); 877 end; 878 879 procedure TSVGStyle.Initialize; 880 begin 881 inherited Initialize; 882 Clear; 883 end; 884 885 destructor TSVGStyle.Destroy; 886 begin 887 Clear; 888 inherited Destroy; 889 end; 890 891 procedure 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 904 const 905 EmptyRec: TSVGStyleItem = (name: ''; attribute: ''); 906 var 907 i,l,pg: integer; 908 st: String; 909 rec: TSVGStyleItem; 910 begin 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; 952 end; 953 954 function TSVGStyle.IsValidID(const sid: integer): boolean; 955 begin 956 result:= (sid >= 0) and (sid < Length(FStyles)); 957 end; 958 959 function TSVGStyle.GetStyle(const sid: integer): TSVGStyleItem; 960 begin 961 if IsValidID(sid) then 962 result:= FStyles[sid] 963 else 964 raise exception.Create(rsInvalidId); 965 end; 966 967 procedure TSVGStyle.SetStyle(const sid: integer; sr: TSVGStyleItem); 968 begin 969 if IsValidID(sid) then 970 FStyles[sid]:= sr 971 else 972 raise exception.Create(rsInvalidId); 973 end; 974 975 function TSVGStyle.Count: Integer; 976 begin 977 result:= Length(FStyles); 978 end; 979 980 function TSVGStyle.Find(sr: TSVGStyleItem): integer; 981 var 982 i: integer; 983 begin 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; 993 end; 994 995 function TSVGStyle.Find(const AName: string): integer; 996 var 997 i: integer; 998 begin 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; 1007 end; 1008 1009 function TSVGStyle.Add(sr: TSVGStyleItem): integer; 1010 var 1011 l: integer; 1012 begin 1013 l:= Length(FStyles); 1014 SetLength(FStyles,l+1); 1015 FStyles[l]:= sr; 1016 result:= l; 1017 end; 1018 1019 procedure TSVGStyle.Remove(sr: TSVGStyleItem); 1020 var 1021 l,p: integer; 1022 begin 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; 1031 end; 1032 1033 procedure TSVGStyle.Clear; 1034 begin 1035 SetLength(FStyles,0); 1036 end; 1037 1038 procedure TSVGStyle.ReParse; 1039 begin 1040 Parse(FDomElem.TextContent); 1041 end; 1042 452 1043 { TSVGRectangle } 453 1044 … … 513 1104 514 1105 constructor TSVGRectangle.Create(ADocument: TXMLDocument; 515 AUnits: TCSSUnitConverter); 516 begin 1106 AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); 1107 begin 1108 inherited Create(ADocument, AUnits, ADataLink); 517 1109 Init(ADocument,'rect',AUnits); 518 1110 end; 519 1111 520 1112 procedure TSVGRectangle.InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); 1113 var 1114 vx,vy,vw,vh: Single; 521 1115 begin 522 1116 if not isStrokeNone or not isFillNone then 523 1117 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; 524 1122 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); 528 1127 if not isFillNone then 529 1128 begin 530 A Canvas2d.fillStyle(fillColor);1129 ApplyFillStyle(ACanvas2D,AUnit); 531 1130 ACanvas2d.fill; 532 1131 end; … … 544 1143 begin 545 1144 result := FDomElem.TagName = 'polygon'; 1145 end; 1146 1147 function TSVGPolypoints.GetBoundingBoxF: TRectF; 1148 begin 1149 if not FBoundingBoxComputed then 1150 ComputeBoundingBox(pointsF); 1151 result := FBoundingBox; 546 1152 end; 547 1153 … … 570 1176 result[i].y := parser.ParseFloat; 571 1177 end; 1178 parser.Free; 572 1179 end; 573 1180 … … 589 1196 end; 590 1197 points := s; 1198 ComputeBoundingBox(AValue); 1199 end; 1200 1201 procedure TSVGPolypoints.ComputeBoundingBox(APoints: ArrayOfTPointF); 1202 var 1203 i: Integer; 1204 begin 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; 591 1227 end; 592 1228 593 1229 constructor TSVGPolypoints.Create(ADocument: TXMLDocument; 594 AUnits: TCSSUnitConverter; AClosed: boolean); 595 begin 1230 AUnits: TCSSUnitConverter; AClosed: boolean; ADataLink: TSVGDataLink); 1231 begin 1232 inherited Create(ADocument, AUnits, ADataLink); 596 1233 if AClosed then 597 1234 Init(ADocument, 'polygon', AUnits) … … 608 1245 var 609 1246 prevMatrix: TAffineMatrix; 1247 pts: ArrayOfTPointF; 610 1248 begin 611 1249 if isFillNone and isStrokeNone then exit; … … 620 1258 begin 621 1259 ACanvas2d.beginPath; 622 ACanvas2d.polylineTo(pointsF); 1260 pts := pointsF; 1261 ACanvas2d.polylineTo(pts); 623 1262 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 624 1268 if not isFillNone then 625 1269 begin 626 A Canvas2d.fillStyle(fillColor);1270 ApplyFillStyle(ACanvas2D,AUnit); 627 1271 ACanvas2d.fill; 628 1272 end; … … 649 1293 end; 650 1294 1295 function TSVGPath.GetBoundingBoxF: TRectF; 1296 begin 1297 if not FBoundingBoxComputed then 1298 begin 1299 FBoundingBox := path.GetBounds; 1300 FBoundingBoxComputed := true; 1301 end; 1302 result := FBoundingBox; 1303 end; 1304 651 1305 function TSVGPath.GetData: string; 652 1306 begin … … 668 1322 else 669 1323 FPath.SvgString := AValue; 1324 FBoundingBoxComputed := false; 670 1325 end; 671 1326 … … 676 1331 end; 677 1332 678 constructor TSVGPath.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter); 679 begin 1333 constructor TSVGPath.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); 1334 begin 1335 inherited Create(ADocument, AUnits, ADataLink); 680 1336 Init(ADocument,'path',AUnits); 681 1337 FPath := nil; 1338 FBoundingBoxComputed := false; 1339 FBoundingBox := rectF(0,0,0,0); 682 1340 end; 683 1341 684 1342 constructor TSVGPath.Create(ADocument: TXMLDocument; AElement: TDOMElement; 685 AUnits: TCSSUnitConverter); 686 begin 1343 AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); 1344 begin 1345 inherited Create(ADocument, AElement, AUnits, ADataLink); 687 1346 Init(ADocument, AElement, AUnits); 688 1347 FPath := nil; 1348 FBoundingBoxComputed := false; 1349 FBoundingBox := rectF(0,0,0,0); 689 1350 end; 690 1351 … … 710 1371 begin 711 1372 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); 712 1377 if not isFillNone then 713 1378 begin 714 A Canvas2d.fillStyle(fillColor);1379 ApplyFillStyle(ACanvas2D,AUnit); 715 1380 ACanvas2d.fill; 716 1381 end; … … 766 1431 767 1432 constructor TSVGEllipse.Create(ADocument: TXMLDocument; 768 AUnits: TCSSUnitConverter); 769 begin 1433 AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); 1434 begin 1435 inherited Create(ADocument, AUnits, ADataLink); 770 1436 Init(ADocument,'ellipse',AUnits); 771 1437 end; 772 1438 773 1439 procedure TSVGEllipse.InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); 1440 var 1441 vcx,vcy,vrx,vry: Single; 774 1442 begin 775 1443 if not isFillNone or not isStrokeNone then 776 1444 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; 777 1449 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); 780 1453 if not isFillNone then 781 1454 begin 782 A Canvas2d.fillStyle(fillColor);1455 ApplyFillStyle(ACanvas2D,AUnit); 783 1456 ACanvas2d.fill; 784 1457 end; … … 823 1496 end; 824 1497 825 constructor TSVGCircle.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter); 826 begin 1498 constructor TSVGCircle.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); 1499 begin 1500 inherited Create(ADocument, AUnits, ADataLink); 827 1501 Init(ADocument,'circle',AUnits); 828 1502 end; 829 1503 830 1504 procedure TSVGCircle.InternalDraw(ACanvas2d: TBGRACanvas2D; AUnit: TCSSUnit); 1505 var 1506 vcx,vcy,vr: Single; 831 1507 begin 832 1508 if not isFillNone or not isStrokeNone then 833 1509 begin 1510 vcx:= Units.ConvertWidth(cx,AUnit).value; 1511 vcy:= Units.ConvertHeight(cy,AUnit).value; 1512 vr:= Units.ConvertWidth(r,AUnit).value; 834 1513 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); 837 1517 if not isFillNone then 838 1518 begin 839 A Canvas2d.fillStyle(fillColor);1519 ApplyFillStyle(ACanvas2D,AUnit); 840 1520 ACanvas2d.fill; 841 1521 end; … … 890 1570 end; 891 1571 892 constructor TSVGLine.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter); 893 begin 1572 constructor TSVGLine.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); 1573 begin 1574 inherited Create(ADocument, AUnits, ADataLink); 894 1575 Init(ADocument,'line',AUnits); 895 1576 end; … … 901 1582 ApplyStrokeStyle(ACanvas2D,AUnit); 902 1583 ACanvas2d.beginPath; 903 ACanvas2d.moveTo(Units.ConvertWidth(x1,AUnit).value,Units.Convert Width(y1,AUnit).value);904 ACanvas2d.lineTo(Units.ConvertWidth(x2,AUnit).value,Units.Convert Width(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); 905 1586 ACanvas2d.stroke; 906 1587 end; 1588 end; 1589 1590 { TSVGGradient } //## 1591 1592 function TSVGGradient.GetHRef: string; 1593 begin 1594 result := Attribute['xlink:href']; 1595 if result = '' then 1596 result := Attribute['href'];//(Note: specific for svg 2) 1597 end; 1598 1599 function TSVGGradient.GetUseObjectBoundingBox: boolean; 1600 begin 1601 result := (gradientUnits = 'objectBoundingBox'); 1602 end; 1603 1604 procedure TSVGGradient.SetGradientTransform(AValue: string); 1605 begin 1606 Attribute['gradientTransform'] := AValue; 1607 end; 1608 1609 function TSVGGradient.GetGradientUnits: string; 1610 begin 1611 result := AttributeDef['gradientUnits','objectBoundingBox']; 1612 end; 1613 1614 function TSVGGradient.GetGradientTransform: string; 1615 begin 1616 result := Attribute['gradientTransform']; 1617 end; 1618 1619 function TSVGGradient.GetGradientMatrix(AUnit: TCSSUnit): TAffineMatrix; 1620 var parser: TSVGParser; 1621 s: string; 1622 begin 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); 1634 end; 1635 1636 procedure TSVGGradient.SetGradientUnits(AValue: string); 1637 begin 1638 Attribute['gradientUnits'] := AValue; 1639 end; 1640 1641 procedure TSVGGradient.SetHRef(AValue: string); 1642 begin 1643 Attribute['xlink:href'] := AValue; 1644 end; 1645 1646 constructor TSVGGradient.Create(ADocument: TXMLDocument; 1647 AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); 1648 begin 1649 inherited Create(ADocument, AUnits, ADataLink); 1650 FContent := TSVGContent.Create(ADocument,FDomElem,AUnits,ADataLink,Self); 1651 end; 1652 1653 function TSVGGradient.HRefToGradientID(const AValue: string): string; 1654 var 1655 l: integer; 1656 begin 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); 1663 end; 1664 1665 function TSVGGradient.FindGradientRef(const AGradientID: string): integer; 1666 var 1667 i: integer; 1668 begin 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; 1677 end; 1678 1679 procedure TSVGGradient.Initialize; 1680 begin 1681 inherited; 1682 InheritedGradients:= TSVGElementList.Create; 1683 end; 1684 1685 function TSVGGradient.GetInheritedAttribute(AValue: string; 1686 AConvMethod: TConvMethod; ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit; 1687 var 1688 i: integer; 1689 el: TSVGGradient; 1690 invalidDef: TFloatWithCSSUnit; 1691 begin 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; 1714 end; 1715 1716 constructor TSVGGradient.Create(ADocument: TXMLDocument; AElement: TDOMElement; 1717 AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); 1718 begin 1719 inherited Create(ADocument, AElement, AUnits, ADataLink); 1720 FContent := TSVGContent.Create(ADocument,AElement,AUnits,ADataLink,Self); 1721 end; 1722 1723 destructor TSVGGradient.Destroy; 1724 begin 1725 FreeAndNil(FContent); 1726 FreeAndNil(InheritedGradients); 1727 inherited Destroy; 1728 end; 1729 1730 procedure TSVGGradient.Recompute; 1731 begin 1732 inherited Recompute; 1733 FContent.Recompute; 1734 end; 1735 1736 procedure TSVGGradient.ScanInheritedGradients(const forceScan: boolean = false); 1737 var 1738 el: TSVGGradient; 1739 pos: integer; 1740 gradientID: string; 1741 begin 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; 1761 end; 1762 1763 { TSVGLinearGradient } 1764 1765 function TSVGLinearGradient.GetX1: TFloatWithCSSUnit; 1766 begin 1767 result := GetInheritedAttribute('x1',cmNone,FloatWithCSSUnit(0,cuPercent)); 1768 end; 1769 1770 function TSVGLinearGradient.GetX2: TFloatWithCSSUnit; 1771 begin 1772 result := GetInheritedAttribute('x2',cmNone,FloatWithCSSUnit(100,cuPercent)); 1773 end; 1774 1775 function TSVGLinearGradient.GetY1: TFloatWithCSSUnit; 1776 begin 1777 result := GetInheritedAttribute('y1',cmNone,FloatWithCSSUnit(0,cuPercent)); 1778 end; 1779 1780 function TSVGLinearGradient.GetY2: TFloatWithCSSUnit; 1781 begin 1782 result := GetInheritedAttribute('y2',cmNone,FloatWithCSSUnit(0,cuPercent)); 1783 end; 1784 1785 procedure TSVGLinearGradient.SetX1(AValue: TFloatWithCSSUnit); 1786 begin 1787 AttributeWithUnit['x1']:= AValue; 1788 end; 1789 1790 procedure TSVGLinearGradient.SetX2(AValue: TFloatWithCSSUnit); 1791 begin 1792 AttributeWithUnit['x2']:= AValue; 1793 end; 1794 1795 procedure TSVGLinearGradient.SetY1(AValue: TFloatWithCSSUnit); 1796 begin 1797 AttributeWithUnit['y1']:= AValue; 1798 end; 1799 1800 procedure TSVGLinearGradient.SetY2(AValue: TFloatWithCSSUnit); 1801 begin 1802 AttributeWithUnit['y2']:= AValue; 1803 end; 1804 1805 constructor TSVGLinearGradient.Create(ADocument: TXMLDocument; 1806 AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); 1807 begin 1808 inherited Create(ADocument, AUnits, ADataLink); 1809 Init(ADocument,'linearGradient',AUnits); 1810 end; 1811 1812 { TSVGRadialGradient } 1813 1814 function TSVGRadialGradient.GetCX: TFloatWithCSSUnit; 1815 begin 1816 result := GetInheritedAttribute('cx',cmHoriz,FloatWithCSSUnit(50,cuPercent)); 1817 end; 1818 1819 function TSVGRadialGradient.GetCY: TFloatWithCSSUnit; 1820 begin 1821 result := GetInheritedAttribute('cy',cmVertical,FloatWithCSSUnit(50,cuPercent)); 1822 end; 1823 1824 function TSVGRadialGradient.GetR: TFloatWithCSSUnit; 1825 begin 1826 result := GetInheritedAttribute('r',cmOrtho,FloatWithCSSUnit(50,cuPercent)); 1827 end; 1828 1829 function TSVGRadialGradient.GetFX: TFloatWithCSSUnit; 1830 begin 1831 result := GetInheritedAttribute('fx',cmHoriz,cx); 1832 end; 1833 1834 function TSVGRadialGradient.GetFY: TFloatWithCSSUnit; 1835 begin 1836 result := GetInheritedAttribute('fy',cmVertical,cy); 1837 end; 1838 1839 function TSVGRadialGradient.GetFR: TFloatWithCSSUnit; 1840 begin 1841 result := GetInheritedAttribute('fr',cmHoriz,FloatWithCSSUnit(0,cuPercent)); 1842 end; 1843 1844 procedure TSVGRadialGradient.SetCX(AValue: TFloatWithCSSUnit); 1845 begin 1846 HorizAttributeWithUnit['cx'] := AValue; 1847 end; 1848 1849 procedure TSVGRadialGradient.SetCY(AValue: TFloatWithCSSUnit); 1850 begin 1851 VerticalAttributeWithUnit['cy'] := AValue; 1852 end; 1853 1854 procedure TSVGRadialGradient.SetR(AValue: TFloatWithCSSUnit); 1855 begin 1856 OrthoAttributeWithUnit['r'] := AValue; 1857 end; 1858 1859 procedure TSVGRadialGradient.SetFX(AValue: TFloatWithCSSUnit); 1860 begin 1861 HorizAttributeWithUnit['fx'] := AValue; 1862 end; 1863 1864 procedure TSVGRadialGradient.SetFY(AValue: TFloatWithCSSUnit); 1865 begin 1866 VerticalAttributeWithUnit['fy'] := AValue; 1867 end; 1868 1869 procedure TSVGRadialGradient.SetFR(AValue: TFloatWithCSSUnit); 1870 begin 1871 HorizAttributeWithUnit['fr'] := AValue; 1872 end; 1873 1874 constructor TSVGRadialGradient.Create(ADocument: TXMLDocument; 1875 AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); 1876 begin 1877 inherited Create(ADocument, AUnits, ADataLink); 1878 Init(ADocument,'radialGradient',AUnits); 1879 end; 1880 1881 { TSVGStopGradient } 1882 1883 function TSVGStopGradient.GetOffset: TFloatWithCSSUnit; 1884 begin 1885 result := AttributeWithUnit['offset']; 1886 end; 1887 1888 procedure TSVGStopGradient.SetOffset(AValue: TFloatWithCSSUnit); 1889 begin 1890 AttributeWithUnit['offset'] := AValue; 1891 end; 1892 1893 constructor TSVGStopGradient.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; 1894 ADataLink: TSVGDataLink); 1895 begin 1896 inherited Create(ADocument, AUnits, ADataLink); 1897 Init(ADocument,'stop',AUnits); 1898 end; 1899 1900 { TSVGDefine } 1901 1902 constructor TSVGDefine.Create(ADocument: TXMLDocument; AUnits: TCSSUnitConverter; 1903 ADataLink: TSVGDataLink); 1904 begin 1905 inherited Create(ADocument, AUnits, ADataLink); 1906 FContent := TSVGContent.Create(ADocument,FDomElem,AUnits,ADataLink,Self); 1907 end; 1908 1909 constructor TSVGDefine.Create(ADocument: TXMLDocument; AElement: TDOMElement; 1910 AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); 1911 begin 1912 inherited Create(ADocument, AElement, AUnits, ADataLink); 1913 FContent := TSVGContent.Create(ADocument,AElement,AUnits,ADataLink,Self); 1914 end; 1915 1916 destructor TSVGDefine.Destroy; 1917 begin 1918 FreeAndNil(FContent); 1919 inherited Destroy; 1920 end; 1921 1922 procedure TSVGDefine.Recompute; 1923 begin 1924 inherited Recompute; 1925 FContent.Recompute; 907 1926 end; 908 1927 … … 948 1967 949 1968 constructor TSVGContent.Create(ADocument: TXMLDocument; AElement: TDOMElement; 950 AUnits: TCSSUnitConverter );1969 AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink; ADataParent: TSVGElement); 951 1970 var cur: TDOMNode; 952 1971 begin 953 1972 FDoc := ADocument; 954 1973 FDomElem := AElement; 955 FElements := TList.Create; 1974 FDataLink := ADataLink; 1975 FElements := TFPList.Create; 956 1976 FUnits := AUnits; 957 1977 cur := FDomElem.FirstChild; … … 959 1979 begin 960 1980 if cur is TDOMElement then 961 FElements.Add(CreateSVGElementFromNode(ADocument,TDOMElement(cur),FUnits)); 1981 FElements.Add(CreateSVGElementFromNode( 1982 ADocument,TDOMElement(cur),FUnits,ADataLink,ADataParent)); 962 1983 cur := cur.NextSibling; 963 1984 end; … … 971 1992 FreeAndNil(FElements); 972 1993 inherited Destroy; 1994 end; 1995 1996 procedure TSVGContent.Recompute; 1997 var 1998 i: Integer; 1999 begin 2000 for i := 0 to ElementCount-1 do 2001 Element[i].Recompute; 973 2002 end; 974 2003 … … 996 2025 ): TSVGLine; 997 2026 begin 998 result := TSVGLine.Create(FDoc,Units );2027 result := TSVGLine.Create(FDoc,Units,FDataLink); 999 2028 result.x1 := FloatWithCSSUnit(x1,AUnit); 1000 2029 result.y1 := FloatWithCSSUnit(y1,AUnit); … … 1014 2043 if (AUnit <> cuCustom) and (Units.DpiScaleX <> Units.DpiScaleY) then 1015 2044 begin 1016 result := TSVGCircle.Create(FDoc,Units );2045 result := TSVGCircle.Create(FDoc,Units,FDataLink); 1017 2046 result.cx := FloatWithCSSUnit(Units.Convert(cx,AUnit,cuCustom,Units.DpiX),cuCustom); 1018 2047 result.cy := FloatWithCSSUnit(Units.Convert(cy,AUnit,cuCustom,Units.DpiY),cuCustom); … … 1022 2051 end else 1023 2052 begin 1024 result := TSVGCircle.Create(FDoc,Units );2053 result := TSVGCircle.Create(FDoc,Units,FDataLink); 1025 2054 result.cx := FloatWithCSSUnit(cx,AUnit); 1026 2055 result.cy := FloatWithCSSUnit(cy,AUnit); … … 1039 2068 ): TSVGEllipse; 1040 2069 begin 1041 result := TSVGEllipse.Create(FDoc,Units );2070 result := TSVGEllipse.Create(FDoc,Units,FDataLink); 1042 2071 result.cx := FloatWithCSSUnit(cx,AUnit); 1043 2072 result.cy := FloatWithCSSUnit(cy,AUnit); … … 1062 2091 end else 1063 2092 begin 1064 result := TSVGPath.Create(FDoc,Units );2093 result := TSVGPath.Create(FDoc,Units,FDataLink); 1065 2094 result.d := data; 1066 2095 AppendElement(result); … … 1072 2101 if (AUnit <> cuCustom) and (Units.DpiScaleX <> Units.DpiScaleY) then 1073 2102 begin 1074 result := TSVGPath.Create(FDoc,Units );2103 result := TSVGPath.Create(FDoc,Units,FDataLink); 1075 2104 result.path.scale(Units.Convert(1,AUnit,cuCustom,Units.DpiX)); 1076 2105 path.copyTo(result.path); … … 1079 2108 end else 1080 2109 begin 1081 result := TSVGPath.Create(FDoc,Units );2110 result := TSVGPath.Create(FDoc,Units,FDataLink); 1082 2111 result.path.scale(Units.ConvertWidth(1,AUnit,cuCustom)); 1083 2112 path.copyTo(result.path); … … 1092 2121 i: integer; 1093 2122 begin 1094 result := TSVGPolypoints.Create(FDoc,FUnits,true );2123 result := TSVGPolypoints.Create(FDoc,FUnits,true,FDataLink); 1095 2124 setlength(pts, length(points) div 2); 1096 2125 for i := 0 to high(pts) do … … 1106 2135 i: integer; 1107 2136 begin 1108 result := TSVGPolypoints.Create(FDoc,FUnits,true );2137 result := TSVGPolypoints.Create(FDoc,FUnits,true,FDataLink); 1109 2138 setlength(pts, length(points)); 1110 2139 for i := 0 to high(pts) do … … 1117 2146 ): TSVGRectangle; 1118 2147 begin 1119 result := TSVGRectangle.Create(FDoc,Units );2148 result := TSVGRectangle.Create(FDoc,Units,FDataLink); 1120 2149 result.x := FloatWithCSSUnit(x,AUnit); 1121 2150 result.y := FloatWithCSSUnit(y,AUnit); … … 1134 2163 ): TSVGText; 1135 2164 begin 1136 result := TSVGText.Create(FDoc,Units );2165 result := TSVGText.Create(FDoc,Units,FDataLink); 1137 2166 result.x := FloatWithCSSUnit(x,AUnit); 1138 2167 result.y := FloatWithCSSUnit(y,AUnit); … … 1150 2179 AUnit: TCSSUnit): TSVGRectangle; 1151 2180 begin 1152 result := TSVGRectangle.Create(FDoc,Units );2181 result := TSVGRectangle.Create(FDoc,Units,FDataLink); 1153 2182 result.x := FloatWithCSSUnit(x,AUnit); 1154 2183 result.y := FloatWithCSSUnit(y,AUnit); -
GraphicTest/Packages/bgrabitmap/bgrasvgtype.pas
r494 r521 2 2 3 3 {$mode objfpc}{$H+} 4 {$MODESWITCH ADVANCEDRECORDS} 4 5 5 6 interface … … 7 8 uses 8 9 Classes, SysUtils, BGRATransform, BGRABitmapTypes, BGRAUnits, 9 laz2_DOM, BGRACanvas2D ;10 laz2_DOM, BGRACanvas2D, fgl, BGRAGraphics; 10 11 11 12 type 13 ArrayOfFloat = array of single; 14 12 15 TSVGElement = class; 16 TSVGElementList = specialize TFPGList<TSVGElement>; 13 17 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; 14 91 15 92 { TSVGElement } … … 17 94 TSVGElement = class 18 95 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; 20 102 function GetFill: string; 21 103 function GetFillColor: TBGRAPixel; 22 104 function GetFillOpacity: single; 23 function GetHorizAttributeOrStyleWithUnit(AName: string 24 ): TFloatWithCSSUnit; 105 function GetFillRule: string; 106 function GetHorizAttributeOrStyleWithUnit(AName: string; 107 ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit; 25 108 function GetIsFillNone: boolean; 26 109 function GetIsStrokeNone: boolean; 27 110 function GetMatrix(AUnit: TCSSUnit): TAffineMatrix; 28 111 function GetOpacity: single; 29 function GetOrthoAttributeOrStyleWithUnit(AName: string 30 ): TFloatWithCSSUnit;112 function GetOrthoAttributeOrStyleWithUnit(AName: string; 113 ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit; 31 114 function GetStroke: string; 32 115 function GetStrokeColor: TBGRAPixel; … … 36 119 function GetStrokeOpacity: single; 37 120 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; 39 126 function GetTransform: string; 40 127 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; 44 133 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; 50 147 procedure SetAttributeWithUnit(AName: string; AValue: TFloatWithCSSUnit); 51 148 procedure SetFill(AValue: string); 52 149 procedure SetFillColor(AValue: TBGRAPixel); 53 150 procedure SetFillOpacity(AValue: single); 151 procedure SetFillRule(AValue: string); 54 152 procedure SetHorizAttributeWithUnit(AName: string; AValue: TFloatWithCSSUnit); 55 153 procedure SetMatrix(AUnit: TCSSUnit; const AValue: TAffineMatrix); … … 62 160 procedure SetStrokeOpacity(AValue: single); 63 161 procedure SetStrokeWidth(AValue: TFloatWithCSSUnit); 162 procedure SetStrokeDashArray(AValue: string); 163 procedure SetStrokeDashArrayF(AValue: ArrayOfFloat); 164 procedure SetStrokeDashOffset(AValue: TFloatWithCSSUnit); 64 165 procedure SetStyle(AName: string; AValue: string); 65 166 procedure SetTransform(AValue: string); 66 167 procedure SetVerticalAttributeWithUnit(AName: string; AValue: TFloatWithCSSUnit); 67 168 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; 68 174 protected 175 FDataLink: TSVGDataLink; 69 176 FDomElem: TDOMElement; 70 177 FUnits: TCSSUnitConverter; … … 74 181 procedure InternalDraw({%H-}ACanvas2d: TBGRACanvas2D; {%H-}AUnit: TCSSUnit); virtual; 75 182 procedure LocateStyleDeclaration(AText: string; AProperty: string; out AStartPos,AColonPos,AValueLength: integer); 183 procedure ApplyFillStyle(ACanvas2D: TBGRACanvas2D; {%H-}AUnit: TCSSUnit); virtual; 76 184 procedure ApplyStrokeStyle(ACanvas2D: TBGRACanvas2D; AUnit: TCSSUnit); 185 procedure Initialize; virtual; 77 186 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; 80 191 procedure Draw({%H-}ACanvas2d: TBGRACanvas2D; {%H-}AUnit: TCSSUnit); 81 192 procedure fillNone; … … 83 194 procedure transformNone; 84 195 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; 85 201 property Attribute[AName: string]: string read GetAttribute write SetAttribute; 202 property AttributeOrStyleDef[AName,ADefault: string]: string read GetAttributeOrStyle; 86 203 property AttributeOrStyle[AName: string]: string read GetAttributeOrStyle; 204 property StyleDef[AName,ADefault: string]: string read GetStyle; 87 205 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; 88 209 property OrthoAttributeWithUnit[AName: string]: TFloatWithCSSUnit read GetOrthoAttributeWithUnit write SetOrthoAttributeWithUnit; 210 property HorizAttributeWithUnitDef[AName: string; ADefault: TFloatWithCSSUnit]: TFloatWithCSSUnit read GetHorizAttributeWithUnit; 89 211 property HorizAttributeWithUnit[AName: string]: TFloatWithCSSUnit read GetHorizAttributeWithUnit write SetHorizAttributeWithUnit; 212 property VerticalAttributeWithUnitDef[AName: string; ADefault: TFloatWithCSSUnit]: TFloatWithCSSUnit read GetVerticalAttributeWithUnit; 90 213 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; 94 217 property DOMElement: TDOMElement read GetDOMElement; 95 218 property Units: TCSSUnitConverter read GetUnits; … … 105 228 property strokeLineJoin: string read GetStrokeLineJoin write SetStrokeLineJoin; 106 229 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; 107 233 property fill: string read GetFill write SetFill; 108 234 property fillColor: TBGRAPixel read GetFillColor write SetFillColor; 109 235 property fillOpacity: single read GetFillOpacity write SetFillOpacity; 236 property fillRule: string read GetFillRule write SetFillRule; 110 237 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; 111 241 end; 112 242 … … 125 255 function ParseId: string; 126 256 function ParseSymbol: char; 257 function ParseTransform: TAffineMatrix; 127 258 procedure SkipSymbol(ASymbol: char); 128 259 procedure SkipUpToSymbol(ASymbol:char); … … 133 264 property Done: boolean read GetDone; 134 265 end; 266 267 resourcestring 268 rsInvalidId = 'invalid id'; 135 269 136 270 implementation 271 272 uses BGRASVGShapes; 273 274 { TSVGPreserveAspectRatio } 275 276 function TSVGPreserveAspectRatio.ToString: string; 277 begin 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; 293 end; 294 295 class function TSVGPreserveAspectRatio.Parse(AValue: string 296 ): TSVGPreserveAspectRatio; 297 var p: TSVGParser; 298 id: string; 299 begin 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; 329 end; 330 331 class function TSVGPreserveAspectRatio.DefaultValue: TSVGPreserveAspectRatio; 332 begin 333 result.Preserve := true; 334 result.Slice := false; 335 result.HorizAlign := taCenter; 336 result.VertAlign := tlCenter; 337 end; 137 338 138 339 { TSVGParser } … … 194 395 end; 195 396 397 function TSVGParser.ParseTransform: TAffineMatrix; 398 var 399 kind: String; 400 m : TAffineMatrix; 401 angle,tx,ty: single; 402 begin 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; 462 end; 463 196 464 procedure TSVGParser.SkipSymbol(ASymbol: char); 197 465 begin … … 211 479 end; 212 480 481 { TSVGDataLink } 482 483 constructor TSVGDataLink.Create; 484 begin 485 FElements:= TSVGElementList.Create; 486 FGradients:= TSVGElementList.Create; 487 FStyles:= TSVGElementList.Create; 488 FRootElements:= TSVGElementList.Create; 489 end; 490 491 destructor TSVGDataLink.Destroy; 492 begin 493 FreeAndNil(FRootElements); 494 FreeAndNil(FGradients); 495 FreeAndNil(FElements); 496 FreeAndNil(FStyles); 497 inherited Destroy; 498 end; 499 500 function TSVGDataLink.IsValidID(const id: integer; list: TSVGElementList): boolean; 501 begin 502 result:= (id >= 0) and (id < list.Count); 503 end; 504 505 function TSVGDataLink.GetElement(id: integer): TSVGElement; 506 begin 507 if not IsValidID(id,FElements) then 508 raise exception.Create(rsInvalidId); 509 result:= FElements[id]; 510 end; 511 512 function TSVGDataLink.GetGradient(id: integer): TSVGElement; 513 begin 514 if not IsValidID(id,FGradients) then 515 raise exception.Create(rsInvalidId); 516 result:= FGradients[id]; 517 end; 518 519 function TSVGDataLink.GetStyle(id: integer): TSVGElement; 520 begin 521 if not IsValidID(id,FStyles) then 522 raise exception.Create(rsInvalidId); 523 result:= FStyles[id]; 524 end; 525 526 function TSVGDataLink.GetRootElement(id: integer): TSVGElement; 527 begin 528 if not IsValidID(id,FRootElements) then 529 raise exception.Create(rsInvalidId); 530 result:= FRootElements[id]; 531 end; 532 533 function TSVGDataLink.FindElement(el: TSVGElement; list: TSVGElementList): integer; 534 var 535 i: integer; 536 begin 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; 544 end; 545 546 function TSVGDataLink.Find(el: TSVGElement): integer; 547 begin 548 result:= FindElement(el,FElements); 549 end; 550 551 procedure TSVGDataLink.InternalLink(const id: integer; parent: TSVGElement); 552 var 553 el: TSVGElement; 554 begin 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; 566 end; 567 568 procedure TSVGDataLink.InternalUnLink(const id: integer); 569 var 570 i,pos_root: integer; 571 el: TSVGElement; 572 begin 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; 603 end; 604 605 procedure TSVGDataLink.InternalReLink(const id: integer; parent: TSVGElement); 606 begin 607 InternalUnLink(id); 608 InternalLink(id,parent); 609 end; 610 611 function TSVGDataLink.ElementCount: integer; 612 begin 613 result:= FElements.Count; 614 end; 615 616 function TSVGDataLink.GradientCount: integer; 617 begin 618 result:= FGradients.Count; 619 end; 620 621 function TSVGDataLink.StyleCount: integer; 622 begin 623 result:= FStyles.Count; 624 end; 625 626 function TSVGDataLink.RootElementCount: integer; 627 begin 628 result:= FRootElements.Count; 629 end; 630 631 function TSVGDataLink.IsLink(el: TSVGElement): boolean; 632 begin 633 result:= Find(el) <> -1; 634 end; 635 636 function TSVGDataLink.Link(el: TSVGElement; parent: TSVGElement = nil): integer; 637 begin 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); 645 end; 646 647 procedure TSVGDataLink.Unlink(el: TSVGElement); 648 var 649 id: integer; 650 begin 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'); 663 end; 664 665 procedure TSVGDataLink.UnlinkAll; 666 var 667 i: integer; 668 begin 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; 676 end; 677 678 function TSVGDataLink.ReLink(el: TSVGElement; parent: TSVGElement): boolean; 679 var 680 id: integer; 681 begin 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; 691 end; 692 693 function TSVGDataLink.GetInternalState: TStringList; 694 var 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 754 var 755 i: integer; 756 begin 757 nid:= 0; 758 sl:= TStringList.Create; 759 for i:= 0 to FRootElements.Count-1 do 760 BuildInfo( FRootElements[i] ); 761 result:= sl; 762 end; 763 213 764 { TSVGElement } 214 765 766 function TSVGElement.GetAttribute(AName,ADefault: string; ACanInherit: boolean): string; 767 var 768 curNode: TDOMElement; 769 begin 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; 789 end; 790 791 function TSVGElement.GetAttribute(AName, ADefault: string): string; 792 begin 793 result := GetAttribute(AName, ADefault, False); 794 end; 795 215 796 function TSVGElement.GetAttribute(AName: string): string; 216 797 begin 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,''); 799 end; 800 801 function TSVGElement.GetVerticalAttributeOrStyleWithUnit(AName: string; 802 ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit; 803 begin 804 result := GetAttributeOrStyleWithUnit(AName,ADefault); 224 805 if result.CSSUnit <> cuCustom then 225 806 if units.DpiScaleY = 0 then … … 229 810 end; 230 811 812 function TSVGElement.GetAttributeWithUnit(AName: string; ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit; 813 begin 814 result := TCSSUnitConverter.parseValue(Attribute[AName],ADefault); 815 end; 816 231 817 function TSVGElement.GetAttributeWithUnit(AName: string): TFloatWithCSSUnit; 232 818 begin 233 result := TCSSUnitConverter.parseValue(Attribute[AName],FloatWithCSSUnit(0,cuCustom));234 end; 235 236 function TSVGElement.GetAttributeOrStyleWithUnit(AName: string 237 ): TFloatWithCSSUnit; 238 varvalueText: string;819 result := GetAttributeWithUnit(AName,FloatWithCSSUnit(0,cuCustom)); 820 end; 821 822 function TSVGElement.GetAttributeOrStyleWithUnit(AName: string; ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit; 823 var 824 valueText: string; 239 825 begin 240 826 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); 830 end; 831 832 function TSVGElement.GetAttributeOrStyleWithUnit(AName: string): TFloatWithCSSUnit; 833 begin 834 result := GetAttributeOrStyleWithUnit(AName,FloatWithCSSUnit(0,cuCustom)); 835 end; 836 837 function TSVGElement.GetOrthoAttributeWithUnit(AName: string; 838 ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit; 839 begin 840 result := GetHorizAttributeWithUnit(AName,ADefault); 249 841 //value will be inconsistent if scaling is inconsistent 250 842 end; 251 843 252 function TSVGElement.GetHorizAttributeWithUnit(AName: string 253 ): TFloatWithCSSUnit; 254 begin 255 result := GetAttributeWithUnit(AName); 844 function TSVGElement.GetOrthoAttributeWithUnit(AName: string): TFloatWithCSSUnit; 845 begin 846 result := GetOrthoAttributeWithUnit(AName,FloatWithCSSUnit(0,cuCustom)); 847 end; 848 849 function TSVGElement.GetHorizAttributeWithUnit(AName: string; 850 ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit; 851 begin 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; 861 end; 862 863 function TSVGElement.GetHorizAttributeWithUnit(AName: string): TFloatWithCSSUnit; 864 begin 865 result := GetHorizAttributeWithUnit(AName,FloatWithCSSUnit(0,cuCustom)); 866 end; 867 868 function TSVGElement.GetAttributeOrStyle(AName,ADefault: string): string; 869 begin 870 result := GetStyle(AName,ADefault); 871 if result = '' then 872 result := GetAttribute(AName,ADefault,True); 873 end; 874 875 function TSVGElement.GetAttributeOrStyle(AName: string): string; 876 begin 877 result:= GetAttributeOrStyle(AName,''); 878 end; 879 880 function TSVGElement.GetFill: string; 881 begin 882 result := AttributeOrStyleDef['fill','black']; 883 end; 884 885 function TSVGElement.GetFillColor: TBGRAPixel; 886 begin 887 result := StrToBGRA(fill,BGRABlack); 888 result.alpha := round(result.alpha*fillOpacity*opacity); 889 if result.alpha = 0 then result := BGRAPixelTransparent; 890 end; 891 892 function TSVGElement.GetFillOpacity: single; 893 var errPos: integer; 894 begin 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; 899 end; 900 901 function TSVGElement.GetFillRule: string; 902 begin 903 result := AttributeOrStyleDef['fill-rule','nonzero']; 904 end; 905 906 function TSVGElement.GetHorizAttributeOrStyleWithUnit(AName: string; 907 ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit; 908 begin 909 result := GetAttributeOrStyleWithUnit(AName,ADefault); 256 910 if result.CSSUnit <> cuCustom then 257 911 if units.DpiScaleX = 0 then … … 261 915 end; 262 916 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; 917 function TSVGElement.GetIsFillNone: boolean; 918 begin 919 result := compareText(trim(fill),'none')=0; 920 end; 921 922 function TSVGElement.GetIsStrokeNone: boolean; 923 var strokeStr: string; 924 begin 925 strokeStr := stroke; 926 result := (trim(strokeStr)='') or (compareText(trim(strokeStr),'none')=0); 927 end; 928 929 function TSVGElement.GetMatrix(AUnit: TCSSUnit): TAffineMatrix; 930 var parser: TSVGParser; 931 s: string; 932 begin 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; 944 end; 945 946 function TSVGElement.GetOpacity: single; 282 947 var errPos: integer; 283 948 begin 284 val(AttributeOrStyle ['fill-opacity'], result, errPos);949 val(AttributeOrStyleDef['opacity','1'], result, errPos); 285 950 if errPos <> 0 then result := 1 else 286 951 if result < 0 then result := 0 else … … 288 953 end; 289 954 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; 955 function TSVGElement.GetOrthoAttributeOrStyleWithUnit(AName: string; 956 ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit; 957 begin 958 result := GetHorizAttributeOrStyleWithUnit(AName,ADefault); 959 //value will be inconsistent if scaling is inconsistent 960 end; 961 962 function TSVGElement.GetStroke: string; 963 begin 964 result := AttributeOrStyleDef['stroke','none']; 965 end; 966 967 function TSVGElement.GetStrokeColor: TBGRAPixel; 968 begin 969 result := StrToBGRA(stroke); 970 result.alpha := round(result.alpha*strokeOpacity*opacity); 971 if result.alpha = 0 then result := BGRAPixelTransparent; 972 end; 973 974 function TSVGElement.GetStrokeLineCap: string; 975 begin 976 result := AttributeOrStyleDef['stroke-linecap','butt']; 977 end; 978 979 function TSVGElement.GetStrokeLineJoin: string; 980 begin 981 result := AttributeOrStyleDef['stroke-linejoin','miter']; 982 end; 983 984 function TSVGElement.GetStrokeMiterLimit: single; 387 985 var errPos: integer; 388 986 begin 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; 990 end; 991 992 function TSVGElement.GetStrokeOpacity: single; 993 var errPos: integer; 994 begin 995 val(AttributeOrStyleDef['stroke-opacity','1'], result, errPos); 390 996 if errPos <> 0 then result := 1 else 391 997 if result < 0 then result := 0 else … … 393 999 end; 394 1000 395 function TSVGElement.GetOrthoAttributeOrStyleWithUnit(AName: string396 ): TFloatWithCSSUnit;397 begin398 result := GetHorizAttributeOrStyleWithUnit(AName);399 //value will be inconsistent if scaling is inconsistent400 end;401 402 function TSVGElement.GetStroke: string;403 begin404 result := AttributeOrStyle['stroke'];405 end;406 407 function TSVGElement.GetStrokeColor: TBGRAPixel;408 begin409 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 begin416 result := AttributeOrStyle['stroke-linecap'];417 if result = '' then result := 'butt';418 end;419 420 function TSVGElement.GetStrokeLineJoin: string;421 begin422 result := AttributeOrStyle['stroke-linejoin'];423 if result = '' then result := 'miter';424 end;425 426 function TSVGElement.GetStrokeMiterLimit: single;427 var errPos: integer;428 begin429 val(AttributeOrStyle['stroke-miterlimit'], result, errPos);430 if errPos <> 0 then result := 4 else431 if result < 1 then result := 1;432 end;433 434 function TSVGElement.GetStrokeOpacity: single;435 var errPos: integer;436 begin437 val(AttributeOrStyle['stroke-opacity'], result, errPos);438 if errPos <> 0 then result := 1 else439 if result < 0 then result := 0 else440 if result > 1 then result := 1;441 end;442 443 1001 function TSVGElement.GetStrokeWidth: TFloatWithCSSUnit; 444 1002 begin 445 result := OrthoAttributeOrStyleWithUnit['stroke-width']; 446 end; 1003 result := OrthoAttributeOrStyleWithUnit['stroke-width',FloatWithCSSUnit(1,cuCustom)]; 1004 end; 1005 1006 function TSVGElement.GetStrokeDashArray: string; 1007 begin 1008 result := AttributeDef['stroke-dasharray','none']; 1009 end; 1010 1011 function TSVGElement.GetStrokeDashArrayF: ArrayOfFloat; 1012 var 1013 parser: TSVGParser; 1014 nvalue,i: integer; 1015 s_array: String; 1016 begin 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; 1036 end; 1037 1038 function TSVGElement.GetStrokeDashOffset: TFloatWithCSSUnit; 1039 begin 1040 result := OrthoAttributeWithUnit['stroke-dashoffset']; 1041 end; 1042 1043 function 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 1056 var 1057 i: integer; 1058 begin 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] ); 1076 end; 447 1077 448 1078 function 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; 1079 begin 1080 result:= GetStyle(AName,''); 1081 end; 461 1082 462 1083 function TSVGElement.GetTransform: string; … … 470 1091 end; 471 1092 1093 function TSVGElement.GetVerticalAttributeWithUnit(AName: string; ADefault: TFloatWithCSSUnit): TFloatWithCSSUnit; 1094 begin 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; 1104 end; 1105 472 1106 function TSVGElement.GetVerticalAttributeWithUnit(AName: string): TFloatWithCSSUnit; 473 1107 begin 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)); 1109 end; 481 1110 482 1111 function TSVGElement.GetDOMElement: TDOMElement; … … 484 1113 result := FDomElem; 485 1114 end; 1115 1116 function TSVGElement.GetID: string; 1117 begin 1118 result := Attribute['id']; 1119 end; 1120 1121 function TSVGElement.GetClassAt: string; 1122 begin 1123 result := Attribute['class']; 1124 end; 486 1125 487 1126 procedure TSVGElement.SetAttribute(AName: string; AValue: string); … … 514 1153 RemoveStyle('fill-opacity'); 515 1154 end; 1155 1156 procedure TSVGElement.SetFillRule(AValue: string); 1157 begin 1158 Attribute['fill-rule'] := AValue; 1159 RemoveStyle('fill-rule'); 1160 end; 516 1161 517 1162 procedure TSVGElement.SetHorizAttributeWithUnit(AName: string; … … 613 1258 end; 614 1259 1260 procedure TSVGElement.SetStrokeDashArray(AValue: string); 1261 begin 1262 Attribute['stroke-dasharray'] := AValue; 1263 end; 1264 1265 procedure TSVGElement.SetStrokeDashArrayF(AValue: ArrayOfFloat); 1266 var 1267 s: string; 1268 i: integer; 1269 begin 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; 1277 end; 1278 1279 procedure TSVGElement.SetStrokeDashOffset(AValue: TFloatWithCSSUnit); 1280 begin 1281 OrthoAttributeWithUnit['stroke-dashoffset'] := AValue; 1282 end; 1283 615 1284 procedure TSVGElement.SetStyle(AName: string; AValue: string); 616 1285 var … … 668 1337 SetHorizAttributeWithUnit(AName,AValue); 669 1338 end; 1339 1340 procedure TSVGElement.SetID(AValue: string); 1341 begin 1342 Attribute['id'] := AValue; 1343 end; 1344 1345 procedure TSVGElement.SetClassAt(AValue: string); 1346 begin 1347 Attribute['class'] := AValue; 1348 end; 670 1349 671 1350 procedure TSVGElement.Init(ADocument: TXMLDocument; ATag: string; … … 748 1427 end; 749 1428 1429 procedure TSVGElement.ApplyFillStyle(ACanvas2D: TBGRACanvas2D; AUnit: TCSSUnit); 1430 begin 1431 ACanvas2D.fillStyle(fillColor); 1432 1433 ACanvas2D.fillMode := TFillMode(fillMode); 1434 end; 1435 750 1436 procedure TSVGElement.ApplyStrokeStyle(ACanvas2D: TBGRACanvas2D; AUnit: TCSSUnit); 1437 var 1438 a: ArrayOfFloat; 1439 lw: single; 1440 i: Integer; 751 1441 begin 752 1442 ACanvas2d.strokeStyle(strokeColor); 753 ACanvas2d.lineWidth := Units.ConvertWidth(strokeWidth,AUnit).value; 1443 lw := Units.ConvertWidth(strokeWidth,AUnit).value; 1444 ACanvas2d.lineWidth := lw; 754 1445 ACanvas2d.lineCap := strokeLineCap; 755 1446 ACanvas2d.lineJoin := strokeLineJoin; 756 1447 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); 1458 end; 1459 1460 procedure TSVGElement.Initialize; 1461 begin 1462 SetLength(styleAttributes,0); 1463 findStyleState := fssNotSearch; 1464 FDataParent := nil; 1465 FDataChildList := TSVGElementList.Create; 757 1466 end; 758 1467 759 1468 constructor TSVGElement.Create(ADocument: TXMLDocument; AElement: TDOMElement; 760 AUnits: TCSSUnitConverter); 761 begin 1469 AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); 1470 begin 1471 FDataLink:= ADataLink; 1472 Initialize; 762 1473 Init(ADocument,AElement,AUnits); 763 1474 end; 764 1475 765 1476 constructor TSVGElement.Create(ADocument: TXMLDocument; 766 AUnits: TCSSUnitConverter); 767 begin 768 raise exception.Create('Cannot create a generic element'); 1477 AUnits: TCSSUnitConverter; ADataLink: TSVGDataLink); 1478 begin 1479 FDataLink:= ADataLink; 1480 Initialize; 1481 //raise exception.Create('Cannot create a generic element'); 1482 end; 1483 1484 destructor TSVGElement.Destroy; 1485 begin 1486 SetLength(styleAttributes,0); 1487 FreeAndNil(FDataChildList); 1488 inherited Destroy; 1489 end; 1490 1491 procedure TSVGElement.Recompute; 1492 begin 1493 769 1494 end; 770 1495 … … 809 1534 end; 810 1535 1536 function TSVGElement.HasAttribute(AName: string): boolean; 1537 begin 1538 result := FDomElem.hasAttribute(AName); 1539 end; 1540 1541 function TSVGElement.fillMode: TSVGFillMode; 1542 begin 1543 if fillRule = 'evenodd' then 1544 result := sfmEvenOdd 1545 else 1546 result := sfmNonZero; 1547 end; 1548 1549 function TSVGElement.DataChildList: TSVGElementList; 1550 begin 1551 result:= FDataChildList; 1552 end; 1553 1554 function TSVGElement.FindStyleElementInternal(const classStr: string; 1555 out attributesStr: string): integer; 1556 var 1557 i: integer; 1558 begin 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; 1571 end; 1572 1573 procedure 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 1589 var 1590 fid: integer; 1591 tag,styleC,s: string; 1592 begin 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; 1631 end; 1632 811 1633 end. 812 1634 -
GraphicTest/Packages/bgrabitmap/bgratext.pas
r494 r521 8 8 {$DEFINE LCL_RENDERER_IS_FINE} 9 9 {$DEFINE LCL_CLEARTYPE_RENDERER_IS_FINE} 10 {$DEFINE RENDER_TEXT_ON_TBITMAP} 10 11 {$ENDIF} 11 12 {$IFDEF FREEBSD} … … 17 18 {$DEFINE RENDER_TEXT_ON_TBITMAP} 18 19 {$ENDIF} 20 {$IFDEF WINDOWS} 21 {$IFNDEF LEGACY_FONT_VERTICAL_OFFSET} 22 {$DEFINE FIX_FONT_VERTICAL_OFFSET} 23 {$ENDIF} 24 {$ENDIF} 19 25 20 26 { … … 32 38 33 39 uses 34 Classes, Types, SysUtils, BGRAGraphics, BGRABitmapTypes, InterfaceBase, BGRAPen, BGRAGrayscaleMask; 40 Classes, Types, SysUtils, BGRAGraphics, BGRABitmapTypes, InterfaceBase, BGRAPen, BGRAGrayscaleMask, 41 LCLVersion; 35 42 36 43 type … … 44 51 FWordBreakHandler: TWordBreakHandler; 45 52 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); 48 57 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); 49 67 public 50 68 procedure SplitText(var ATextUTF8: string; AMaxWidth: integer; out ARemainsUTF8: string); 51 69 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; 60 80 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; 61 84 constructor Create; 62 85 destructor Destroy; override; … … 67 90 68 91 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 74 93 end; 75 94 … … 79 98 80 99 procedure 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); 82 102 83 103 procedure BGRATextOutAngle(bmp: TBGRACustomBitmap; Font: TFont; Quality: TBGRAFontQuality; xf, yf: single; orientationTenthDegCCW: integer; 84 104 sUTF8: string; c: TBGRAPixel; tex: IBGRAScanner; align: TAlignment; CustomAntialiasingLevel: Integer = 0); 85 105 86 procedure BGRATextRect(bmp: TBGRACustomBitmap; Font: TFont; Quality: TBGRAFontQuality; ARect: TRect; x , y: integer;106 procedure BGRATextRect(bmp: TBGRACustomBitmap; Font: TFont; Quality: TBGRAFontQuality; ARect: TRect; xf, yf: single; 87 107 sUTF8: string; style: TTextStyle; c: TBGRAPixel; tex: IBGRAScanner; CustomAntialiasingLevel: Integer = 0); 88 108 89 109 function BGRATextSize(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer): TSize; 110 function BGRATextFitInfo(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer; AMaxWidth: integer): integer; 90 111 function 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; 112 function BGRAOriginalTextSizeEx(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer; 113 out actualAntialiasingLevel: integer; out extraVerticalMarginDueToRotation: integer): TSize; 92 114 93 115 function BGRATextUnderline(ATopLeft: TPointF; AWidth: Single; AMetrics: TFontPixelMetric): ArrayOfTPointF; overload; … … 101 123 function LCLFontAvailable: boolean; 102 124 function GetFineClearTypeAuto: TBGRAFontQuality; 125 function FixLCLFontFullHeight({%H-}AFontName: string; AFontHeight: integer): integer; 103 126 104 127 procedure BGRAFillClearTypeGrayscaleMask(dest: TBGRACustomBitmap; x,y: integer; xThird: integer; mask: TGrayscaleMask; color: TBGRAPixel; texture: IBGRAScanner = nil; RGBOrder: boolean=true); … … 116 139 implementation 117 140 118 uses GraphType, Math, BGRABlend, BGRAUTF8; 141 uses GraphType, Math, BGRABlend, BGRAUTF8, BGRAUnicode, BGRATextBidi 142 {$IF lcl_fullversion >= 1070000}, lclplatformdef{$ENDIF}; 119 143 120 144 const MaxPixelMetricCount = 100; … … 281 305 function GetLCLFontPixelMetric(AFont: TFont): TFontPixelMetric; 282 306 var i,startPos,endPos: integer; 283 begin 307 prevHeight,fixHeight: integer; 308 begin 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 284 328 FindPixelMetricPos(AFont,startPos,endPos); 285 329 for i := startPos to endPos-1 do … … 428 472 end else 429 473 if (green = 0) then break; 474 bgra.Free; 430 475 lclBmp.Free; 431 476 end; … … 433 478 fqFineClearTypeComputed:= true; 434 479 end; 480 481 {$IFNDEF WINDOWS} 482 var LCLFontFullHeightRatio : array of record 483 FontName: string; 484 Ratio: single; 485 end; 486 {$ENDIF} 487 488 function FixLCLFontFullHeight(AFontName: string; AFontHeight: integer): integer; 489 {$IFNDEF WINDOWS} 490 const TestHeight = 200; 491 var 492 i: Integer; 493 ratio : single; 494 f: TFont; 495 h: LongInt; 496 begin 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; 525 end; 526 {$ELSE} 527 begin 528 result := AFontHeight; 529 end; 530 {$ENDIF} 435 531 436 532 function FontEmHeightSign: integer; … … 469 565 end; 470 566 471 function BGRAOriginalTextSizeEx(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer; out actualAntialiasingLevel: integer): TSize; 567 function BGRAOriginalTextSizeEx(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer; 568 out actualAntialiasingLevel: integer; out extraVerticalMarginDueToRotation: integer): TSize; 472 569 begin 473 570 actualAntialiasingLevel:= CustomAntialiasingLevel; 571 extraVerticalMarginDueToRotation := 0; 474 572 if not LCLFontAvailable then 475 573 result := Size(0,0) … … 490 588 Result.cy := 0; 491 589 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; 492 595 except 493 596 on ex: exception do … … 501 604 end; 502 605 606 function BGRATextFitInfo(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string; 607 CustomAntialiasingLevel: Integer; AMaxWidth: integer): integer; 608 var 609 actualAntialiasingLevel: Integer; 610 begin 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; 638 end; 639 503 640 function BGRAOriginalTextSize(Font: TFont; Quality: TBGRAFontQuality; sUTF8: string; CustomAntialiasingLevel: Integer): TSize; 504 var actualAntialiasingLevel: integer; 505 begin 506 result := BGRAOriginalTextSizeEx(Font, Quality, sUTF8, CustomAntialiasingLevel, actualAntialiasingLevel); 641 var actualAntialiasingLevel, extraMargin: integer; 642 begin 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} 507 647 end; 508 648 … … 515 655 result.cy := ceil(Result.cy/CustomAntialiasingLevel); 516 656 end; 657 end; 658 659 function RemovePrefix(sUTF8: string): string; 660 var i,resLen: integer; 661 begin 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); 517 685 end; 518 686 … … 562 730 grayscaleMask := TGrayscaleMask.Create(temp, cGreen); 563 731 FreeAndNil(temp); 732 {$IFNDEF LINUX} 564 733 pb := grayscaleMask.Data; 565 734 for n := grayscaleMask.NbPixels - 1 downto 0 do … … 568 737 Inc(pb); 569 738 end; 739 {$ENDIF} 570 740 end; 571 741 end; … … 611 781 612 782 procedure 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); 614 785 var 615 786 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; 627 791 begin 628 792 if not LCLFontAvailable then exit; … … 648 812 {$ENDIF} 649 813 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); 651 820 if (size.cx = 0) or (size.cy = 0) then 652 821 exit; … … 654 823 if (size.cy >= 144) and (Quality in[fqFineAntialiasing,fqFineClearTypeBGR,fqFineClearTypeRGB]) and (CustomAntialiasingLevel > 4) then 655 824 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); 658 827 end; 659 828 … … 664 833 end; 665 834 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); 732 845 end; 733 846 … … 740 853 size: TSize; 741 854 temp: TBGRACustomBitmap; 742 Top Right,BottomRight,BottomLeft: TPointF;743 Top : Single;855 TopLeft,TopRight,BottomRight,BottomLeft: TPointF; 856 Top,dy: Single; 744 857 Left: Single; 745 858 cosA,sinA: single; 746 859 rotBounds: TRect; 747 sizeFactor : integer;860 sizeFactor, extraVerticalMargin: integer; 748 861 TempFont: TFont; 749 862 oldOrientation: integer; … … 781 894 TempFont.Orientation := orientationTenthDegCCW; 782 895 TempFont.Height := Font.Height; 783 size := BGRAOriginalTextSizeEx(TempFont,Quality,sUTF8,CustomAntialiasingLevel,sizeFactor );896 size := BGRAOriginalTextSizeEx(TempFont,Quality,sUTF8,CustomAntialiasingLevel,sizeFactor, extraVerticalMargin); 784 897 if (size.cx = 0) or (size.cy = 0) then 785 898 begin … … 787 900 exit; 788 901 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} 789 910 tempFont.Free; 790 911 791 912 cosA := cos(orientationTenthDegCCW*Pi/1800); 792 913 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); 796 920 rotBounds := rect(0,0,0,0); 797 921 Top := 0; … … 854 978 end; 855 979 856 procedure BGRATextRect(bmp: TBGRACustomBitmap; Font: TFont; Quality: TBGRAFontQuality; ARect: TRect; x , y: integer;980 procedure BGRATextRect(bmp: TBGRACustomBitmap; Font: TFont; Quality: TBGRAFontQuality; ARect: TRect; xf, yf: single; 857 981 sUTF8: string; style: TTextStyle; c: TBGRAPixel; tex: IBGRAScanner; CustomAntialiasingLevel: Integer = 0); 858 982 var … … 920 1044 Canvas.Font.Color := clWhite; 921 1045 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); 923 1049 end; 924 1050 {$IFDEF RENDER_TEXT_ON_TBITMAP} … … 933 1059 end; 934 1060 935 { TLCLFontRenderer }936 937 function TLCLFontRenderer.TextSurfaceSmaller(sUTF8: string; ARect: TRect): boolean;938 begin939 with TextSize(sUTF8) do940 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 begin946 if not style.Clipping or TextSurfaceSmaller(sUTF8,ARect) then947 begin948 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 begin958 if not style.Clipping or TextSurfaceSmaller(sUTF8,ARect) then959 begin960 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 967 1061 { TCustomLCLFontRenderer } 968 1062 969 1063 { Update font properties to internal TFont object } 970 1064 procedure TCustomLCLFontRenderer.UpdateFont; 1065 var fixedHeight: integer; 971 1066 begin 972 1067 if FFont.Name <> FontName then … … 974 1069 if FFont.Style <> FontStyle then 975 1070 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; 978 1077 if FFont.Orientation <> FontOrientation then 979 1078 FFont.Orientation := FontOrientation; … … 984 1083 end; 985 1084 986 function TCustomLCLFontRenderer.TextSizeNoUpdateFont(sUTF8: string): TSize; 987 begin 1085 function TCustomLCLFontRenderer.InternalTextSize(sUTF8: string; AShowPrefix: boolean): TSize; 1086 begin 1087 if AShowPrefix then sUTF8 := RemovePrefix(sUTF8); 988 1088 result := BGRAText.BGRATextSize(FFont,FontQuality,sUTF8,FontAntialiasingLevel); 989 1089 if (result.cy >= 24) and (FontQuality in[fqFineAntialiasing,fqFineClearTypeBGR,fqFineClearTypeRGB]) then … … 993 1093 procedure TCustomLCLFontRenderer.SplitText(var ATextUTF8: string; 994 1094 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; 1095 var WordBreakHandler: TWordBreakHandler; 1096 begin 1008 1097 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); 1033 1104 end; 1034 1105 … … 1070 1141 procedure TCustomLCLFontRenderer.TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; 1071 1142 texture: IBGRAScanner; align: TAlignment); 1072 var mode : TBGRATextOutImproveReadabilityMode;1073 1143 begin 1074 1144 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); 1087 1146 end; 1088 1147 1089 1148 procedure TCustomLCLFontRenderer.TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; c: TBGRAPixel; 1090 1149 align: TAlignment); 1091 var mode : TBGRATextOutImproveReadabilityMode;1092 1150 begin 1093 1151 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); 1153 end; 1154 1155 procedure TCustomLCLFontRenderer.TextOut(ADest: TBGRACustomBitmap; x, 1156 y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment; 1157 ARightToLeft: boolean); 1158 begin 1159 UpdateFont; 1160 InternalTextOut(ADest, x,y, sUTF8, BGRAPixelTransparent,texture, align, 1161 False, ARightToLeft); 1162 end; 1163 1164 procedure TCustomLCLFontRenderer.TextOut(ADest: TBGRACustomBitmap; x, 1165 y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment; 1166 ARightToLeft: boolean); 1167 begin 1168 UpdateFont; 1169 InternalTextOut(ADest, x,y, sUTF8, c,nil, align, false, ARightToLeft); 1106 1170 end; 1107 1171 … … 1109 1173 style: TTextStyle; c: TBGRAPixel); 1110 1174 begin 1175 UpdateFont; 1111 1176 InternalTextRect(ADest,ARect,x,y,sUTF8,style,c,nil); 1112 1177 end; … … 1115 1180 style: TTextStyle; texture: IBGRAScanner); 1116 1181 begin 1182 UpdateFont; 1117 1183 InternalTextRect(ADest,ARect,x,y,sUTF8,style,BGRAPixelTransparent,texture); 1118 1184 end; … … 1120 1186 procedure TCustomLCLFontRenderer.TextWordBreak(ADest: TBGRACustomBitmap; 1121 1187 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); 1189 begin 1190 UpdateFont; 1191 InternalTextWordBreak(ADest,AText,x,y,AMaxWidth,AColor,nil,AHorizAlign,AVertAlign,ARightToLeft); 1125 1192 end; 1126 1193 1127 1194 procedure TCustomLCLFontRenderer.TextWordBreak(ADest: TBGRACustomBitmap; 1128 1195 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); 1197 begin 1198 UpdateFont; 1199 InternalTextWordBreak(ADest,AText,x,y,AMaxWidth,BGRAPixelTransparent,ATexture,AHorizAlign,AVertAlign,ARightToLeft); 1132 1200 end; 1133 1201 1134 1202 procedure TCustomLCLFontRenderer.InternalTextWordBreak( 1135 1203 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); 1206 var remains, part, curText,nextText: string; 1138 1207 stepX,stepY: integer; 1139 1208 lines: TStringList; 1140 1209 i: integer; 1141 1210 lineShift: single; 1211 WordBreakHandler: TWordBreakHandler; 1212 lineEndingBreak: boolean; 1213 bidiLayout: TBidiTextLayout; 1214 bidiAlign: TBidiTextAlignment; 1142 1215 begin 1143 1216 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; 1144 1251 1145 1252 stepX := 0; 1146 1253 stepY := TextSize('Hg').cy; 1147 1254 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; 1185 1289 end; 1186 1290 … … 1190 1294 var 1191 1295 previousClip, intersected: TRect; 1192 oldOrientation: integer; 1296 lines: TStringList; 1297 iStart,i,h: integer; 1298 availableWidth: integer; 1193 1299 begin 1194 1300 previousClip := ADest.ClipRect; … … 1199 1305 ADest.ClipRect := intersected; 1200 1306 end; 1201 oldOrientation:= FontOrientation;1202 FontOrientation:= 0;1307 FFont.Orientation := 0; 1308 if style.SystemFont then FFont.Name := 'default'; 1203 1309 1204 1310 if not (style.Alignment in[taCenter,taRightJustify]) then ARect.Left := x; 1205 1311 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; 1207 1317 if style.Layout = tlCenter then Y := (ARect.Top+ARect.Bottom) div 2 else 1208 1318 if style.Layout = tlBottom then Y := ARect.Bottom else … … 1212 1322 X := ARect.Left; 1213 1323 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 1215 1329 else 1216 1330 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 1221 1352 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 1226 1387 if style.Clipping then 1227 1388 ADest.ClipRect := previousClip; 1389 end; 1390 1391 procedure TCustomLCLFontRenderer.InternalTextOut(ADest: TBGRACustomBitmap; x, 1392 y: single; sUTF8: string; c: TBGRAPixel; texture: IBGRAScanner; 1393 align: TAlignment; AShowPrefix: boolean = false; ARightToLeft: boolean = false); 1394 var mode : TBGRATextOutImproveReadabilityMode; 1395 begin 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); 1419 end; 1420 1421 procedure TCustomLCLFontRenderer.InternalTextOutEllipse( 1422 ADest: TBGRACustomBitmap; x, y, availableWidth: single; sUTF8: string; 1423 c: TBGRAPixel; texture: IBGRAScanner; align: TAlignment; 1424 AShowPrefix: boolean; ARightToLeft: boolean); 1425 var remain: string; 1426 begin 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); 1433 end; 1434 1435 procedure TCustomLCLFontRenderer.InternalSplitText(var ATextUTF8: string; 1436 AMaxWidth: integer; out ARemainsUTF8: string; out ALineEndingBreak: boolean; AWordBreak: TWordBreakHandler); 1437 var p,skipCount, charLen: integer; 1438 zeroWidth: boolean; 1439 u: Cardinal; 1440 begin 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); 1484 end; 1485 1486 procedure TCustomLCLFontRenderer.InternalSplitText(var ATextUTF8: string; 1487 AMaxWidth: integer; out ARemainsUTF8: string; AWordBreak: TWordBreakHandler); 1488 var lineEndingBreak: boolean; 1489 begin 1490 InternalSplitText(ATextUTF8,AMaxWidth,ARemainsUTF8,lineEndingBreak,AWordBreak); 1491 end; 1492 1493 procedure TCustomLCLFontRenderer.DefaultWorkBreakHandler(var ABeforeUTF8, 1494 AAfterUTF8: string); 1495 begin 1496 BGRADefaultWordBreakHandler(ABeforeUTF8,AAfterUTF8); 1228 1497 end; 1229 1498 … … 1234 1503 FontOrientation:= 0; 1235 1504 UpdateFont; 1236 result := TextSizeNoUpdateFont(sUTF8);1505 result := InternalTextSize(sUTF8,False); 1237 1506 FontOrientation:= oldOrientation; 1507 end; 1508 1509 function TCustomLCLFontRenderer.TextSizeAngle(sUTF8: string; 1510 orientationTenthDegCCW: integer): TSize; 1511 var oldOrientation: integer; 1512 begin 1513 oldOrientation:= FontOrientation; 1514 FontOrientation:= orientationTenthDegCCW; 1515 UpdateFont; 1516 result := InternalTextSize(sUTF8,False); 1517 FontOrientation:= oldOrientation; 1518 end; 1519 1520 function TCustomLCLFontRenderer.TextSize(sUTF8: string; 1521 AMaxWidth: integer; ARightToLeft: boolean): TSize; 1522 var 1523 remains: string; 1524 h, i, w: integer; 1525 WordBreakHandler: TWordBreakHandler; 1526 layout: TBidiTextLayout; 1527 begin 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; 1563 end; 1564 1565 function TCustomLCLFontRenderer.TextFitInfo(sUTF8: string; AMaxWidth: integer 1566 ): integer; 1567 begin 1568 UpdateFont; 1569 result := BGRATextFitInfo(FFont, FontQuality, sUTF8, FontAntialiasingLevel, AMaxWidth); 1238 1570 end; 1239 1571 -
GraphicTest/Packages/bgrabitmap/bgratextfx.pas
r494 r521 62 62 OutlineVisible,OuterOutlineOnly: boolean; 63 63 OutlineTexture: IBGRAScanner; 64 constructor Create; 65 constructor Create(AShader: TCustomPhongShading; AShaderOwner: boolean); 64 constructor Create; overload; 65 constructor Create(AShader: TCustomPhongShading; AShaderOwner: boolean); overload; 66 66 destructor Destroy; override; 67 67 procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientation: integer; 68 s: string; texture: IBGRAScanner; align: TAlignment); over ride;68 s: string; texture: IBGRAScanner; align: TAlignment); overload; override; 69 69 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; 76 78 property Shader: TCustomPhongShading read FShader; 77 79 property ShaderLightPosition: TPoint read GetShaderLightPosition write SetShaderLightPosition; … … 87 89 procedure InitWithFontName(AText: string; AFontName: string; AFullHeight: integer; AStyle: TFontStyles; Antialiasing: boolean; SubOffsetX,SubOffsetY: single); 88 90 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; 96 98 end; 97 99 … … 509 511 end; 510 512 513 procedure TBGRATextEffectFontRenderer.TextOut(ADest: TBGRACustomBitmap; x, 514 y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment; 515 ARightToLeft: boolean); 516 begin 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); 521 end; 522 523 procedure TBGRATextEffectFontRenderer.TextOut(ADest: TBGRACustomBitmap; x, 524 y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment; 525 ARightToLeft: boolean); 526 begin 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); 531 end; 532 511 533 function TBGRATextEffectFontRenderer.TextSize(sUTF8: string): TSize; 512 534 begin … … 514 536 result := VectorizedFontRenderer.TextSize(sUTF8) 515 537 else 516 begin517 538 result := inherited TextSize(sUTF8); 518 end; 539 end; 540 541 function TBGRATextEffectFontRenderer.TextSize(sUTF8: string; 542 AMaxWidth: integer; ARightToLeft: boolean): TSize; 543 begin 544 if VectorizedFontNeeded then 545 result := VectorizedFontRenderer.TextSize(sUTF8, AMaxWidth, ARightToLeft) 546 else 547 result := inherited TextSize(sUTF8, AMaxWidth, ARightToLeft); 548 end; 549 550 function TBGRATextEffectFontRenderer.TextFitInfo(sUTF8: string; 551 AMaxWidth: integer): integer; 552 begin 553 if VectorizedFontNeeded then 554 result := VectorizedFontRenderer.TextFitInfo(sUTF8, AMaxWidth) 555 else 556 result := inherited TextFitInfo(sUTF8, AMaxWidth) 519 557 end; 520 558 … … 526 564 overhang: integer; 527 565 begin 566 FShadowQuality:= rbFast; 528 567 if SubOffsetX < 0 then SubOffsetX := 0; 529 568 if SubOffsetY < 0 then SubOffsetY := 0; -
GraphicTest/Packages/bgrabitmap/bgrathumbnail.pas
r494 r521 9 9 Classes, SysUtils, BGRABitmap, BGRABitmapTypes, FPimage; 10 10 11 function GetBitmapThumbnail(ABitmap: TBGRABitmap; AWidth,AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil; AVerticalShrink : single = 1): TBGRABitmap; 11 function GetBitmapThumbnail(ABitmap: TBGRACustomBitmap; AWidth,AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil; AVerticalShrink: single = 1; AHorizShrink: single = 1): TBGRABitmap; overload; 12 function GetBitmapThumbnail(ABitmap: TBGRACustomBitmap; AFormat: TBGRAImageFormat; AWidth,AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil; AVerticalShrink: single = 1; AHorizShrink: single = 1): TBGRABitmap; overload; 12 13 function GetFileThumbnail(AFilenameUTF8: string; AWidth,AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil): TBGRABitmap; 13 14 function GetStreamThumbnail(AStream: TStream; AWidth,AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ASuggestedExtensionUTF8: string = ''; ADest: TBGRABitmap= nil): TBGRABitmap; overload; … … 22 23 function GetPaintDotNetThumbnail(AStream: TStream; AWidth, AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil): TBGRABitmap; 23 24 function GetBmpThumbnail(AStream: TStream; AWidth, AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil): TBGRABitmap; 24 {$IFDEF BGRABITMAP_USE_LCL}25 25 function GetIcoThumbnail(AStream: TStream; AWidth, AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil): TBGRABitmap; 26 {$ENDIF} 26 function GetCurThumbnail(AStream: TStream; AWidth, AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil): TBGRABitmap; 27 27 28 28 function GetPcxThumbnail(AStream: TStream; AWidth, AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil): TBGRABitmap; … … 34 34 function GetBmpMioMapThumbnail(AStream: TStream; AWidth, AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil): TBGRABitmap; 35 35 36 procedure DrawThumbnailCheckers(bmp: TBGRABitmap; ARect: TRect); 36 procedure DrawThumbnailCheckers(bmp: TBGRABitmap; ARect: TRect; AIconCheckers: boolean = false); 37 38 var 39 ImageCheckersColor1,ImageCheckersColor2 : TBGRAPixel; 40 IconCheckersColor1,IconCheckersColor2 : TBGRAPixel; 37 41 38 42 implementation 39 43 40 uses Types, base64, BGRAUTF8, {$IFDEF BGRABITMAP_USE_LCL}Graphics, GraphType,{$ENDIF}44 uses Types, base64, BGRAUTF8, 41 45 DOM, XMLRead, BGRAReadJPEG, BGRAReadPng, BGRAReadGif, BGRAReadBMP, 42 46 BGRAReadPSD, BGRAReadIco, UnzipperExt, BGRAReadLzp; 43 47 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; 48 procedure DrawThumbnailCheckers(bmp: TBGRABitmap; ARect: TRect; AIconCheckers: boolean); 49 begin 50 if AIconCheckers then 51 bmp.DrawCheckers(ARect, IconCheckersColor1, IconCheckersColor2) 52 else 53 bmp.DrawCheckers(ARect, ImageCheckersColor1, ImageCheckersColor2); 54 end; 55 56 function 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; 51 58 var 52 59 factorX, factorY, factor: single; 53 60 xIcon,yIcon,wIcon,hIcon: Integer; 61 hotspot: TPoint; 54 62 begin 55 63 result := nil; … … 64 72 end else 65 73 result := TBGRABitmap.Create(AWidth,AHeight,ABackColor); 66 factorX := result.Width/ ABitmap.Width;74 factorX := result.Width/(ABitmap.Width*AHorizShrink); 67 75 factorY := result.Height/(ABitmap.Height*AVerticalShrink); 68 76 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; 70 79 hIcon := round(ABitmap.Height*AVerticalShrink*factor); 80 if hIcon = 0 then hIcon := 1; 71 81 xIcon:= (result.Width-wIcon) div 2; 72 82 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; 74 94 if (ABackColor.alpha <> 0) or ACheckers then 75 95 result.StretchPutImage(Rect(xIcon,yIcon,xIcon+wIcon,yIcon+hIcon),ABitmap,dmDrawWithTransparency) else 76 96 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; 77 102 end; 78 103 except 79 104 end; 105 end; 106 107 function GetBitmapThumbnail(ABitmap: TBGRACustomBitmap; AWidth, AHeight: integer; 108 ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap = nil; 109 AVerticalShrink: single = 1; AHorizShrink: single = 1): TBGRABitmap; 110 begin 111 result := InternalGetBitmapThumbnail(ABitmap,AWidth,AHeight,ABackColor,ACheckers,ADest,AVerticalShrink,AHorizShrink, 112 false,false); 113 end; 114 115 function GetBitmapThumbnail(ABitmap: TBGRACustomBitmap; AFormat: TBGRAImageFormat; AWidth, AHeight: integer; 116 ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap = nil; AVerticalShrink: single = 1; AHorizShrink: single = 1): TBGRABitmap; 117 begin 118 result := InternalGetBitmapThumbnail(ABitmap,AWidth,AHeight,ABackColor,ACheckers,ADest,AVerticalShrink,AHorizShrink, 119 AFormat = ifCur, AFormat in[ifCur,ifIco]); 120 80 121 end; 81 122 … … 83 124 var stream: TFileStreamUTF8; 84 125 begin 126 result := nil; 85 127 try 86 128 stream := TFileStreamUTF8.Create(AFilenameUTF8,fmOpenRead or fmShareDenyWrite); 87 129 except 88 result := nil;89 130 exit; 90 131 end; … … 99 140 ABackColor: TBGRAPixel; ACheckers: boolean; ASuggestedExtensionUTF8: string; 100 141 ADest: TBGRABitmap): TBGRABitmap; 101 begin 102 case DetectFileFormat(AStream,ASuggestedExtensionUTF8) of 142 var 143 ff: TBGRAImageFormat; 144 reader: TFPCustomImageReader; 145 begin 146 ff := DetectFileFormat(AStream,ASuggestedExtensionUTF8); 147 case ff of 103 148 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}108 149 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); 111 151 ifPaintDotNet: result := GetPaintDotNetThumbnail(AStream, AWidth,AHeight, ABackColor, ACheckers, ADest); 112 152 ifLazPaint: result := GetLazPaintThumbnail(AStream, AWidth,AHeight, ABackColor, ACheckers, ADest); … … 114 154 ifPhoxo: result := GetPhoxoThumbnail(AStream, AWidth,AHeight, ABackColor, ACheckers, ADest); 115 155 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);121 156 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; 123 172 end; 124 173 end; … … 127 176 AWidth, AHeight: integer; ABackColor: TBGRAPixel; ACheckers: boolean; 128 177 ADest: TBGRABitmap): TBGRABitmap; 129 var bmp: TBGRABitmap; 130 begin 178 var 179 bmp: TBGRACustomBitmap; 180 AOriginalWidth, AOriginalHeight: integer; 181 begin 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 131 197 bmp := TBGRABitmap.Create; 132 198 try … … 143 209 end; 144 210 end; 145 146 147 211 148 212 function GetOpenRasterThumbnail(AStream: TStream; AWidth, AHeight: integer; … … 234 298 end; 235 299 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; 300 function GetPngThumbnail(AStream: TStream; AWidth, AHeight: integer; 301 ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap= nil): TBGRABitmap; 302 var 303 pngFormat: TBGRAReaderPNG; 304 begin 305 pngFormat:= TBGRAReaderPNG.Create; 306 result:= GetStreamThumbnail(AStream, pngFormat, AWidth,AHeight, ABackColor, ACheckers, ADest); 307 pngFormat.Free; 258 308 end; 259 309 … … 303 353 if Assigned(pngNode) then 304 354 begin 305 png64 := TStringStream.Create( pngNode.NodeValue);355 png64 := TStringStream.Create(string(pngNode.NodeValue)); 306 356 try 307 357 png64.Position := 0; … … 327 377 var 328 378 bmpFormat: TBGRAReaderBMP; 329 bmp: TBGRABitmap;330 379 begin 331 380 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); 349 382 bmpFormat.Free; 350 383 end; 351 384 352 {$IFDEF BGRABITMAP_USE_LCL}353 385 function GetIcoThumbnail(AStream: TStream; AWidth, AHeight: integer; 354 386 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; 387 var 388 reader: TBGRAReaderIco; 389 icoBmp: TBGRABitmap; 359 390 begin 360 391 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; 403 end; 404 405 function GetCurThumbnail(AStream: TStream; AWidth, AHeight: integer; 406 ABackColor: TBGRAPixel; ACheckers: boolean; ADest: TBGRABitmap): TBGRABitmap; 407 var 408 reader: TBGRAReaderCur; 409 icoBmp: TBGRABitmap; 410 begin 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; 423 end; 398 424 399 425 function GetPcxThumbnail(AStream: TStream; AWidth, AHeight: integer; … … 467 493 end; 468 494 495 initialization 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 469 503 end. -
GraphicTest/Packages/bgrabitmap/bgratransform.pas
r494 r521 13 13 { Contains an affine matrix, i.e. a matrix to transform linearly and translate TPointF coordinates } 14 14 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; 32 17 33 18 { TBGRAAffineScannerTransform allow to transform any scanner. To use it, … … 87 72 procedure Init(ABitmap: TBGRACustomBitmap; ARepeatImageX: Boolean= false; ARepeatImageY: Boolean= false; AResampleFilter: TResampleFilter = rfLinear; AIncludeEdges: boolean = false); 88 73 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; 91 76 destructor Destroy; override; 92 77 function InternalScanCurrentPixel: TBGRAPixel; override; … … 137 122 constructor Create(ASource: IBGRAScanner; 138 123 ASourceMatrix: TAffineMatrix; const APoints: array of TPointF; 139 ATextureInterpolation: boolean = true); 124 ATextureInterpolation: boolean = true); overload; 140 125 constructor Create(ASource: IBGRAScanner; 141 126 const ATexCoords: array of TPointF; const APoints: array of TPointF; 142 ATextureInterpolation: boolean = true); 127 ATextureInterpolation: boolean = true); overload; 143 128 destructor Destroy; override; 144 129 property Culling: TFaceCulling read GetCulling write SetCulling; … … 191 176 {---------------------- Affine matrix functions -------------------} 192 177 //fill a matrix 193 function AffineMatrix(m11,m12,m13,m21,m22,m23: single): TAffineMatrix; 178 function AffineMatrix(m11,m12,m13,m21,m22,m23: single): TAffineMatrix; overload; 179 function AffineMatrix(AU,AV: TPointF; ATranslation: TPointF): TAffineMatrix; overload; 194 180 195 181 //matrix multiplication … … 200 186 operator *(M: TAffineMatrix; V: TPointF): TPointF; 201 187 operator *(M: TAffineMatrix; A: array of TPointF): ArrayOfTPointF; 188 operator *(M: TAffineMatrix; ab: TAffineBox): TAffineBox; 202 189 203 190 //check if matrix is inversible … … 221 208 //define a scaling matrix 222 209 function AffineMatrixScale(sx,sy: single): TAffineMatrix; 210 function AffineMatrixScaledRotation(ASourceVector, ATargetVector: TPointF): TAffineMatrix; 211 function AffineMatrixScaledRotation(ASourcePoint, ATargetPoint, AOrigin: TPointF): TAffineMatrix; 223 212 224 213 function AffineMatrixSkewXDeg(AngleCW: single): TAffineMatrix; … … 228 217 229 218 //define a linear matrix 230 function AffineMatrixLinear(v1,v2: TPointF): TAffineMatrix; 219 function AffineMatrixLinear(v1,v2: TPointF): TAffineMatrix; overload; 220 function AffineMatrixLinear(const AMatrix: TAffineMatrix): TAffineMatrix; overload; 231 221 232 222 //define a rotation matrix (positive radians are counter-clockwise) … … 242 232 243 233 function IsAffineMatrixOrthogonal(M: TAffineMatrix): boolean; 234 function IsAffineMatrixScaledRotation(M: TAffineMatrix): boolean; 244 235 245 236 type … … 278 269 procedure SetIncludeOppositePlane(AValue: boolean); 279 270 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; 282 273 destructor Destroy; override; 283 274 procedure ScanMoveTo(X, Y: Integer); override; … … 298 289 public 299 290 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; 303 294 function MapQuadToQuad(const srcQuad,destQuad: array of TPointF): boolean; 304 295 function MapRectToQuad(x1,y1,x2,y2: single; const quad: array of TPointF): boolean; … … 386 377 end; 387 378 379 function AffineMatrix(AU, AV: TPointF; ATranslation: TPointF): TAffineMatrix; 380 begin 381 result:= AffineMatrix(AU.x, AV.x, ATranslation.x, 382 AU.y, AV.y, ATranslation.y); 383 end; 384 388 385 operator *(M, N: TAffineMatrix): TAffineMatrix; 389 386 begin … … 427 424 for i := 0 to high(A) do 428 425 result[i] := M*A[i]; 426 end; 427 428 operator*(M: TAffineMatrix; ab: TAffineBox): TAffineBox; 429 begin 430 result.TopLeft := M*ab.TopLeft; 431 result.TopRight := M*ab.TopRight; 432 result.BottomLeft := M*ab.BottomLeft; 429 433 end; 430 434 … … 475 479 end; 476 480 481 function AffineMatrixScaledRotation(ASourceVector, ATargetVector: TPointF): TAffineMatrix; 482 var 483 prevScale, newScale, scale: Single; 484 u1,v1,u2,v2,w: TPointF; 485 begin 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; 500 end; 501 502 function AffineMatrixScaledRotation(ASourcePoint, ATargetPoint, AOrigin: TPointF): TAffineMatrix; 503 begin 504 result := AffineMatrixTranslation(AOrigin.x,AOrigin.y)* 505 AffineMatrixScaledRotation(ASourcePoint-AOrigin, ATargetPoint-AOrigin)* 506 AffineMatrixTranslation(-AOrigin.x,-AOrigin.y); 507 end; 508 477 509 function AffineMatrixSkewXDeg(AngleCW: single): TAffineMatrix; 478 510 begin … … 506 538 end; 507 539 540 function AffineMatrixLinear(const AMatrix: TAffineMatrix): TAffineMatrix; 541 begin 542 result := AffineMatrix(AMatrix[1,1],AMatrix[1,2],0, 543 AMatrix[2,1],AMatrix[2,2],0); 544 end; 545 508 546 function AffineMatrixRotationRad(AngleCCW: Single): TAffineMatrix; 509 547 begin … … 527 565 begin 528 566 result := PointF(M[1,1],M[2,1])*PointF(M[1,2],M[2,2]) = 0; 567 end; 568 569 function IsAffineMatrixScaledRotation(M: TAffineMatrix): boolean; 570 begin 571 result := IsAffineMatrixOrthogonal(M) and 572 (VectLen(PointF(M[1,1],M[2,1]))=VectLen(PointF(M[1,2],M[2,2]))); 529 573 end; 530 574 … … 608 652 if y > FBounds.Bottom-1 then y := FBounds.Bottom-1; 609 653 result := FSource.ScanAt(X,Y); 610 end;611 612 { TAffineBox }613 614 function TAffineBox.GetAsPolygon: ArrayOfTPointF;615 begin616 result := PointsF([TopLeft,TopRight,BottomRight,BottomLeft]);617 end;618 619 function TAffineBox.GetBottomRight: TPointF;620 begin621 if IsEmpty then622 result := EmptyPointF623 else624 result := TopRight + (BottomLeft-TopLeft);625 end;626 627 function TAffineBox.GetIsEmpty: boolean;628 begin629 result := isEmptyPointF(TopRight) or isEmptyPointF(BottomLeft) or isEmptyPointF(TopLeft);630 end;631 632 class function TAffineBox.EmptyBox: TAffineBox;633 begin634 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 begin641 result.TopLeft := ATopLeft;642 result.TopRight := ATopRight;643 result.BottomLeft := ABottomLeft;644 654 end; 645 655 -
GraphicTest/Packages/bgrabitmap/bgratypewriter.pas
r494 r521 35 35 end; 36 36 37 TGlyphPointCurveMode= (cmAuto, cmCurve, cmAngle); 38 37 TGlyphPointCurveMode= TEasyBezierCurveMode; 38 39 const 40 cmAuto = TEasyBezierCurveMode.cmAuto; 41 cmCurve = TEasyBezierCurveMode.cmCurve; 42 cmAngle = TEasyBezierCurveMode.cmAngle; 43 44 type 39 45 { TBGRAPolygonalGlyph } 40 46 41 47 TBGRAPolygonalGlyph = class(TBGRAGlyph) 42 48 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); 43 56 procedure SetQuadraticCurves(AValue: boolean); 44 57 protected 45 58 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; 54 60 function ContentSize: integer; override; 55 61 function HeaderName: string; override; 56 62 procedure WriteContent(AStream: TStream); override; 57 63 procedure ReadContent(AStream: TStream); override; 64 function PointTransformMatrix(APoint: PPointF; AData: pointer): TPointF; 58 65 procedure Init; 59 66 public 60 67 Offset: TPointF; 61 Closed: boolean;62 MinimumDotProduct: single;63 68 constructor Create(AIdentifier: string); override; 64 69 constructor Create(AStream: TStream); override; 70 constructor Create(AStream: TStream; AQuadratic: boolean); 65 71 procedure SetPoints(const APoints: array of TPointF); overload; 66 72 procedure SetPoints(const APoints: array of TPointF; const ACurveMode: array of TGlyphPointCurveMode); overload; 67 73 procedure Path(ADest: IBGRAPath; AMatrix: TAffineMatrix); override; 68 74 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; 69 79 end; 70 80 … … 193 203 { TBGRAPolygonalGlyph } 194 204 205 function TBGRAPolygonalGlyph.GetClosed: boolean; 206 begin 207 result := FEasyBezier.Closed; 208 end; 209 210 function TBGRAPolygonalGlyph.GetMinimumDotProduct: single; 211 begin 212 result := FEasyBezier.MinimumDotProduct; 213 end; 214 215 function TBGRAPolygonalGlyph.GetPoint(AIndex: integer): TPointF; 216 begin 217 result := FEasyBezier.Point[AIndex]; 218 end; 219 220 function TBGRAPolygonalGlyph.GetPointCount: integer; 221 begin 222 result := FEasyBezier.PointCount; 223 end; 224 225 procedure TBGRAPolygonalGlyph.SetClosed(AValue: boolean); 226 begin 227 FEasyBezier.Closed := AValue; 228 end; 229 230 procedure TBGRAPolygonalGlyph.SetMinimumDotProduct(AValue: single); 231 begin 232 FEasyBezier.MinimumDotProduct := AValue; 233 end; 234 235 procedure TBGRAPolygonalGlyph.SetPoint(AIndex: integer; AValue: TPointF); 236 begin 237 FEasyBezier.Point[AIndex] := AValue; 238 end; 239 195 240 procedure TBGRAPolygonalGlyph.SetQuadraticCurves(AValue: boolean); 196 241 begin 197 242 if FQuadraticCurves=AValue then Exit; 198 243 FQuadraticCurves:=AValue; 199 Curves := nil;200 end;201 202 function TBGRAPolygonalGlyph.MaybeCurve(start1,end1,start2,end2: integer): boolean;203 var204 u,v: TPointF;205 lu,lv: single;206 begin207 if (start1=-1) or (end1=-1) or (start2=-1) or (end2=-1) then208 begin209 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 var224 i,FirstPointIndex,NextPt,NextPt2: integer;225 begin226 setlength(Curves, length(points));227 FirstPointIndex := 0;228 for i := 0 to high(points) do229 Curves[i].isCurvedToPrevious := false;230 for i := 0 to high(points) do231 begin232 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]) then238 begin239 FirstPointIndex := i+1;240 end else241 begin242 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 then252 begin253 case CurveMode[nextPt] of254 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;262 244 end; 263 245 264 246 function TBGRAPolygonalGlyph.ContentSize: integer; 265 247 begin 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; 267 249 end; 268 250 269 251 function TBGRAPolygonalGlyph.HeaderName: string; 270 252 begin 271 Result:='TBGRAPolygonalGlyph'; 253 if FQuadraticCurves then 254 Result:='TBGRAEasyBezierGlyph' 255 else 256 Result:='TBGRAPolygonalGlyph' 272 257 end; 273 258 … … 277 262 inherited WriteContent(AStream); 278 263 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])); 282 270 end; 283 271 … … 285 273 var i: integer; 286 274 tempPts: array of TPointF; 275 flags: LongInt; 287 276 begin 288 277 inherited ReadContent(AStream); … … 292 281 tempPts[i] := LEReadPointF(AStream); 293 282 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; 291 end; 292 293 function TBGRAPolygonalGlyph.PointTransformMatrix(APoint: PPointF; 294 AData: pointer): TPointF; 295 begin 296 result := TAffineMatrix(AData^) * APoint^; 294 297 end; 295 298 296 299 procedure TBGRAPolygonalGlyph.Init; 297 300 begin 301 FEasyBezier.Init; 298 302 Closed := True; 299 MinimumDotProduct := 0.707; 303 Offset := PointF(0,0); 304 FQuadraticCurves:= False; 300 305 end; 301 306 302 307 constructor TBGRAPolygonalGlyph.Create(AIdentifier: string); 303 308 begin 309 Init; 304 310 inherited Create(AIdentifier); 305 Offset := PointF(0,0); 311 end; 312 313 constructor TBGRAPolygonalGlyph.Create(AStream: TStream); 314 begin 306 315 Init; 307 end;308 309 constructor TBGRAPolygonalGlyph.Create(AStream: TStream);310 begin311 316 inherited Create(AStream); 317 end; 318 319 constructor TBGRAPolygonalGlyph.Create(AStream: TStream; AQuadratic: boolean); 320 begin 312 321 Init; 322 FQuadraticCurves:= AQuadratic; 323 inherited Create(AStream); 313 324 end; 314 325 315 326 procedure 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; 327 begin 328 FEasyBezier.SetPoints(APoints, cmAuto); 325 329 end; 326 330 327 331 procedure TBGRAPolygonalGlyph.SetPoints(const APoints: array of TPointF; 328 332 const ACurveMode: array of TGlyphPointCurveMode); 329 var i: integer;330 333 begin 331 334 if length(APoints) <> length(ACurveMode) then 332 335 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); 340 337 end; 341 338 … … 343 340 var i: integer; 344 341 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; 342 begin 352 343 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 363 353 begin 364 354 if nextMove then 365 355 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]); 371 357 nextMove := false; 372 358 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]); 381 360 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); 395 364 end; 396 365 … … 473 442 if lName = 'TBGRAPolygonalGlyph' then 474 443 result := TBGRAPolygonalGlyph.Create(AStream) 444 else if lName = 'TBGRAEasyBezierGlyph' then 445 result := TBGRAPolygonalGlyph.Create(AStream, true) 475 446 else if lName = 'TBGRAGlyph' then 476 447 result := TBGRAGlyph.Create(AStream) -
GraphicTest/Packages/bgrabitmap/bgraunits.pas
r494 r521 47 47 property DefaultUnitHeight: TFloatWithCSSUnit read GetDefaultUnitHeight; 48 48 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; 58 59 property DpiX: single read GetDpiX; 59 60 property DpiY: single read GetDpiY; … … 135 136 136 137 function TCSSUnitConverter.Convert(xy: single; sourceUnit, destUnit: TCSSUnit; 137 dpi: single ): single;138 dpi: single; containerSize: single): single; 138 139 var sourceFactor, destFactor: integer; 139 140 begin … … 144 145 result := xy 145 146 else 147 if sourceUnit = cuPercent then 148 begin 149 result := xy/100*containerSize; 150 end else 146 151 if sourceUnit = cuFontEmHeight then 147 152 begin … … 185 190 186 191 function TCSSUnitConverter.ConvertWidth(x: single; sourceUnit, 187 destUnit: TCSSUnit ): single;192 destUnit: TCSSUnit; containerWidth: single): single; 188 193 begin 189 194 if sourceUnit = destUnit then … … 192 197 with DefaultUnitWidth do 193 198 begin 194 result := x*ConvertWidth(value,CSSUnit, destUnit )199 result := x*ConvertWidth(value,CSSUnit, destUnit, containerWidth) 195 200 end 196 201 else if destUnit = cuCustom then … … 202 207 result := x/value; 203 208 end else 204 result := Convert(x, sourceUnit, destUnit, DpiX );209 result := Convert(x, sourceUnit, destUnit, DpiX, containerWidth); 205 210 end; 206 211 207 212 function TCSSUnitConverter.ConvertHeight(y: single; sourceUnit, 208 destUnit: TCSSUnit ): single;213 destUnit: TCSSUnit; containerHeight: single): single; 209 214 begin 210 215 if sourceUnit = cuCustom then 211 216 with DefaultUnitHeight do 212 217 begin 213 result := y*ConvertHeight(value,CSSUnit, destUnit )218 result := y*ConvertHeight(value,CSSUnit, destUnit, containerHeight) 214 219 end 215 220 else if destUnit = cuCustom then … … 221 226 result := y/value; 222 227 end else 223 result := Convert(y, sourceUnit, destUnit, DpiY );228 result := Convert(y, sourceUnit, destUnit, DpiY, containerHeight); 224 229 end; 225 230 226 231 function TCSSUnitConverter.ConvertWidth(AValue: TFloatWithCSSUnit; 227 destUnit: TCSSUnit ): TFloatWithCSSUnit;232 destUnit: TCSSUnit; containerWidth: single): TFloatWithCSSUnit; 228 233 begin 229 234 result.CSSUnit := destUnit; 230 result.value:= ConvertWidth(AValue.value,AValue.CSSUnit,destUnit );235 result.value:= ConvertWidth(AValue.value,AValue.CSSUnit,destUnit,containerWidth); 231 236 end; 232 237 233 238 function TCSSUnitConverter.ConvertHeight(AValue: TFloatWithCSSUnit; 234 destUnit: TCSSUnit ): TFloatWithCSSUnit;239 destUnit: TCSSUnit; containerHeight: single): TFloatWithCSSUnit; 235 240 begin 236 241 result.CSSUnit := destUnit; 237 result.value:= ConvertHeight(AValue.value,AValue.CSSUnit,destUnit );242 result.value:= ConvertHeight(AValue.value,AValue.CSSUnit,destUnit,containerHeight); 238 243 end; 239 244 240 245 function 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; 247 begin 248 result.x := ConvertWidth(pt.x, sourceUnit, destUnit, containerWidth); 249 result.y := ConvertHeight(pt.y, sourceUnit, destUnit, containerHeight); 245 250 end; 246 251 … … 266 271 end; 267 272 273 class function TCSSUnitConverter.parseValue(AValue: string; ADefault: single): single; 274 var 275 errPos: integer; 276 begin 277 AValue := trim(AValue); 278 val(AValue,result,errPos); 279 if errPos <> 0 then 280 result := ADefault; 281 end; 282 268 283 class function TCSSUnitConverter.formatValue(AValue: TFloatWithCSSUnit; APrecision: integer = 7): string; 269 284 begin -
GraphicTest/Packages/bgrabitmap/bgrautf8.pas
r494 r521 7 7 8 8 uses 9 Classes, SysUtils {$IFDEF BGRABITMAP_USE_LCL}, lazutf8classes{$ENDIF};9 Classes, SysUtils, BGRAUnicode{$IFDEF BGRABITMAP_USE_LCL}, lazutf8classes{$ENDIF}; 10 10 11 11 {$IFDEF BGRABITMAP_USE_LCL} … … 19 19 FFileName: utf8string; 20 20 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; 23 23 destructor Destroy; override; 24 24 property FileName: utf8string Read FFilename; … … 60 60 61 61 function UTF8CharacterLength(p: PChar): integer; 62 function UTF8Length(const s: string): PtrInt; 63 function UTF8Length(p: PChar; ByteCount: PtrInt): PtrInt; 62 function UTF8Length(const s: string): PtrInt; overload; 63 function UTF8Length(p: PChar; ByteCount: PtrInt): PtrInt; overload; 64 64 function UnicodeCharToUTF8(u: cardinal): string4; 65 function UTF8ReverseString(const s: string): string; 66 function UTF8CodepointToUnicode(p: PChar; ACodePointLen: integer): cardinal; 67 68 type 69 TBidiUTF8Info = packed record 70 Offset: Integer; 71 BidiInfo: TUnicodeBidiInfo; 72 end; 73 TBidiUTF8Array = packed array of TBidiUTF8Info; 74 TUnicodeDisplayOrder = BGRAUnicode.TUnicodeDisplayOrder; 75 76 function GetBidiClassUTF8(P: PChar): TUnicodeBidiClass; 77 function GetFirstStrongBidiClassUTF8(const sUTF8: string): TUnicodeBidiClass; 78 function GetLastStrongBidiClassUTF8(const sUTF8: string): TUnicodeBidiClass; 79 function IsRightToLeftUTF8(const sUTF8: string): boolean; 80 function IsZeroWidthUTF8(const sUTF8: string): boolean; 81 function AddParagraphBidiUTF8(s: string; ARightToLeft: boolean): string; 82 function AnalyzeBidiUTF8(const sUTF8: string; ARightToLeft: boolean): TBidiUTF8Array; overload; 83 function AnalyzeBidiUTF8(const sUTF8: string): TBidiUTF8Array; overload; 84 function GetUTF8DisplayOrder(const ABidi: TBidiUTF8Array): TUnicodeDisplayOrder; 85 function ContainsBidiIsolateOrFormattingUTF8(const sUTF8: string): boolean; 86 87 function UTF8OverrideDirection(const sUTF8: string; ARightToLeft: boolean): string; 88 function UTF8EmbedDirection(const sUTF8: string; ARightToLeft: boolean): string; 65 89 66 90 //little endian stream functions 91 function LEReadInt64(Stream: TStream): int64; 92 procedure LEWriteInt64(Stream: TStream; AValue: int64); 67 93 function LEReadLongint(Stream: TStream): longint; 68 94 procedure LEWriteLongint(Stream: TStream; AValue: LongInt); … … 172 198 result := LazUtf8.UnicodeToUTF8(u); 173 199 end; 200 174 201 {$ELSE} 175 202 … … 457 484 {$ENDIF} 458 485 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)); 486 function UTF8ReverseString(const s: string): string; 487 var 488 pSrc,pDest,pEnd: PChar; 489 charLen: Integer; 490 begin 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; 508 end; 509 510 function UTF8CodepointToUnicode(p: PChar; ACodePointLen: integer): cardinal; 511 begin 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; 498 523 end; 499 524 … … 515 540 end; 516 541 542 function GetBidiClassUTF8(P: PChar): TUnicodeBidiClass; 543 begin 544 result := GetUnicodeBidiClass(UTF8CodepointToUnicode(P, UTF8CharacterLength(p))); 545 end; 546 547 function GetFirstStrongBidiClassUTF8(const sUTF8: string): TUnicodeBidiClass; 548 var 549 p,pEnd: PChar; 550 charLen: Integer; 551 u: Cardinal; 552 curBidi: TUnicodeBidiClass; 553 isolateNesting: integer; 554 begin 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); 580 end; 581 582 function GetLastStrongBidiClassUTF8(const sUTF8: string): TUnicodeBidiClass; 583 var 584 p,pEnd: PChar; 585 charLen: Integer; 586 u: Cardinal; 587 curBidi: TUnicodeBidiClass; 588 isolateNesting: integer; 589 begin 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; 615 end; 616 617 function IsRightToLeftUTF8(const sUTF8: string): boolean; 618 begin 619 result := GetFirstStrongBidiClassUTF8(sUTF8) in[ubcRightToLeft,ubcArabicLetter]; 620 end; 621 622 function IsZeroWidthUTF8(const sUTF8: string): boolean; 623 var 624 p,pEnd: PChar; 625 charLen: Integer; 626 u: Cardinal; 627 begin 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); 640 end; 641 642 function AddParagraphBidiUTF8(s: string; ARightToLeft: boolean): string; 643 var 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 669 var 670 charLen: integer; 671 u: Cardinal; 672 673 begin 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; 693 end; 694 695 type 696 TUnicodeArray = packed array of cardinal; 697 TIntegerArray = array of integer; 698 699 procedure UTF8ToUnicode(const sUTF8: string; out u: TUnicodeArray; out ofs: TIntegerArray); 700 var 701 index,len,charLen: integer; 702 p,pStart,pEnd: PChar; 703 begin 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; 735 end; 736 737 function AnalyzeBidiUTF8(const sUTF8: string; ABaseDirection: cardinal): TBidiUTF8Array; 738 var 739 u: TUnicodeArray; 740 ofs: TIntegerArray; 741 a: TUnicodeBidiArray; 742 i: Integer; 743 begin 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; 757 end; 758 759 function AnalyzeBidiUTF8(const sUTF8: string; ARightToLeft: boolean): TBidiUTF8Array; 760 begin 761 if ARightToLeft then 762 result := AnalyzeBidiUTF8(sUTF8, UNICODE_RIGHT_TO_LEFT_ISOLATE) 763 else 764 result := AnalyzeBidiUTF8(sUTF8, UNICODE_LEFT_TO_RIGHT_ISOLATE); 765 end; 766 767 function AnalyzeBidiUTF8(const sUTF8: string): TBidiUTF8Array; 768 begin 769 result := AnalyzeBidiUTF8(sUTF8, UNICODE_FIRST_STRONG_ISOLATE) 770 end; 771 772 function GetUTF8DisplayOrder(const ABidi: TBidiUTF8Array): TUnicodeDisplayOrder; 773 begin 774 if length(ABidi) = 0 then 775 result := nil 776 else 777 result := GetUnicodeDisplayOrder(@ABidi[0].BidiInfo, sizeof(TBidiUTF8Info), length(ABidi)); 778 end; 779 780 function ContainsBidiIsolateOrFormattingUTF8(const sUTF8: string): boolean; 781 var 782 p,pEnd: PChar; 783 charLen: Integer; 784 u: Cardinal; 785 begin 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); 802 end; 803 804 function UTF8OverrideDirection(const sUTF8: string; ARightToLeft: boolean): string; 805 begin 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); 810 end; 811 812 function UTF8EmbedDirection(const sUTF8: string; ARightToLeft: boolean): string; 813 begin 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); 818 end; 819 820 //little endian stream functions 821 function LEReadInt64(Stream: TStream): int64; 822 begin 823 Result := 0; 824 stream.Read(Result, sizeof(Result)); 825 Result := LEtoN(Result); 826 end; 827 828 procedure LEWriteInt64(Stream: TStream; AValue: int64); 829 begin 830 AValue := NtoLE(AValue); 831 stream.Write(AValue, sizeof(AValue)); 832 end; 833 834 function LEReadLongint(Stream: TStream): longint; 835 begin 836 Result := 0; 837 stream.Read(Result, sizeof(Result)); 838 Result := LEtoN(Result); 839 end; 840 841 procedure LEWriteLongint(Stream: TStream; AValue: LongInt); 842 begin 843 AValue := NtoLE(AValue); 844 stream.Write(AValue, sizeof(AValue)); 845 end; 846 847 function LEReadByte(Stream: TStream): byte; 848 begin 849 Result := 0; 850 stream.Read(Result, sizeof(Result)); 851 end; 852 853 procedure LEWriteByte(Stream: TStream; AValue: Byte); 854 begin 855 stream.Write(AValue, sizeof(AValue)); 856 end; 857 858 function LEReadSingle(Stream: TStream): single; 859 var 860 ResultAsDWord : longword absolute result; 861 begin 862 ResultAsDWord := 0; 863 stream.Read(ResultAsDWord, sizeof(Result)); 864 ResultAsDWord := LEtoN(ResultAsDWord); 865 end; 866 867 procedure LEWriteSingle(Stream: TStream; AValue: single); 868 var 869 ValueAsDWord : longword absolute AValue; 870 begin 871 ValueAsDWord := NtoLE(ValueAsDWord); 872 stream.Write(ValueAsDWord, sizeof(AValue)); 873 end; 874 517 875 end. 518 876 -
GraphicTest/Packages/bgrabitmap/bgravectorize.pas
r494 r521 63 63 ShadowOffset: TPoint; 64 64 65 constructor Create; 66 constructor Create(ADirectoryUTF8: string); 65 constructor Create; overload; 66 constructor Create(ADirectoryUTF8: string); overload; 67 67 function GetFontPixelMetric: TFontPixelMetric; override; 68 procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientation: integer; s: string; c: TBGRAPixel; align: TAlignment); over ride;69 procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientation: integer; s: string; texture: IBGRAScanner; align: TAlignment); over ride;70 procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; s: string; texture: IBGRAScanner; align: TAlignment); over ride;71 procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; s: string; c: TBGRAPixel; align: TAlignment); over ride;72 procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; s: string; style: TTextStyle; c: TBGRAPixel); over ride;73 procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; s: string; style: TTextStyle; texture: IBGRAScanner); over ride;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; 74 74 procedure CopyTextPathTo(ADest: IBGRAPath; x, y: single; s: string; align: TAlignment); override; 75 function HandlesTextPath: boolean; override; 75 76 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; 76 79 destructor Destroy; override; 77 80 end; … … 151 154 public 152 155 UnderlineDecoration,StrikeOutDecoration: boolean; 153 constructor Create; 154 constructor Create(AVectorizeLCL: boolean); 156 constructor Create; overload; 157 constructor Create(AVectorizeLCL: boolean); overload; 155 158 destructor Destroy; override; 156 159 function GetGlyphSize(AIdentifier:string): TPointF; … … 162 165 AAlign: TBGRATypeWriterAlignment=twaTopLeft); override; 163 166 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; 166 169 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; 169 172 procedure UpdateDirectory; 170 173 function LoadGlyphsInfo(AFilenameUTF8: string): TBGRAGlyphsInfo; … … 190 193 implementation 191 194 192 uses BGRAUTF8 ;195 uses BGRAUTF8, math; 193 196 194 197 function VectorizeMonochrome(ASource: TBGRACustomBitmap; zoom: single; PixelCenteredCoordinates: boolean): ArrayOfTPointF; … … 234 237 inc(nbpoints); 235 238 end; 236 procedure AddLine(x1,y1,x2,y2: integer); 239 procedure AddLine(x1,y1,x2,y2: integer); overload; 237 240 var i,j,k: integer; 238 241 begin … … 267 270 points[k].next := addpoint(x2,y2,k,-1); 268 271 end; 269 procedure AddLine(x1,y1,x2,y2,x3,y3: integer); 272 procedure AddLine(x1,y1,x2,y2,x3,y3: integer); overload; 270 273 begin 271 274 AddLine(x1,y1,x2,y2); 272 275 AddLine(x2,y2,x3,y3); 273 276 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; 275 278 begin 276 279 AddLine(x1,y1,x2,y2); … … 278 281 AddLine(x3,y3,x4,y4); 279 282 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; 281 284 begin 282 285 AddLine(x1,y1,x2,y2); … … 1225 1228 end; 1226 1229 1230 function TBGRAVectorizedFontRenderer.HandlesTextPath: boolean; 1231 begin 1232 Result:= true; 1233 end; 1234 1227 1235 function TBGRAVectorizedFontRenderer.TextSize(s: string): TSize; 1228 1236 var sizeF: TPointF; … … 1232 1240 result.cx := round(sizeF.x); 1233 1241 result.cy := round(sizeF.y); 1242 end; 1243 1244 function TBGRAVectorizedFontRenderer.TextSize(sUTF8: string; 1245 AMaxWidth: integer; ARightToLeft: boolean): TSize; 1246 var 1247 remains: string; 1248 w,h,totalH: single; 1249 begin 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); 1263 end; 1264 1265 function TBGRAVectorizedFontRenderer.TextFitInfo(sUTF8: string; 1266 AMaxWidth: integer): integer; 1267 var 1268 remains: string; 1269 begin 1270 UpdateFont; 1271 FVectorizedFont.SplitText(sUTF8, AMaxWidth, remains); 1272 result := length(sUTF8); 1234 1273 end; 1235 1274 … … 1351 1390 FFont.Height := FontEmHeightSign * 100; 1352 1391 lEmHeight := BGRATextSize(FFont, fqSystem, 'Hg', 1).cy; 1353 FFont.Height := F ontFullHeightSign * 100;1392 FFont.Height := FixLCLFontFullHeight(FFont.Name, FontFullHeightSign * 100); 1354 1393 lFullHeight := BGRATextSize(FFont, fqSystem, 'Hg', 1).cy; 1355 1394 if lEmHeight = 0 then … … 1392 1431 FFont.Name := FName; 1393 1432 FFont.Style := FStyle; 1394 FFont.Height := FontFullHeightSign * FResolution; 1433 FFont.Height := FixLCLFontFullHeight(FFont.Name, FontFullHeightSign * FResolution); 1434 FFont.Quality := fqNonAntialiased; 1395 1435 FFontEmHeightRatio := 1; 1396 1436 FFontEmHeightRatioComputed := false; … … 1960 2000 FBuffer.Fill(BGRAWhite); 1961 2001 FBuffer.Canvas.Font := FFont; 1962 FBuffer.Canvas.Font.Quality := fqNonAntialiased;1963 2002 FBuffer.Canvas.Font.Color := clBlack; 1964 2003 FBuffer.Canvas.TextOut(size.cy div 2,0,AIdentifier); -
GraphicTest/Packages/bgrabitmap/bgrawinbitmap.pas
r494 r521 53 53 public 54 54 procedure LoadFromBitmapIfNeeded; override; 55 procedure Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean=True); over ride;56 procedure Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean = True); over ride;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; 58 58 ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); override; 59 59 procedure GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer); override; … … 183 183 end; 184 184 185 procedure TBGRAWinBitmap.DataDrawOpaque(ACanvas: TCanvas; Rect: TRect;185 procedure TBGRAWinBitmap.DataDrawOpaque(ACanvas: TCanvas; ARect: TRect; 186 186 AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); 187 187 var … … 206 206 207 207 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, 210 210 0, 0, AWidth, AHeight, AData, info, DIB_RGB_COLORS, SRCCOPY); 211 211 -
GraphicTest/Packages/bgrabitmap/bgrawinresource.pas
r494 r521 6 6 7 7 uses 8 Classes, SysUtils, BGRAMultiFileType, BGRABitmapTypes ;8 Classes, SysUtils, BGRAMultiFileType, BGRABitmapTypes, BGRAReadBMP; 9 9 10 10 const … … 31 31 RT_HTML = 23; 32 32 RT_MANIFEST = 24; 33 34 ICON_OR_CURSOR_FILE_ICON_TYPE = 1; 35 ICON_OR_CURSOR_FILE_CURSOR_TYPE = 2; 33 36 34 37 type … … 95 98 constructor Create(AContainer: TMultiFileContainer; ATypeNameOrId: TNameOrId; AEntryNameOrId: TNameOrId; const AResourceInfo: TResourceInfo; ADataStream: TStream); 96 99 destructor Destroy; override; 97 function CopyTo(ADestination: TStream): int eger; override;100 function CopyTo(ADestination: TStream): int64; override; 98 101 end; 99 102 … … 106 109 public 107 110 constructor Create(AContainer: TMultiFileContainer; AEntryNameOrId: TNameOrId; const AResourceInfo: TResourceInfo; ADataStream: TStream); 108 function CopyTo(ADestination: TStream): int eger; override;111 function CopyTo(ADestination: TStream): int64; override; 109 112 procedure CopyFrom(ASource: TStream); 110 113 end; … … 151 154 constructor Create(AContainer: TMultiFileContainer; ATypeNameOrId: TNameOrId; AEntryNameOrId: TNameOrId; const AResourceInfo: TResourceInfo); 152 155 procedure Clear; 153 function CopyTo(ADestination: TStream): int eger; override;156 function CopyTo(ADestination: TStream): int64; override; 154 157 procedure CopyFrom(ASource: TStream); 155 158 property NbIcons: integer read GetNbIcons; … … 206 209 implementation 207 210 208 uses Math, B MPcomn, BGRAUTF8;211 uses Math, BGRAUTF8; 209 212 210 213 operator =(const ANameOrId1, ANameOrId2: TNameOrId): boolean; … … 216 219 end; 217 220 218 function NameOrId(AName: string): TNameOrId; 221 function NameOrId(AName: string): TNameOrId; overload; 219 222 begin 220 223 result.Id := -1; … … 222 225 end; 223 226 224 function NameOrId(AId: integer): TNameOrId; 227 function NameOrId(AId: integer): TNameOrId; overload; 225 228 begin 226 229 result.Id := AId; … … 237 240 function TGroupCursorEntry.ExpectedResourceType: word; 238 241 begin 239 result := 2;242 result := ICON_OR_CURSOR_FILE_CURSOR_TYPE; 240 243 end; 241 244 … … 262 265 function TGroupIconEntry.ExpectedResourceType: word; 263 266 begin 264 result := 1;267 result := ICON_OR_CURSOR_FILE_ICON_TYPE; 265 268 end; 266 269 … … 371 374 end; 372 375 373 function TGroupIconOrCursorEntry.CopyTo(ADestination: TStream): int eger;376 function TGroupIconOrCursorEntry.CopyTo(ADestination: TStream): int64; 374 377 var 375 378 fileDir: packed array of TIconFileDirEntry; … … 515 518 end; 516 519 517 function TBitmapResourceEntry.CopyTo(ADestination: TStream): integer; 518 var header: PBitMapInfoHeader; 519 fileHeader: TBitMapFileHeader; 520 headerSize: integer; 521 extraSize: integer; 522 520 function TBitmapResourceEntry.CopyTo(ADestination: TStream): int64; 521 var fileHeader: TBitMapFileHeader; 523 522 begin 524 523 result := 0; 525 524 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); 557 530 end; 558 531 … … 633 606 end; 634 607 635 function TUnformattedResourceEntry.CopyTo(ADestination: TStream): int eger;608 function TUnformattedResourceEntry.CopyTo(ADestination: TStream): int64; 636 609 begin 637 610 if FDataStream.Size > 0 then … … 1039 1012 'ico': begin 1040 1013 result := TGroupIconEntry.Create(self, entryName, resourceInfo); 1014 AContent.Position:= 0; 1041 1015 TGroupIconEntry(result).CopyFrom(AContent); 1016 AContent.Free; 1042 1017 end; 1043 1018 'cur': begin 1044 1019 result := TGroupCursorEntry.Create(self, entryName, resourceInfo); 1020 AContent.Position:= 0; 1045 1021 TGroupCursorEntry(result).CopyFrom(AContent); 1022 AContent.Free; 1046 1023 end; 1047 1024 'bmp': begin 1048 1025 result := TBitmapResourceEntry.Create(self, entryName, resourceInfo, AContent); 1026 AContent.Position:= 0; 1049 1027 TBitmapResourceEntry(result).CopyFrom(AContent); 1028 AContent.Free; 1050 1029 end; 1051 1030 'dat': result := TUnformattedResourceEntry.Create(self, NameOrId(RT_RCDATA), entryName, resourceInfo, AContent); -
GraphicTest/Packages/bgrabitmap/bgrawritelzp.pas
r494 r521 148 148 begin 149 149 IncludeThumbnail := false; 150 header.compressionMode:= CompressionMode; 150 header.compressionMode:= CompressionMode; //update field for thumbnail 151 151 end; 152 152 153 153 header.previewOffset:= Str.Position - startPos; 154 154 if Compression = lzpRLE then 155 WriteRLEImage(Str, Img )155 WriteRLEImage(Str, Img, Caption) 156 156 else 157 157 begin 158 158 compBmp := TBGRACompressableBitmap.Create(Img as TBGRABitmap); 159 compBmp.Caption := Caption; 159 160 compBmp.WriteToStream(Str); 160 161 compBmp.Free; -
GraphicTest/Packages/bgrabitmap/bgrawritepng.pas
r494 r521 80 80 function DoFilter (LineFilter:byte;index:longword; b:byte) : byte; virtual; 81 81 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; 84 84 function DecideGetPixel : TGetPixelFunc; virtual; 85 85 procedure DetermineHeader (var AHeader : THeaderChunk); virtual; -
GraphicTest/Packages/bgrabitmap/csscolorconst.inc
r494 r521 99 99 constructor Create; 100 100 {** Add a color to the list } 101 procedure Add(Name: string; const Color: TBGRAPixel); 101 procedure Add(Name: string; const Color: TBGRAPixel); overload; 102 102 {** Ends the color list and prevents further modifications } 103 103 procedure Finished; … … 137 137 {* Converts a fully defined string into a ''TBGRAPixel'' value. Color names from ''VGAColors'' and ''CSSColors'' 138 138 are used if there is an exact match } 139 function StrToBGRA(str: string): TBGRAPixel; 139 function StrToBGRA(str: string): TBGRAPixel; overload; 140 140 {* Converts a string into a ''TBGRAPixel'' value. If the value is not fully defined or that 141 141 there is an error, ''DefaultColor'' is returned. 142 142 Color names from ''VGAColors'' and ''CSSColors'' are used if there is an exact match. } 143 function StrToBGRA(str: string; const DefaultColor: TBGRAPixel): TBGRAPixel; 143 function StrToBGRA(str: string; const DefaultColor: TBGRAPixel): TBGRAPixel; overload; 144 144 {* Converts a string into a ''TBGRAPixel'' value. If the value is not fully defined, missing channels (expressed with '?') 145 145 are filled with fallbackValues. You can check if there was an error with the provided boolean. … … 311 311 function ParseColorValue(str: string; var flagError: boolean): byte; 312 312 var pourcent,unclipped,{%H-}errPos: integer; 313 pourcentF: single; 314 pourcentStr: string; 313 315 begin 314 316 if str = '' then result := 0 else … … 316 318 if str[length(str)]='%' then 317 319 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; 323 342 end else 324 343 begin -
GraphicTest/Packages/bgrabitmap/geometrytypes.inc
r494 r521 19 19 {$endif} 20 20 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 } 21 25 TAffineMatrix = array[1..2,1..3] of single; 22 26 … … 24 28 TRectF = Types.TRectF; 25 29 {$else} 30 {$define BGRA_DEFINE_TRECTF} 31 { TRectF } 32 26 33 TRectF = 27 34 {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} … … 29 36 {$endif FPC_REQUIRES_PROPER_ALIGNMENT} 30 37 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); 31 45 case Integer of 32 46 0: (Left, Top, Right, Bottom: Single); 33 47 1: (TopLeft, BottomRight: TPointF); 34 48 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 72 operator=(const ARect1,ARect2: TRect): boolean; 73 74 type 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 35 86 {$endif} 87 88 const 89 EmptyPoint : TPoint = (X: -2147483648; Y: -2147483648); 90 91 function IsEmptyPoint(const APoint: TPoint): boolean; 92 93 type 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 102 type 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 117 const 118 {* A value for an empty rectangle } 119 EmptyRectF : TRectF = (left:0; top:0; right:0; bottom: 0); 120 36 121 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 126 type 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; 37 155 38 156 const … … 43 161 {----------------- Operators for TPointF --------------------} 44 162 {** 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; 46 165 {** Checks if the structure is empty (equal to ''EmptyPointF'') } 47 166 function isEmptyPointF(const pt: TPointF): boolean; … … 68 187 type 69 188 TFaceCulling = (fcNone, fcKeepCW, fcKeepCCW); 70 {* Contains an array of points with single-precision floating point coordinates }71 ArrayOfTPointF = array of TPointF;72 189 73 190 {** Creates an array of ''TPointF'' } … … 109 226 ssRoundOutside, 110 227 {** 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); 175 231 176 232 type … … 271 327 procedure SetStrokeMatrix(const AValue: TAffineMatrix); virtual; abstract; 272 328 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; 275 331 function ComputePolylineAutoCycle(const APoints: array of TPointF; AWidth: single): ArrayOfTPointF; virtual; abstract; 276 332 function ComputePolygon(const APoints: array of TPointF; AWidth: single): ArrayOfTPointF; virtual; abstract; … … 325 381 {** Computes the intersection of two lines. If they are parallel, returns 326 382 the middle of the segment between the two origins } 327 function IntersectLine(line1, line2: TLineDef): TPointF; 383 function IntersectLine(line1, line2: TLineDef): TPointF; overload; 328 384 {** Computes the intersection of two lines. If they are parallel, returns 329 385 the middle of the segment between the two origins. The value ''parallel'' 330 386 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; 332 388 {** Checks if the polygon formed by the given points is convex. ''IgnoreAlign'' 333 389 specifies that if the points are aligned, it should still be considered as convex } … … 348 404 procedure closePath; 349 405 {** Moves to a location, disconnected from previous points } 350 procedure moveTo(const pt: TPointF);406 procedure moveTo(constref pt: TPointF); 351 407 {** Adds a line from the current point } 352 procedure lineTo(const pt: TPointF);408 procedure lineTo(constref pt: TPointF); 353 409 {** Adds a polyline from the current point } 354 410 procedure polylineTo(const pts: array of TPointF); 355 411 {** Adds a quadratic Bézier curve from the current point } 356 procedure quadraticCurveTo(const cp,pt: TPointF);412 procedure quadraticCurveTo(constref cp,pt: TPointF); 357 413 {** 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); 359 415 {** 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); 361 417 {** Adds an opened spline. If there is a current point, it is connected to the beginning of the spline } 362 418 procedure openedSpline(const pts: array of TPointF; style: TSplineStyle); … … 366 422 procedure copyTo(dest: IBGRAPath); 367 423 {** Returns the content of the path as an array of points } 368 function getPoints: ArrayOfTPointF; 424 function getPoints: ArrayOfTPointF; overload; 369 425 {** 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; 371 427 {** Returns a cursor to go through the path. The cursor must be freed by calling ''Free''. } 372 428 function getCursor: TBGRACustomPathCursor; 373 429 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; 374 458 375 459 { TBGRACustomPathCursor } … … 420 504 end; 421 505 506 var 507 BGRAPathFactory: TBGRAPathAny; 508 422 509 const 423 510 {* A value for an empty rectangle } … … 428 515 {* Creates a rectangle with the specified ''width'' and ''height'' } 429 516 function RectWithSize(left,top,width,height: integer): TRect; 517 518 {$DEFINE INCLUDE_INTERFACE} 519 {$I bezier.inc} 430 520 431 521 type … … 501 591 gtDiamond, 502 592 {** 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); 504 596 const 505 597 {** List of string to represent gradient types } 506 598 GradientTypeStr : array[TGradientType] of string 507 = ('Linear','Reflected','Diamond','Radial' );599 = ('Linear','Reflected','Diamond','Radial','Angular'); 508 600 {** Returns the gradient type represented by the given string } 509 601 function StrToGradientType(str: string): TGradientType; … … 539 631 {$UNDEF INCLUDE_IMPLEMENTATION} 540 632 633 {$IFDEF BGRA_DEFINE_TRECTF} 634 { TRectF } 635 636 function TRectF.GetHeight: single; 637 begin 638 result := Bottom-Top; 639 end; 640 641 function TRectF.GetWidth: Single; 642 begin 643 result := Right-Left; 644 end; 645 646 procedure TRectF.Offset(const dx, dy: Single); 647 begin 648 left:=left+dx; right:=right+dx; 649 bottom:=bottom+dy; top:=top+dy; 650 end; 651 652 { TRectHelper } 653 654 function TRectHelper.GetHeight: integer; 655 begin 656 result := Bottom-Top; 657 end; 658 659 function TRectHelper.GetIsEmpty: boolean; 660 begin 661 result := (Width = 0) and (Height = 0) 662 end; 663 664 function TRectHelper.GetWidth: integer; 665 begin 666 result := Right-Left; 667 end; 668 669 procedure TRectHelper.SetHeight(AValue: integer); 670 begin 671 Bottom := Top+AValue; 672 end; 673 674 procedure TRectHelper.SetWidth(AValue: integer); 675 begin 676 Right := Left+AValue; 677 end; 678 679 constructor TRectHelper.Create(Origin: TPoint; AWidth, AHeight: Longint); 680 begin 681 self.Left := Origin.X; 682 self.Top := Origin.Y; 683 self.Right := Origin.X+AWidth; 684 self.Bottom := Origin.Y+AHeight; 685 end; 686 687 constructor TRectHelper.Create(ALeft, ATop, ARight, ABottom: Longint); 688 begin 689 self.Left := ALeft; 690 self.Top := ATop; 691 self.Right := ARight; 692 self.Bottom := ABottom; 693 end; 694 695 procedure TRectHelper.Intersect(const ARect: TRect); 696 begin 697 IntersectRect(self, self, ARect); 698 end; 699 700 procedure TRectHelper.Offset(DX, DY: Longint); 701 begin 702 OffsetRect(self, DX,DY); 703 end; 704 705 procedure TRectHelper.Inflate(DX, DY: Longint); 706 begin 707 InflateRect(self, DX,DY); 708 end; 709 710 function TRectHelper.Contains(const APoint: TPoint): boolean; 711 begin 712 result := (APoint.X >= Left) and (APoint.X <= Right) and 713 (APoint.Y >= Top) and (APoint.Y <= Bottom); 714 end; 715 716 function TRectHelper.Contains(const ARect: TRect): boolean; 717 begin 718 Result := (Left <= ARect.Left) and (ARect.Right <= Right) and (Top <= ARect.Top) and (ARect.Bottom <= Bottom); 719 end; 720 721 operator =(const ARect1, ARect2: TRect): boolean; 722 begin 723 result:= (ARect1.Left = ARect2.Left) and (ARect1.Top = ARect2.Top) and 724 (ARect1.Right = ARect2.Right) and (ARect1.Bottom = ARect2.Bottom); 725 end; 726 727 { TSizeHelper } 728 729 function TSizeHelper.GetHeight: integer; 730 begin 731 result := cy; 732 end; 733 734 function TSizeHelper.GetWidth: integer; 735 begin 736 result := cx; 737 end; 738 739 {$ENDIF} 740 741 function IsEmptyPoint(const APoint: TPoint): boolean; 742 begin 743 result := (APoint.x = -2147483648) or (APoint.y = -2147483648); 744 end; 745 746 function TPointFHelper.Ceiling: TPoint; 747 begin 748 if isEmptyPointF(self) then 749 result := EmptyPoint 750 else 751 begin 752 result.x:=ceil(x); 753 result.y:=ceil(y); 754 end; 755 end; 756 757 function TPointFHelper.Truncate: TPoint; 758 begin 759 if isEmptyPointF(self) then 760 result := EmptyPoint 761 else 762 begin 763 result.x:=trunc(x); 764 result.y:=trunc(y); 765 end; 766 end; 767 768 function TPointFHelper.Floor: TPoint; 769 begin 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; 777 end; 778 779 function TPointFHelper.Round: TPoint; 780 begin 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; 788 end; 789 790 function TPointFHelper.Length: Single; 791 begin 792 result:= VectLen(self); 793 end; 794 795 class function TRectFHelper.Intersect(const R1: TRectF; const R2: TRectF): TRectF; 796 begin 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; 803 end; 804 805 class function TRectFHelper.Union(const R1: TRectF; const R2: TRectF): TRectF; 806 begin 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); 811 end; 812 813 class function TRectFHelper.Union(const R1: TRectF; const R2: TRectF; ADiscardEmpty: boolean): TRectF; 814 begin 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); 818 end; 819 820 function TRectFHelper.Union(const r: TRectF): TRectF; 821 begin 822 result := TRectF.Union(self, r); 823 end; 824 825 function TRectFHelper.Union(const r: TRectF; ADiscardEmpty: boolean): TRectF; 826 begin 827 result := TRectF.Union(self, r, ADiscardEmpty); 828 end; 829 830 function TRectFHelper.IntersectsWith(const r: TRectF): boolean; 831 begin 832 result:= not TRectF.Intersect(self, r).IsEmpty; 833 end; 834 835 function TRectFHelper.IsEmpty: boolean; 836 begin 837 result:= IsEmptyRectF(self); 838 end; 839 840 { TAffineBox } 841 842 function TAffineBox.GetAsPolygon: ArrayOfTPointF; 843 begin 844 result := PointsF([TopLeft,TopRight,BottomRight,BottomLeft]); 845 end; 846 847 function TAffineBox.GetBottomRight: TPointF; 848 begin 849 if IsEmpty then 850 result := EmptyPointF 851 else 852 result := TopRight + (BottomLeft-TopLeft); 853 end; 854 855 function TAffineBox.GetHeight: single; 856 begin 857 if isEmptyPointF(TopLeft) or isEmptyPointF(BottomLeft) then 858 result := 0 859 else 860 result := VectLen(BottomLeft-TopLeft); 861 end; 862 863 function TAffineBox.GetIsEmpty: boolean; 864 begin 865 result := isEmptyPointF(TopRight) or isEmptyPointF(BottomLeft) or isEmptyPointF(TopLeft); 866 end; 867 868 function TAffineBox.GetRectBounds: TRect; 869 begin 870 with GetRectBoundsF do 871 result := Rect(floor(Left),floor(Top),ceil(Right),ceil(Bottom)); 872 end; 873 874 function TAffineBox.GetRectBoundsF: TRectF; 875 var 876 x1,y1,x2,y2: single; 877 begin 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); 893 end; 894 895 function TAffineBox.GetSurface: single; 896 var 897 u, v: TPointF; 898 lenU, lenH: Single; 899 begin 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); 907 end; 908 909 function TAffineBox.GetWidth: single; 910 begin 911 if isEmptyPointF(TopLeft) or isEmptyPointF(TopRight) then 912 result := 0 913 else 914 result := VectLen(TopRight-TopLeft); 915 end; 916 917 class function TAffineBox.EmptyBox: TAffineBox; 918 begin 919 result.TopLeft := EmptyPointF; 920 result.TopRight := EmptyPointF; 921 result.BottomLeft := EmptyPointF; 922 end; 923 924 class function TAffineBox.AffineBox(ATopLeft, ATopRight, ABottomLeft: TPointF): TAffineBox; 925 begin 926 result.TopLeft := ATopLeft; 927 result.TopRight := ATopRight; 928 result.BottomLeft := ABottomLeft; 929 end; 930 931 class function TAffineBox.AffineBox(ARectF: TRectF): TAffineBox; 932 begin 933 result.TopLeft := ARectF.TopLeft; 934 result.TopRight := PointF(ARectF.Right, ARectF.Top); 935 result.BottomLeft := PointF(ARectF.Left, ARectF.Bottom); 936 end; 937 938 function TAffineBox.Contains(APoint: TPointF): boolean; 939 var 940 u,v,perpU,perpV: TPointF; 941 posV1, posV2, posU1, posU2: single; 942 begin 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); 964 end; 965 541 966 function StrToGradientType(str: string): TGradientType; 542 967 var gt: TGradientType; … … 667 1092 end; 668 1093 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 1096 function 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}; 1097 begin 1098 if GetInterface(iid, obj) then 1099 Result := S_OK 1100 else 1101 Result := longint(E_NOINTERFACE); 1102 end; 1103 1104 { There is no automatic reference counting, but it is compulsory to define these functions } 1105 function TBGRACustomPath._AddRef: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND}; 1106 begin 1107 result := 0; 1108 end; 1109 1110 function TBGRACustomPath._Release: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND}; 1111 begin 1112 result := 0; 696 1113 end; 697 1114 … … 832 1249 end; 833 1250 1251 function RectF(const ATopLeft, ABottomRight: TPointF): TRectF; 1252 begin 1253 result.TopLeft:= ATopLeft; 1254 result.BottomRight:= ABottomRight; 1255 end; 1256 1257 function RectWithSizeF(left, top, width, height: Single): TRectF; 1258 begin 1259 result.Left:= Left; 1260 result.Top:= Top; 1261 result.Right:= left+width; 1262 result.Bottom:= top+height; 1263 end; 1264 1265 function IsEmptyRectF(const ARect: TRectF): boolean; 1266 begin 1267 result:= (ARect.Width = 0) and (ARect.Height = 0); 1268 end; 1269 834 1270 function PointF(x, y: single): TPointF; 835 1271 begin 836 1272 Result.x := x; 837 1273 Result.y := y; 1274 end; 1275 1276 function PointF(pt: TPoint): TPointF; 1277 begin 1278 if IsEmptyPoint(pt) then 1279 result:= EmptyPointF 1280 else 1281 begin 1282 Result.x := pt.x; 1283 Result.y := pt.y; 1284 end; 838 1285 end; 839 1286 … … 867 1314 function VectLen(v: TPointF): single; 868 1315 begin 869 result := sqrt(v*v); 1316 if isEmptyPointF(v) then 1317 result := EmptySingle 1318 else 1319 result := sqrt(v*v); 870 1320 end; 871 1321 … … 1069 1519 end; 1070 1520 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 1553 1524 {$ENDIF} -
GraphicTest/Packages/bgrabitmap/lineartexscan.inc
r494 r521 21 21 procedure NextLight; inline; 22 22 begin 23 inc(light,lightStep);23 light := (light+lightStep) and 65535; 24 24 inc(lightAcc,lightDiff); 25 25 if lightAcc >= lightMod then 26 26 begin 27 27 dec(lightAcc,lightMod); 28 inc(light);28 light := (light + 1) and 65535; 29 29 end; 30 30 end; … … 53 53 light := info1.lightness; 54 54 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; 58 67 end; 59 68 lightAcc := lightDiff div 2; -
GraphicTest/Packages/bgrabitmap/multishapeline.inc
r494 r521 2 2 for k := 0 to NbShapeRows-1 do 3 3 with shapeRow[shapeRowsList[k]],shapes[shapeRowsList[k]] do 4 if densMinx <= densMaxx then 4 5 begin 6 if densMinx < minx then densMinx := minx; 7 if densMaxx > maxx then densMaxx := maxx; 8 5 9 if texture <> nil then 6 10 begin … … 11 15 with sums[xb-minx] do 12 16 begin 13 j := pdens^; inc(pdens); 14 if j <> 0 then 17 if pdens^ <> 0 then 15 18 begin 16 19 ec := GammaExpansion(ScanNextFunc()); 17 20 {$ifdef PARAM_ANTIALIASINGFACTOR} 18 w := DivByAntialiasPrecision65536( j*ec.alpha);21 w := DivByAntialiasPrecision65536(pdens^ * ec.alpha); 19 22 {$else} 20 w := ( j*ec.alpha) shr 16;23 w := (pdens^ * ec.alpha) shr 16; 21 24 {$endif} 22 25 if w <> 0 then … … 29 32 end else 30 33 ScanNextFunc(); 34 inc(pdens); 31 35 end; 32 36 end else … … 37 41 with sums[xb-minx] do 38 42 begin 39 j := pdens^; inc(pdens); 40 if j <> 0 then 43 if pdens^ <> 0 then 41 44 begin 42 45 {$ifdef PARAM_ANTIALIASINGFACTOR} 43 w := DivByAntialiasPrecision65536( j*ec.alpha);46 w := DivByAntialiasPrecision65536(pdens^ * ec.alpha); 44 47 {$else} 45 w := ( j*ec.alpha) shr 16;48 w := (pdens^ * ec.alpha) shr 16; 46 49 {$endif} 47 50 if w <> 0 then … … 53 56 end; 54 57 end; 58 inc(pdens); 55 59 end; 56 60 end; -
GraphicTest/Packages/bgrabitmap/paletteformats.inc
r494 r521 96 96 AStream.WriteBuffer(AValue,sizeof(AValue)); 97 97 end; 98 procedure WriteBlock(ABlockType: Int16; AContentLength: Int32); 98 procedure WriteBlock(ABlockType: Int16; AContentLength: Int32); overload; 99 99 begin 100 100 WriteInt16(ABlockType); … … 102 102 end; 103 103 104 procedure WriteBlock(ABlockType: Int16; AName: string; AExtraContentLength: Int32); 104 procedure WriteBlock(ABlockType: Int16; AName: string; AExtraContentLength: Int32); overload; 105 105 var contentLength: Int32; 106 106 wideName: UnicodeString; -
GraphicTest/Packages/bgrabitmap/part3d.inc
r494 r521 19 19 destructor Destroy; override; 20 20 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; 35 35 procedure RemoveVertex(Index: integer); 36 36 procedure RemoveNormal(Index: integer); … … 50 50 procedure SetNormal(AIndex: Integer; AValue: IBGRANormal3D); 51 51 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; 57 57 procedure RotateXDeg(angle: single; Before: boolean = true); 58 58 procedure RotateYDeg(angle: single; Before: boolean = true); -
GraphicTest/Packages/bgrabitmap/perspectivescan.inc
r494 r521 51 51 procedure NextLight; inline; 52 52 begin 53 inc(light,lightStep);53 light := (light+lightStep) and 65535; 54 54 inc(lightAcc,lightDiff); 55 55 if lightAcc >= lightMod then 56 56 begin 57 57 dec(lightAcc,lightMod); 58 inc(light);58 light := (light + 1) and 65535; 59 59 end; 60 60 end; … … 101 101 light := info1.lightness; 102 102 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; 106 115 end; 107 116 lightAcc := lightDiff div 2; -
GraphicTest/Packages/bgrabitmap/vertex3d.inc
r494 r521 16 16 FFaceColorsInvalidated, 17 17 FMaterialInvalidated: boolean; 18 procedure AddFace(AFace: IBGRAFace3D); 18 procedure AddFace(AFace: IBGRAFace3D); overload; 19 19 public 20 20 constructor Create(AScene: TBGRAScene3D); … … 23 23 procedure InvalidateColor; 24 24 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; 30 30 function AddFaceReversed(const AVertices: array of IBGRAVertex3D): IBGRAFace3D; 31 31 procedure ComputeWithMatrix(constref AMatrix: TMatrix3D; constref AProjection: TProjection3D); -
GraphicTest/UMainForm.pas
r472 r521 6 6 7 7 uses 8 Classes, SysUtils, FileUtil, SynHighlighterPas, SynMemo, Forms, Controls,8 Classes, SysUtils, LazFileUtils, SynHighlighterPas, SynMemo, Forms, Controls, 9 9 Graphics, Dialogs, ComCtrls, ExtCtrls, StdCtrls, DateUtils, UPlatform, 10 10 LCLType, IntfGraphics, fpImage, Math, GraphType, Contnrs, LclIntf, Spin, … … 337 337 Copy(TDrawMethod(DrawMethods[ListViewMethods.Selected.Index]).ClassName, 2, High(Integer)) + '.pas'; 338 338 339 if FileExists UTF8(FileName) then339 if FileExists(FileName) then 340 340 SynMemo1.Lines.LoadFromFile(FileName) 341 341 else SynMemo1.Lines.Clear;
Note:
See TracChangeset
for help on using the changeset viewer.